Skip to content

Configure editing setup matrix for dose response curves #143

New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Merged
Rudhik1904 merged 5 commits into from
Dec 12, 2025
Merged

Configure editing setup matrix for dose response curves #143

Show file tree
Hide file tree
Changes from all commits
Commits
Show all changes
5 commits
Select commit Hold shift + click to select a range
14d767a
making the comparision matrix editable
Rudhik1904 Dec 9, 2025
c29ad03
Adding Tests
Rudhik1904 Dec 10, 2025
c326c44
Adding instructions for users to edit the setup matrix
Rudhik1904 Dec 10, 2025
3196d98
bug fix: fix indexing for get_data()
tonywu1999 Dec 10, 2025
29fea49
Adding contrast render_group_comparision_plot_inputs()
Rudhik1904 Dec 11, 2025
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
4 changes: 2 additions & 2 deletions R/module-qc-server.R
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -36,12 +36,12 @@ qcServer <- function(input, output, session,parent_session, loadpage_input,get_d
# selectizeInput(ns("names"), "choose standard", unique(get_data()[2]), multiple = TRUE)
# }
# else{
selectizeInput(ns("names"), "choose standard", unique(get_data()[1]), multiple = TRUE)
selectizeInput(ns("names"), "choose standard", unique(get_data()$ProteinName), multiple = TRUE)
# }

}
else if (input$standards == "Peptides") {
selectizeInput(ns("names"), "choose standard", unique(get_data()[2]), multiple = TRUE)
selectizeInput(ns("names"), "choose standard", unique(get_data()$PeptideSequence), multiple = TRUE)
}

})
Expand Down
83 changes: 71 additions & 12 deletions R/module-statmodel-server.R
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -71,8 +71,6 @@ render_custom_non_pairwise_inputs = function(output, session, condition_list) {
})
}

# Todo: Add helper function to render dose response curve inputs

