diff --git a/R/constants.R b/R/constants.R index 12c8454..bb61f17 100644 --- a/R/constants.R +++ b/R/constants.R @@ -16,6 +16,7 @@ NAMESPACE_STATMODEL = list( modeling_response_curve_increasing_trend = "modeling_response_curve_increasing_trend", modeling_response_curve_log_xaxis = "modeling_response_curve_log_xaxis", visualization_plot_options_conditional_panel = "plot_options_conditional_panel", + modeling_section_header = "modeling_section_header", visualization_plot_type = "visualization_plot_type", visualization_logp_base = "visualization_logp_base", visualization_which_protein = "visualization_which_protein", diff --git a/R/module-statmodel-server.R b/R/module-statmodel-server.R index 160ccc8..3941354 100644 --- a/R/module-statmodel-server.R +++ b/R/module-statmodel-server.R @@ -62,12 +62,51 @@ statmodelServer = function(id, parent_session, loadpage_input, qc_input, }) render_group_comparison_plot_inputs(output, session, Rownames, get_data, input, loadpage_input, condition_list,contrast) + output[[NAMESPACE_STATMODEL$modeling_section_header]] <- renderUI({ + get_modeling_section_header(input[[NAMESPACE_STATMODEL$comparison_mode]]) + }) + # Filter visualization dropdown based on comparison mode + observeEvent(input[[NAMESPACE_STATMODEL$comparison_mode]], { + req(input[[NAMESPACE_STATMODEL$comparison_mode]]) + mode <- input[[NAMESPACE_STATMODEL$comparison_mode]] + if (mode == CONSTANTS_STATMODEL$comparison_mode_response_curve) { + updateSelectInput(session, NAMESPACE_STATMODEL$visualization_plot_type, + choices = c("Dose Response Curve" = CONSTANTS_STATMODEL$plot_type_response_curve) + ) + } else { + updateSelectInput(session, NAMESPACE_STATMODEL$visualization_plot_type, + choices = c( + "Volcano Plot" = CONSTANTS_STATMODEL$plot_type_volcano_plot, + "Heatmap" = CONSTANTS_STATMODEL$plot_type_heatmap, + "Comparison Plot" = CONSTANTS_STATMODEL$plot_type_comparison_plot + ) + ) + } + }, ignoreInit = TRUE) + # Reset on configuration change observeEvent(c(input[[NAMESPACE_STATMODEL$comparison_mode]], loadpage_input()$proceed1), { contrast$matrix = NULL comp_list$dList = NULL significant$result = NULL + + # Auto-build response curve metadata when dose response mode is selected + if (isTRUE(input[[NAMESPACE_STATMODEL$comparison_mode]] == + CONSTANTS_STATMODEL$comparison_mode_response_curve)) { + tryCatch({ + rc_matrix <- build_response_curve_matrix(condition_list()) + if (is.null(rc_matrix) || nrow(rc_matrix) == 0) { + stop("Unable to auto-build group metadata from the current conditions.") + } + contrast$matrix <- rc_matrix + enable(NAMESPACE_STATMODEL$modeling_start) + }, error = function(e) { + contrast$matrix <- NULL + disable(NAMESPACE_STATMODEL$modeling_start) + showNotification(conditionMessage(e), type = "error", duration = 6) + }) + } }) # Validate contrast inputs @@ -176,13 +215,17 @@ statmodelServer = function(id, parent_session, loadpage_input, qc_input, output$matrix = renderUI({ ns = session$ns + mode = input[[NAMESPACE_STATMODEL$comparison_mode]] + matrix_title = if (isTRUE(mode == CONSTANTS_STATMODEL$comparison_mode_response_curve)) { + "Group Metadata" + } else { + "Comparison matrix" + } 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"), + h2(matrix_title), p(tags$i("This table is interactive. Click values to edit.")), if (!is.null(input[[NAMESPACE_STATMODEL$comparison_mode]]) && input[[NAMESPACE_STATMODEL$comparison_mode]] %in% c( diff --git a/R/statmodel-server-options-modeling.R b/R/statmodel-server-options-modeling.R index 696e2ae..c7f8b30 100644 --- a/R/statmodel-server-options-modeling.R +++ b/R/statmodel-server-options-modeling.R @@ -10,6 +10,25 @@ get_tmt_moderation_radio_button = function(loadpage_input, ns) { } } +#' Get modeling section header based on comparison mode +#' +#' @param mode Character. The current comparison mode. +#' @return A tagList with the appropriate heading and description. +#' @noRd +get_modeling_section_header <- function(mode) { + if (isTRUE(mode == CONSTANTS_STATMODEL$comparison_mode_response_curve)) { + tagList( + h4("2. Dose response analysis"), + p("Please configure the mapping between experimental groups and treatment concentrations.") + ) + } else { + tagList( + h4("2. Group comparison"), + p("Please add a comparison matrix before modeling.") + ) + } +} + #' Get response curve fitting options conditioned on if contrast mode is response curve #' @noRd get_response_curve_fitting_options = function(mode, ns) { diff --git a/R/statmodel-ui-comparisons.R b/R/statmodel-ui-comparisons.R index 5cc1dd6..e38ab2a 100644 --- a/R/statmodel-ui-comparisons.R +++ b/R/statmodel-ui-comparisons.R @@ -85,8 +85,6 @@ build_custom_nonpairwise_panel <- function(ns) { #' @noRd build_response_curve_panel <- function(ns) { tagList( - h5("Set up response curve configuration:"), - actionButton(ns(NAMESPACE_STATMODEL$comparisons_submit), "Setup Metadata"), actionButton(ns(NAMESPACE_STATMODEL$comparisons_clear), "Reset") ) } \ No newline at end of file diff --git a/R/statmodel-ui-options-modeling.R b/R/statmodel-ui-options-modeling.R index 7d69163..6adce75 100644 --- a/R/statmodel-ui-options-modeling.R +++ b/R/statmodel-ui-options-modeling.R @@ -7,8 +7,7 @@ #' @noRd create_modeling_section <- function(ns) { tagList( - h4("2. Group comparison"), - p("Please add a comparison matrix before modeling."), + uiOutput(ns(NAMESPACE_STATMODEL$modeling_section_header)), disabled(actionButton(ns(NAMESPACE_STATMODEL$modeling_start), "Start")), tags$hr(), uiOutput(ns(NAMESPACE_STATMODEL$modeling_response_curve_fitting_options)), diff --git a/tests/testthat/test-module-statmodel-ui.R b/tests/testthat/test-module-statmodel-ui.R index 45ad295..8682e3d 100644 --- a/tests/testthat/test-module-statmodel-ui.R +++ b/tests/testthat/test-module-statmodel-ui.R @@ -11,16 +11,14 @@ test_that("UI components appear in correct order", { ui <- create_test_ui() ui_html <- htmltools::renderTags(ui)$html - # Extract positions of key elements pos_contrast <- regexpr("1\\. Define comparisons", ui_html) - pos_group_comp <- regexpr("2\\. Group comparison", ui_html) + pos_modeling <- regexpr(NAMESPACE_STATMODEL$modeling_section_header, ui_html) pos_viz <- regexpr("3\\. Visualization", ui_html) - # Verify order - expect_true(pos_contrast < pos_group_comp, - info = "Contrast matrix section should appear before group comparison") - expect_true(pos_group_comp < pos_viz, - info = "Group comparison should appear before visualization") + expect_true(pos_contrast < pos_modeling, + info = "Contrast matrix section should appear before modeling section") + expect_true(pos_modeling < pos_viz, + info = "Modeling section should appear before visualization") }) test_that("Side panel contains all three main sections", { @@ -28,7 +26,8 @@ test_that("Side panel contains all three main sections", { ui_html <- htmltools::renderTags(ui)$html expect_true(grepl("1\\. Define comparisons", ui_html)) - expect_true(grepl("2\\. Group comparison", ui_html)) + expect_true(grepl(NAMESPACE_STATMODEL$modeling_section_header, ui_html), + info = "Modeling section header placeholder should be present") expect_true(grepl("3\\. Visualization", ui_html)) }) @@ -209,8 +208,8 @@ test_that("Informative messages are present", { ui <- create_test_ui() ui_html <- htmltools::renderTags(ui)$html - expect_true(grepl("Please add a comparison matrix before modeling", ui_html), - info = "Matrix requirement message should be present") + expect_true(grepl(NAMESPACE_STATMODEL$modeling_section_header, ui_html), + info = "Modeling section header output should be present") }) # ============================================================================ diff --git a/tests/testthat/test-statmodel-ui-options-contrasts.R b/tests/testthat/test-statmodel-ui-options-contrasts.R index 4f870fb..ca280a3 100644 --- a/tests/testthat/test-statmodel-ui-options-contrasts.R +++ b/tests/testthat/test-statmodel-ui-options-contrasts.R @@ -58,9 +58,22 @@ test_that("build_response_curve_panel creates correct UI structure", { ns <- function(id) paste0("statmodel-", id) ui <- build_response_curve_panel(ns) html <- as.character(ui) - expect_true(grepl("
Set up response curve configuration:
", html, fixed = TRUE)) - expect_true(grepl(NAMESPACE_STATMODEL$comparisons_submit, html, fixed = TRUE)) + # Setup Metadata button removed. Metadata auto-builds on radio selection + expect_false(grepl(NAMESPACE_STATMODEL$comparisons_submit, html, fixed = TRUE), + info = "Submit contrast matrix button should not be present") expect_true(grepl(NAMESPACE_STATMODEL$comparisons_clear, html, fixed = TRUE)) expect_s3_class(ui, "shiny.tag.list") - expect_length(ui, 3) + expect_length(ui, 1) +}) + +# ============================================================================ +# DYNAMIC HEADING AND DROPDOWN TESTS +# ============================================================================ + +test_that("modeling section header placeholder exists in UI", { + ui <- MSstatsShiny::statmodelUI("statmodel") + ui_html <- htmltools::renderTags(ui)$html + + expect_true(grepl(NAMESPACE_STATMODEL$modeling_section_header, ui_html), + info = "Modeling section header uiOutput placeholder should be present") }) \ No newline at end of file diff --git a/tests/testthat/test-utils-statmodel-server.R b/tests/testthat/test-utils-statmodel-server.R index 54c66b0..9b8728c 100644 --- a/tests/testthat/test-utils-statmodel-server.R +++ b/tests/testthat/test-utils-statmodel-server.R @@ -595,4 +595,44 @@ test_that("generate_analysis_code produces groupComparisonTMT for TMT", { expect_true(grepl("groupComparisonTMT", result)) expect_false(grepl("doseResponseFit", result)) +}) + +# ============================================================================ +# MODELING SECTION HEADER TESTS +# ============================================================================ + +test_that("get_modeling_section_header returns dose response heading for response curve mode", { + result <- MSstatsShiny:::get_modeling_section_header( + CONSTANTS_STATMODEL$comparison_mode_response_curve + ) + html <- as.character(result) + expect_true(grepl("Dose response analysis", html), + info = "Should show dose response heading") + expect_true(grepl("configure the mapping", html), + info = "Should show dose response description") + expect_false(grepl("Group comparison", html), + info = "Should not show group comparison heading") +}) + +test_that("get_modeling_section_header returns group comparison heading for other modes", { + for (mode in c( + CONSTANTS_STATMODEL$comparison_mode_all_pairwise, + CONSTANTS_STATMODEL$comparison_mode_all_vs_one, + CONSTANTS_STATMODEL$comparison_mode_custom_pairwise, + CONSTANTS_STATMODEL$comparison_mode_custom_nonpairwise + )) { + result <- MSstatsShiny:::get_modeling_section_header(mode) + html <- as.character(result) + expect_true(grepl("Group comparison", html), + info = paste("Should show group comparison for mode:", mode)) + expect_false(grepl("Dose response", html), + info = paste("Should not show dose response for mode:", mode)) + } +}) + +test_that("get_modeling_section_header handles NULL mode", { + result <- MSstatsShiny:::get_modeling_section_header(NULL) + html <- as.character(result) + expect_true(grepl("Group comparison", html), + info = "NULL mode should default to group comparison") }) \ No newline at end of file