diff --git a/DESCRIPTION b/DESCRIPTION index 93220e9b3..3ff5bdc60 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,6 +1,6 @@ Package: aNCA Title: (Pre-)Clinical NCA in a Dynamic Shiny App -Version: 0.1.0.9175 +Version: 0.1.0.9176 Authors@R: c( person("Ercan", "Suekuer", email = "ercan.suekuer@roche.com", role = "aut", comment = c(ORCID = "0009-0001-1626-1526")), diff --git a/NEWS.md b/NEWS.md index 9ac7adfd1..e1c0e4f0a 100644 --- a/NEWS.md +++ b/NEWS.md @@ -80,6 +80,7 @@ * Dose-aware AUCint parameters now share the same PPTESTCD as their non-dose-aware counterparts in CDISC exports, with `PPANMETH` indicating the analytical method. Internal PPTESTCDs renamed from misleading `D` suffix (e.g. `AUCINTD`) to lowercase `da` suffix (e.g. `AUCINTda`). Fixed wrong PPTEST label for `AUCINTD` which said "Normalized by Dose" (#1242) * Optional settings (`slope_rules`, `int_parameters`, `ratio_table`) are now normalized to `NULL` when empty, instead of persisting as 0-row data frames throughout the app and settings pipeline (#1262) * Interval-specific parameters (`aucint.*`, `cav.int.*`) excluded from the Parameter Selection matrix — they require finite sub-intervals and must be configured via Partial Interval Calculations (#1309) +* Slope rules table (Slope Selector) now properly clears when all rules are removed, and row removal no longer corrupts data or leaks extraneous columns (#1302). The root cause was multi-layered: (1) `validate(need(FALSE))` retained previous output instead of clearing the reactable, (2) `reactable.extras` widgets sent Shiny input events during initialization after every re-render, overwriting valid data with widget defaults, (3) `rbind`/`bind_rows` column mismatches introduced stray columns from plot-click rules, and (4) a namespaced `updateReactable` had been a silent no-op since #1262 due to a missing module namespace suffix. ### Ratio Calculations * Fixed `Aggregate Subject = yes/if-needed` not aggregating reference values, and ratio columns not appearing in results (#1273) diff --git a/inst/shiny/functions/utils-slope_selector.R b/inst/shiny/functions/utils-slope_selector.R index 3723d4377..2fef352ba 100644 --- a/inst/shiny/functions/utils-slope_selector.R +++ b/inst/shiny/functions/utils-slope_selector.R @@ -161,10 +161,12 @@ check_slope_rule_overlap <- function(existing, new, .keep = FALSE) { rows_with_same_cols <- is_matching_cols(c(slope_groups, "TYPE", "RANGE"), existing, new) if (sum(rows_with_same_cols) > 0) { existing <- existing[!rows_with_same_cols, ] - return(if (nrow(existing) == 0) NULL else existing) + return(if (nrow(existing) == 0) existing[0, ] else existing) } # Otherwise, just add the new exclusion - existing <- bind_rows(existing, new) + # Drop columns from existing that are not in new to prevent column mismatch (#1302) + common_cols <- intersect(names(existing), names(new)) + existing <- bind_rows(existing[, common_cols, drop = FALSE], new) } if (new$TYPE == "Selection") { @@ -174,9 +176,10 @@ check_slope_rule_overlap <- function(existing, new, .keep = FALSE) { existing <- existing[!rows_with_same_groups, ] } # Otherwise, just add the new selection - existing <- bind_rows(existing, new) + common_cols <- intersect(names(existing), names(new)) + existing <- bind_rows(existing[, common_cols, drop = FALSE], new) } - if (nrow(existing) == 0) NULL else existing + if (nrow(existing) == 0) existing[0, ] else existing } #' Update plots with PKNCA data (for affected intervals) diff --git a/inst/shiny/modules/tab_nca.R b/inst/shiny/modules/tab_nca.R index bb0f8ae60..e640cf8cb 100644 --- a/inst/shiny/modules/tab_nca.R +++ b/inst/shiny/modules/tab_nca.R @@ -119,6 +119,15 @@ tab_nca_server <- function(id, pknca_data, extra_group_vars, settings_override, reactive(slope_rules()), columns = NULL) + # Ensure Results table clears when slope rules become NULL/empty (#1302) + observeEvent(slope_rules(), { + sr <- slope_rules() + if (is.null(sr) || (is.data.frame(sr) && nrow(sr) == 0)) { + reactable::updateReactable(ns("manual_slopes-table"), + data = data.frame(Status = "No rules defined")) + } + }, ignoreNULL = FALSE) + # Auto-replay: trigger NCA run once settings are applied and data is ready. # Debounces processed_pknca_data to wait for the full settings cascade # (analyte → pcspec → profile → parameters → data object) to settle. diff --git a/inst/shiny/modules/tab_nca/setup/manual_slopes_table.R b/inst/shiny/modules/tab_nca/setup/manual_slopes_table.R index 163215844..0eeb1a240 100644 --- a/inst/shiny/modules/tab_nca/setup/manual_slopes_table.R +++ b/inst/shiny/modules/tab_nca/setup/manual_slopes_table.R @@ -82,6 +82,23 @@ manual_slopes_table_server <- function( # create a reactive to update the reactable UI when the table changes refresh_reactable <- reactiveVal(0) + # Flag to suppress edit events during widget (re-)initialization after table re-render. + # When TRUE, edit observer ignores incoming events to prevent reactable.extras widgets + # from writing default values (e.g. first dropdown choice, empty text) into the data. + # Uses a generation counter so rapid successive operations don't prematurely unblock. + suppress_edit_events <- reactiveVal(0) # 0 = not suppressing, >0 = suppressing + + # Set suppression on each re-render; clear after delay only if no newer re-render occurred. + observeEvent(refresh_reactable(), { + gen <- suppress_edit_events(0) + 1 # increment generation (0→1, 1→2, etc.) + suppress_edit_events(gen) + shinyjs::delay(500, { + if (identical(suppress_edit_events(), gen)) { + suppress_edit_events(0) + } + }) + }, ignoreInit = TRUE) + # Add a new row to the table when the user clicks the add button observeEvent(input$add_rule, { log_trace("{id}: adding manual slopes row") @@ -110,6 +127,11 @@ manual_slopes_table_server <- function( } else { new_row[0, ] # empty DF with matching columns } + # Keep only columns present in new_row to prevent rbind column mismatch + # when old rules (e.g. from plot clicks) have extra columns like ATPTREF (#1302) + common_cols <- intersect(names(old_rows), names(new_row)) + old_rows <- old_rows[, common_cols, drop = FALSE] + new_row <- new_row[, common_cols, drop = FALSE] updated_data <- as.data.frame( rbind(old_rows, new_row), stringsAsFactors = FALSE @@ -124,9 +146,11 @@ manual_slopes_table_server <- function( log_trace("{id}: removing manual slopes row") req(manual_slopes()) selected <- getReactableState("manual_slopes", "selected") - req(selected) - edited_slopes <- manual_slopes()[-selected, ] - if (nrow(edited_slopes) == 0) edited_slopes <- NULL + if (is.null(selected) || length(selected) == 0) { + return() + } + edited_slopes <- manual_slopes()[-selected, , drop = FALSE] + if (nrow(edited_slopes) == 0) edited_slopes <- edited_slopes[0, ] manual_slopes(edited_slopes) reset_reactable_memory() refresh_reactable(refresh_reactable() + 1) @@ -134,11 +158,14 @@ manual_slopes_table_server <- function( # Render the manual slopes table (reactable) output$manual_slopes <- renderReactable({ - req(manual_slopes()) + data <- manual_slopes() + if (is.null(data) || nrow(data) == 0) { + return(NULL) + } log_trace("{id}: rendering slope edit data table") - isolate({ - data <- manual_slopes() - }) + # Drop stray columns (e.g. ATPTREF from plot clicks) not in canonical column set (#1302) + canonical_cols <- c(colnames(slopes_pknca_groups()), "TYPE", "RANGE", "REASON") + data <- data[, intersect(names(data), canonical_cols), drop = FALSE] # Define columns: group columns (dynamic), then TYPE/RANGE/REASON (fixed) fixed_columns <- list( TYPE = colDef( @@ -195,6 +222,7 @@ manual_slopes_table_server <- function( req(manual_slopes()) purrr::walk(colnames(manual_slopes()), function(colname) { observeEvent(input[[paste0("edit_", colname)]], { + req(suppress_edit_events() == 0) edit <- input[[paste0("edit_", colname)]] edited_slopes <- manual_slopes() edited_slopes[edit$row, edit$column] <- edit$value diff --git a/inst/shiny/modules/tab_nca/setup/slope_selector.R b/inst/shiny/modules/tab_nca/setup/slope_selector.R index 7f3cfe0f1..79b122bd8 100644 --- a/inst/shiny/modules/tab_nca/setup/slope_selector.R +++ b/inst/shiny/modules/tab_nca/setup/slope_selector.R @@ -266,18 +266,14 @@ slope_selector_server <- function( # nolint refresh_reactable(refresh_reactable() + 1) }) - #' Separate event handling updating displayed reactable upon every change (adding and removing - #' rows, plots selection, edits). This needs to be separate call, since simply re-rendering - #' the table would mean losing focus on text inputs when entering values. + #' Observe manual_slopes changes for inline edits. + #' NOTE: We intentionally do NOT call updateReactable here because: + #' 1. renderReactable + bindEvent(refresh_reactable()) handles all full re-renders + #' 2. reactable.extras widgets (dropdown_extra, text_extra) handle inline edits directly + #' 3. updateReactable from the parent module cannot reference the inner module's + #' outputId without hardcoding internal namespace structure (#1302). observeEvent(manual_slopes(), { - req(manual_slopes()) - - # Update reactable with rules - reactable::updateReactable( - outputId = "manual_slopes", - data = manual_slopes() - ) - + # manual_slopes changes are handled by refresh_reactable-triggered re-renders }) #' returns half life adjustments rules to update processed_pknca_data in nca_setup.R manual_slopes diff --git a/inst/shiny/tests/testthat/test-utils-slope-selector.R b/inst/shiny/tests/testthat/test-utils-slope-selector.R index 5ce33b5c4..961a2aad1 100644 --- a/inst/shiny/tests/testthat/test-utils-slope-selector.R +++ b/inst/shiny/tests/testthat/test-utils-slope-selector.R @@ -93,7 +93,38 @@ describe("check_slope_rule_overlap", { RANGE = "3:6" ) - expect_null(check_slope_rule_overlap(EXISTING_FIXTURE, NEW)) + expect_equal(nrow(check_slope_rule_overlap(EXISTING_FIXTURE, NEW)), 0) + }) + + it("drops extra columns from existing that are not in new (column normalization)", { + EXISTING_WITH_EXTRA <- cbind( + EXISTING_FIXTURE, + data.frame(EXTRA_COL = "should_be_dropped", stringsAsFactors = FALSE) + ) + NEW_SELECTION <- data.frame( + TYPE = "Selection", USUBJID = 1, ATPTREF = 1, + PARAM = "A", PCSPEC = 1, RANGE = "1:3", + stringsAsFactors = FALSE + ) + result <- check_slope_rule_overlap(EXISTING_WITH_EXTRA, NEW_SELECTION) + expect_false("EXTRA_COL" %in% names(result)) + expect_equal(nrow(result), 2) + }) + + it("keeps only common columns when new has missing columns (e.g. no REASON)", { + EXISTING_WITH_REASON <- data.frame( + TYPE = "Exclusion", USUBJID = 1, ATPTREF = 1, + PARAM = "A", PCSPEC = 1, RANGE = "3:6", + REASON = "outlier", stringsAsFactors = FALSE + ) + NEW_NO_REASON <- data.frame( + TYPE = "Selection", USUBJID = 1, ATPTREF = 1, + PARAM = "B", PCSPEC = 1, RANGE = "1:3", + stringsAsFactors = FALSE + ) + result <- check_slope_rule_overlap(EXISTING_WITH_REASON, NEW_NO_REASON) + expect_false("REASON" %in% names(result)) + expect_equal(nrow(result), 2) }) it("should warn if more than one range for single subject, profile and rule type is detected", { diff --git a/tests/testthat/test-utils-slope_selector.R b/tests/testthat/test-utils-slope_selector.R index d7bf0a5ed..a77c4fb08 100644 --- a/tests/testthat/test-utils-slope_selector.R +++ b/tests/testthat/test-utils-slope_selector.R @@ -39,7 +39,7 @@ describe("check_slope_rule_overlap", { PARAM = "A", PCSPEC = 1, RANGE = "3:6", REASON = "outlier" ) result <- check_slope_rule_overlap(existing, new_rule) - expect_null(result) + expect_equal(nrow(result), 0) }) it("returns remaining rows when cancelling one of multiple exclusions", { @@ -54,6 +54,38 @@ describe("check_slope_rule_overlap", { expect_equal(nrow(result), 1) expect_equal(result$RANGE, "7:9") }) + + it("drops extra columns from existing that are not in new (column normalization)", { + existing <- data.frame( + TYPE = "Exclusion", USUBJID = 1, ATPTREF = 1, + PARAM = "A", PCSPEC = 1, RANGE = "3:6", + EXTRA_COL = "should_be_dropped", stringsAsFactors = FALSE + ) + new_rule_no_reason <- data.frame( + TYPE = "Selection", USUBJID = 1, ATPTREF = 1, + PARAM = "A", PCSPEC = 1, RANGE = "1:3", + stringsAsFactors = FALSE + ) + result <- check_slope_rule_overlap(existing, new_rule_no_reason) + expect_false("EXTRA_COL" %in% names(result)) + expect_equal(nrow(result), 2) + }) + + it("keeps only common columns when new has missing columns (e.g. no REASON)", { + existing <- data.frame( + TYPE = "Exclusion", USUBJID = 1, ATPTREF = 1, + PARAM = "A", PCSPEC = 1, RANGE = "3:6", + REASON = "outlier", stringsAsFactors = FALSE + ) + new_no_reason <- data.frame( + TYPE = "Selection", USUBJID = 1, ATPTREF = 1, + PARAM = "B", PCSPEC = 1, RANGE = "1:3", + stringsAsFactors = FALSE + ) + result <- check_slope_rule_overlap(existing, new_no_reason) + expect_false("REASON" %in% names(result)) + expect_equal(nrow(result), 2) + }) }) describe("update_pknca_with_rules", {