validate_contrast_inputs = function(input, contrast_mode, condition_list) {
if (contrast_mode == CONSTANTS_STATMODEL$comparison_mode_custom_pairwise) {
validate(
Expand Down Expand Up @@ -210,6 +208,34 @@ build_response_curve_matrix = function(condition_list) {
return(data.frame(GROUP = condition_list, condition_to_metadata_table))
}

#' Update a matrix or data frame from a DT cell edit event
#'
#' @param mat The matrix or data.frame to be updated.
#' @param info The `input$table_cell_edit` object from a DT edit event.
#'
#' @return The updated matrix or data.frame.
#' @noRd
update_matrix_from_edit = function(mat, info) {
# DT provides 1-based indices for rows and columns in the edit event
i <- info$row
j <- info$col
v <- info$value

# Coerce the new value to the type of the target column to maintain data integrity
if (is.data.frame(mat)) {
# For data frames, coerce to the column's class.
# tryCatch prevents the app from crashing if the user enters an invalid
# value (e.g., text in a numeric column). If coercion fails, the original value is kept.
v <- tryCatch(as(v, class(mat[[j]])), error = function(e) v)
mat[i, j] <- v
} else {
# For matrices, all elements have the same type. Coerce to the matrix's class.
v <- tryCatch(as(v, class(mat[1, 1])), error = function(e) v)
mat[i, j] <- v
}
return(mat)
}

#' Get TMT moderation radio button conditioned on if experiment is TMT
#' @noRd
get_tmt_moderation_radio_button <- function(loadpage_input, ns) {
Expand All @@ -224,7 +250,7 @@ get_tmt_moderation_radio_button <- function(loadpage_input, ns) {
# Plotting Functions
# ============================================================================

render_group_comparison_plot_inputs = function(output, session, rownames, get_data, input, loadpage_input, condition_list) {
render_group_comparison_plot_inputs = function(output, session, rownames, get_data, input, loadpage_input, condition_list,contrast) {
ns = session$ns

output[[NAMESPACE_STATMODEL$visualization_which_comparison]] = renderUI({
Expand All @@ -236,7 +262,7 @@ render_group_comparison_plot_inputs = function(output, session, rownames, get_da
output[[NAMESPACE_STATMODEL$visualization_which_protein]] = renderUI({
selectInput(ns(NAMESPACE_STATMODEL$visualization_which_protein),
label = h4("which protein to plot"),
unique(get_data()[[1]]))
unique(get_data()$ProteinName))
})
Comment on lines 262 to 266
Copy link
Copy Markdown

@coderabbitai coderabbitai Bot Dec 11, 2025

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

⚠️ Potential issue | 🟠 Major

🧩 Analysis chain

🏁 Script executed:

#!/bin/bash
# Check ProteinName and protein_column usage
echo "=== Searching for ProteinName usage ==="
rg -n "ProteinName" -S --type r

echo ""
echo "=== Searching for protein_column configuration ==="
rg -n 'protein_column' -S --type r

echo ""
echo "=== Checking the specific lines mentioned ==="
sed -n '262,266p' R/module-statmodel-server.R
echo "---"
sed -n '695,721p' R/module-statmodel-server.R

echo ""
echo "=== Searching for Protein column usage ==="
rg -n '"Protein"' -S --type r | head -20

Repository: Vitek-Lab/MSstatsShiny

Length of output: 8719

🏁 Script executed:

#!/bin/bash
# Check what columns ProteinLevelData contains
echo "=== Searching for ProteinLevelData column definitions ==="
rg -n "ProteinLevelData" -S --type r -A 3 -B 3

echo ""
echo "=== Checking preprocess_data function ==="
rg -n "def preprocess_data\|function.*preprocess" -S --type r

Repository: Vitek-Lab/MSstatsShiny

Length of output: 13049

Fix protein selector to use protein-level data column name

The protein selector at lines 262-266 sources choices from get_data()$ProteinName, which is the feature-level protein identifier column. However, at lines 707-721, the response curve analysis uses preprocess_data()$ProteinLevelData with protein_column = "Protein" in MSstatsPrepareDoseResponseFit.

Since ProteinLevelData uses the "Protein" column (not "ProteinName"), the protein names selected by the UI won't match the identifiers available in the prepared data, causing downstream filtering to return empty results.

Change line 265 to:

unique(preprocess_data()$ProteinLevelData$Protein)

This same issue applies at lines 695-721 where the response curve branch uses the same selector input.

🤖 Prompt for AI Agents 
In R/module-statmodel-server.R around lines 262-266 (and likewise the
response-curve branch around lines 695-721), the selectInput choices are pulled
from get_data()$ProteinName (feature-level column) but the downstream
response-curve analysis and filtering use preprocess_data()$ProteinLevelData
with the "Protein" column; update the selectInput choices to source unique names
from preprocess_data()$ProteinLevelData$Protein so the UI selection matches the
prepared protein-level identifiers used later, and keep the input id/namespace
unchanged.


output[[NAMESPACE_STATMODEL$visualization_plot_options_conditional_panel]] <- renderUI({
Expand Down Expand Up @@ -264,13 +290,12 @@ render_group_comparison_plot_inputs = function(output, session, rownames, get_da
}
})


# Rudhik TODO: change build_response_curve_matrix(condition_list())$drug

# to the drug column of the user-defined matrix
output[[NAMESPACE_STATMODEL$visualization_response_curve_which_drug]] = renderUI({
if (input[[NAMESPACE_STATMODEL$visualization_plot_type]] ==
CONSTANTS_STATMODEL$plot_type_response_curve) {
response_curve_setup_matrix = build_response_curve_matrix(condition_list())
response_curve_setup_matrix = contrast$matrix
unique_drugs = unique(response_curve_setup_matrix$drug)
unique_drugs_without_control = unique_drugs[unique_drugs != "DMSO"]
selectInput(session$ns(NAMESPACE_STATMODEL$visualization_response_curve_which_drug),
Expand Down Expand Up @@ -534,7 +559,7 @@ statmodelServer = function(id, parent_session, loadpage_input, qc_input,
tryCatch({ rownames(matrix_build()) }, error = function(e) {})
})

render_group_comparison_plot_inputs(output, session, Rownames, get_data, input, loadpage_input, condition_list)
render_group_comparison_plot_inputs(output, session, Rownames, get_data, input, loadpage_input, condition_list,contrast)

# Reset on configuration change
observeEvent(c(input[[NAMESPACE_STATMODEL$comparison_mode]], loadpage_input()$proceed1), {
Expand Down Expand Up @@ -591,7 +616,8 @@ statmodelServer = function(id, parent_session, loadpage_input, qc_input,

# Run analysis
data_comparison = eventReactive(input[[NAMESPACE_STATMODEL$modeling_start]], {
matrix = matrix_build()
req(contrast$matrix)
matrix = contrast$matrix
if (input[[NAMESPACE_STATMODEL$comparison_mode]] ==
CONSTANTS_STATMODEL$comparison_mode_response_curve) {
fitResponseCurves(input, matrix, preprocess_data())
Expand All @@ -601,7 +627,8 @@ statmodelServer = function(id, parent_session, loadpage_input, qc_input,
})

data_comparison_code = eventReactive(input[[NAMESPACE_STATMODEL$modeling_start]], {
comp_mat = matrix_build()
req(contrast$matrix)
comp_mat = contrast$matrix
generate_analysis_code(qc_input(), loadpage_input(), comp_mat, input)
})

Expand All @@ -610,14 +637,46 @@ statmodelServer = function(id, parent_session, loadpage_input, qc_input,
extract_significant_proteins(data_comp, loadpage_input(), input[[NAMESPACE_STATMODEL$modeling_significance_level]])
})

# Handle edits to the contrast matrix from the UI
observeEvent(input$table_cell_edit, {
# Use isolate() to get a snapshot of the matrix. This is crucial to prevent
# a reactive loop where updating the matrix would re-trigger this observer.
current_matrix <- isolate(contrast$matrix)

updated_matrix <- update_matrix_from_edit(current_matrix, input$table_cell_edit)

# Update the reactive value. This will trigger re-rendering of the table.
contrast$matrix <- updated_matrix
})

# Matrix output
output$message = renderText({ check_cond() })
output$table = renderDataTable({ matrix_build() })
output$table = renderDataTable({
# This table now directly depends on contrast$matrix, so it updates on build or edit.
req(contrast$matrix)
mat <- contrast$matrix

# Define editable options, disabling the 'GROUP' column for response curves
editable_options <- list(target = 'cell')
# Perform a case-insensitive check for the 'GROUP' column for robustness.
if (any(toupper(colnames(mat)) == "GROUP")) {
group_col_idx <- which(toupper(colnames(mat)) == "GROUP")
editable_options$disable <- list(columns = group_col_idx)
}

DT::datatable(mat, editable = editable_options, options = list(scrollX = TRUE))
})
Comment on lines +660 to +668
Copy link
Copy Markdown

@coderabbitai coderabbitai Bot Dec 10, 2025

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

⚠️ Potential issue | 🔴 Critical

🧩 Analysis chain

🌐 Web query:

DT::datatable editable disable columns index convention 0-based 1-based

💡 Result:

Use 0-based (JavaScript-style) column indices. The editable:disable columns vector counts from 0, so the first column is 0. Example:
editable = list(target = "cell", disable = list(columns = c(0, 1))) # disables col1 and col2. [1][2]

Sources:
[1] Stack Overflow discussion showing 0-based indices.
[2] DT datatable documentation for the editable argument.

Fix column index conversion for DT's 0-based indexing.

DT::datatable's editable$disable$columns expects 0-based column indices (JavaScript convention), but which() returns 1-based indices. The GROUP column won't be disabled correctly. Subtract 1 from the result: group_col_idx <- which(toupper(colnames(mat)) == "GROUP") - 1.

🤖 Prompt for AI Agents 
In R/module-statmodel-server.R around lines 660 to 668, the code uses which() to
find the GROUP column but passes 1-based R indices to DT::datatable
editable$disable$columns which expects 0-based JS indices; change the assignment
to subtract 1 from the which() result (and coerce to integer/vector if
necessary) so editable_options$disable$columns receives 0-based indices (e.g.,
group_col_idx <- which(toupper(colnames(mat)) == "GROUP") - 1) before setting
editable_options$disable.


output$matrix = renderUI({
ns = session$ns
tagList(
# CSS rule to ensure text in editable cells is always black.
# This overrides conflicting styles that may turn the text white during editing.
tags$head(tags$style(HTML(
"table.dataTable td input { color: black !important; }"
))),
h2("Comparison matrix"),
p(tags$i("This table is interactive. Click values to edit.")),
br(),
textOutput(ns("message")),
br(),
Expand All @@ -644,7 +703,7 @@ statmodelServer = function(id, parent_session, loadpage_input, qc_input,
op = plotOutput(ns("comp_plots"))
} else if (input[[NAMESPACE_STATMODEL$visualization_plot_type]] ==
CONSTANTS_STATMODEL$plot_type_response_curve) {
matrix = matrix_build()
matrix = contrast$matrix
protein_level_data <- merge(preprocess_data()$ProteinLevelData, matrix, by = "GROUP")
dia_prepared <- MSstatsPrepareDoseResponseFit(
data = protein_level_data,
Expand Down
41 changes: 38 additions & 3 deletions tests/testthat/test-utils-statmodel-server.R
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -379,13 +379,48 @@ test_that("get_contrast_panel_ui returns correct UI for each mode", {

test_that("build_response_curve_matrix returns correct columns", {
condition_list = c("Dasatinib_001nM", "Dasatinib_001uM", "DMSO")

contrast <- list(matrix = NULL)
result <- build_response_curve_matrix(condition_list)

# This test requires the MSstatsResponse package to be installed
expect_equal(nrow(result), 3)
expect_equal(ncol(result), 3)
expect_true("GROUP" %in% colnames(result))
expect_true("drug" %in% colnames(result))
expect_true("dose_nM" %in% colnames(result))
})
})

# ============================================================================
# Tests for update_matrix_from_edit
# ============================================================================

test_that("update_matrix_from_edit updates a numeric matrix correctly", {
mat <- matrix(c(1, 2, 3, 4), nrow = 2, ncol = 2)
info <- list(row = 1, col = 2, value = "99")

result <- update_matrix_from_edit(mat, info)

expect_equal(result[1, 2], 99)
expect_true(is.numeric(result))
})

test_that("update_matrix_from_edit updates a data.frame with mixed types", {
df <- data.frame(
label = c("A", "B"),
value = c(10, 20),
stringsAsFactors = FALSE
)

# Update numeric column
info_numeric <- list(row = 1, col = 2, value = "100.5")
result_numeric <- update_matrix_from_edit(df, info_numeric)

expect_equal(result_numeric[1, 2], 100.5)
expect_true(is.numeric(result_numeric$value))

# Update character column
info_char <- list(row = 2, col = 1, value = "Updated")
result_char <- update_matrix_from_edit(result_numeric, info_char)

expect_equal(result_char[2, 1], "Updated")
expect_true(is.character(result_char$label))
})
Loading