From 14d767ae4b1b96f75cd505878ba9cb38424e28d6 Mon Sep 17 00:00:00 2001 From: Rudhik1904 Date: Mon, 8 Dec 2025 18:30:42 -0600 Subject: [PATCH 1/5] making the comparision matrix editable --- R/module-statmodel-server.R | 55 ++++++++++++++++++++++++++++++++++--- 1 file changed, 51 insertions(+), 4 deletions(-) diff --git a/R/module-statmodel-server.R b/R/module-statmodel-server.R index 639d782..a23a74d 100644 --- a/R/module-statmodel-server.R +++ b/R/module-statmodel-server.R @@ -591,7 +591,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()) @@ -601,7 +602,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) }) @@ -610,13 +612,58 @@ 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, { + info <- input$table_cell_edit + # Use isolate() to get the current matrix without creating a reactive dependency + mat <- isolate(contrast$matrix) + + # DT provides 1-based indices for rows and columns in the edit event + i <- info$row + j <- info$col + v <- info$value + + # copy the new value to the type of the target column to maintain data integrity + if (is.data.frame(mat)) { + # For data frames, copy to the column's class + 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 + } + + # Update the reactive value. This will trigger the table to re-render with the new value. + contrast$matrix <- mat + }) + # 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)) + }) 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"), br(), textOutput(ns("message")), @@ -644,7 +691,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, From c29ad0341f5f383a98071b5e80a475b43a727091 Mon Sep 17 00:00:00 2001 From: Rudhik1904 Date: Tue, 9 Dec 2025 21:32:22 -0600 Subject: [PATCH 2/5] Adding Tests --- R/module-statmodel-server.R | 61 ++++++++++++-------- tests/testthat/test-utils-statmodel-server.R | 41 ++++++++++++- 2 files changed, 74 insertions(+), 28 deletions(-) diff --git a/R/module-statmodel-server.R b/R/module-statmodel-server.R index a23a74d..74425bc 100644 --- a/R/module-statmodel-server.R +++ b/R/module-statmodel-server.R @@ -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( @@ -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) { @@ -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), @@ -614,28 +639,14 @@ statmodelServer = function(id, parent_session, loadpage_input, qc_input, # Handle edits to the contrast matrix from the UI observeEvent(input$table_cell_edit, { - info <- input$table_cell_edit - # Use isolate() to get the current matrix without creating a reactive dependency - mat <- isolate(contrast$matrix) + # 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) - # DT provides 1-based indices for rows and columns in the edit event - i <- info$row - j <- info$col - v <- info$value - - # copy the new value to the type of the target column to maintain data integrity - if (is.data.frame(mat)) { - # For data frames, copy to the column's class - 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 - } + updated_matrix <- update_matrix_from_edit(current_matrix, input$table_cell_edit) - # Update the reactive value. This will trigger the table to re-render with the new value. - contrast$matrix <- mat + # Update the reactive value. This will trigger re-rendering of the table. + contrast$matrix <- updated_matrix }) # Matrix output diff --git a/tests/testthat/test-utils-statmodel-server.R b/tests/testthat/test-utils-statmodel-server.R index abc7d81..69c9e47 100644 --- a/tests/testthat/test-utils-statmodel-server.R +++ b/tests/testthat/test-utils-statmodel-server.R @@ -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)) -}) \ No newline at end of file +}) + +# ============================================================================ +# 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)) +}) From c326c445a5c5394599804335bfb141f49d543325 Mon Sep 17 00:00:00 2001 From: Rudhik1904 Date: Tue, 9 Dec 2025 21:44:57 -0600 Subject: [PATCH 3/5] Adding instructions for users to edit the setup matrix --- R/module-statmodel-server.R | 1 + 1 file changed, 1 insertion(+) diff --git a/R/module-statmodel-server.R b/R/module-statmodel-server.R index 74425bc..98e76f7 100644 --- a/R/module-statmodel-server.R +++ b/R/module-statmodel-server.R @@ -676,6 +676,7 @@ statmodelServer = function(id, parent_session, loadpage_input, qc_input, "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(), From 3196d98abab5d1ed668e1cb22ffeb48150c1c38b Mon Sep 17 00:00:00 2001 From: Tony Wu Date: Wed, 10 Dec 2025 18:16:24 -0500 Subject: [PATCH 4/5] bug fix: fix indexing for get_data() --- R/module-qc-server.R | 4 ++-- R/module-statmodel-server.R | 2 +- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/R/module-qc-server.R b/R/module-qc-server.R index 84432ac..58277cd 100644 --- a/R/module-qc-server.R +++ b/R/module-qc-server.R @@ -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) } }) diff --git a/R/module-statmodel-server.R b/R/module-statmodel-server.R index 98e76f7..61f152e 100644 --- a/R/module-statmodel-server.R +++ b/R/module-statmodel-server.R @@ -262,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)) }) output[[NAMESPACE_STATMODEL$visualization_plot_options_conditional_panel]] <- renderUI({ From 29fea4947e9ba6bb7d22884135d95860113de2bc Mon Sep 17 00:00:00 2001 From: Rudhik1904 Date: Wed, 10 Dec 2025 18:32:02 -0600 Subject: [PATCH 5/5] Adding contrast render_group_comparision_plot_inputs() --- R/module-statmodel-server.R | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/R/module-statmodel-server.R b/R/module-statmodel-server.R index 61f152e..40f66cd 100644 --- a/R/module-statmodel-server.R +++ b/R/module-statmodel-server.R @@ -250,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({ @@ -559,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), {