fix: slope rules table clearing and data corruption on row removal (#1302)

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")),

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)

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)

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.

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,21 +146,26 @@ 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)
     })
 
     # 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

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

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", {

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", {