feat: filter slope selector plots to show only flagged profiles

R/get_halflife_plots.R

@@ -225,7 +225,8 @@ get_halflife_plots <- function(pknca_data, add_annotations = TRUE,
   wide_output$result <- wide_output$result %>%
     filter(
       PPTESTCD %in% c("lambda.z.time.first", "lambda.z.time.last",
-                      "lambda.z", "adj.r.squared", "span.ratio", "tlast")
+                      "lambda.z", "adj.r.squared", "r.squared",
+                      "span.ratio", "tlast")
     ) %>%
     select(-any_of(c("PPORRESU", "PPSTRESU", "PPSTRES"))) %>%
     mutate(exclude = paste0(na.omit(unique(exclude)), collapse = ". "))
@@ -243,7 +244,8 @@ get_halflife_plots <- function(pknca_data, add_annotations = TRUE,
         mutate(
           start = numeric(0), end = numeric(0),
           lambda.z = numeric(0), adj.r.squared = numeric(0),
-          span.ratio = numeric(0), lambda.z.time.first = numeric(0),
+          r.squared = numeric(0), span.ratio = numeric(0),
+          lambda.z.time.first = numeric(0),
           lambda.z.time.last = numeric(0), tlast = numeric(0),
           exclude = character(0)
         )

inst/shiny/functions/utils-slope_selector.R

@@ -50,7 +50,8 @@ detect_pknca_data_changes <- function(old, new, reason_col = "REASON") {
 #' @param old_pknca_data Previous PKNCA data object
 #' @param plot_outputs Current plot outputs (named list)
 #' @return Updated plot_outputs (named list)
-handle_hl_adj_change <- function(new_pknca_data, old_pknca_data, plot_outputs) {
+handle_hl_adj_change <- function(new_pknca_data, old_pknca_data,
+                                 plot_outputs, profile_data = NULL) {
   excl_hl_col <- new_pknca_data$conc$columns$exclude_half.life
   incl_hl_col <- new_pknca_data$conc$columns$include_half.life
   new_concdata <- new_pknca_data$conc$data
@@ -69,9 +70,11 @@ handle_hl_adj_change <- function(new_pknca_data, old_pknca_data, plot_outputs) {
       filter(!!sym(time_col) >= start, !!sym(time_col) <= end) %>%
       select(-any_of(time_col)) %>%
       distinct()
-    plot_outputs <- update_plots_with_pknca(new_pknca_data, plot_outputs, affected_groups)
+    return(update_plots_with_pknca(
+      new_pknca_data, plot_outputs, profile_data, affected_groups
+    ))
   }
-  plot_outputs
+  list(plots = plot_outputs, data = profile_data)
 }
 
 #' Handle interval changes
@@ -81,7 +84,8 @@ handle_hl_adj_change <- function(new_pknca_data, old_pknca_data, plot_outputs) {
 #' @param old_pknca_data Previous PKNCA data object
 #' @param plot_outputs Current plot outputs (named list)
 #' @return Updated plot_outputs (named list)
-handle_interval_change <- function(new_pknca_data, old_pknca_data, plot_outputs) {
+handle_interval_change <- function(new_pknca_data, old_pknca_data,
+                                   plot_outputs, profile_data = NULL) {
   # Join on identity columns only (not parameter flags) so that
   # parameter selection changes are treated as updates, not add+remove.
   id_cols <- intersect(
@@ -104,11 +108,11 @@ handle_interval_change <- function(new_pknca_data, old_pknca_data, plot_outputs)
       merge(unique(PKNCA::getGroups(new_pknca_data$conc)), all.x = TRUE) %>%
       select(any_of(c(group_vars(new_pknca_data), "start", "end"))) %>%
       distinct()
-    plot_outputs <- update_plots_with_pknca(
-      new_pknca_data,
-      plot_outputs,
-      affected_groups
+    result <- update_plots_with_pknca(
+      new_pknca_data, plot_outputs, profile_data, affected_groups
     )
+    plot_outputs <- result$plots
+    profile_data <- result$data
   }
   if (nrow(rm_intervals) > 0) {
     rm_plot_names <- rm_intervals %>%
@@ -126,8 +130,9 @@ handle_interval_change <- function(new_pknca_data, old_pknca_data, plot_outputs)
       )) %>%
       pull(id)
     plot_outputs <- plot_outputs[!names(plot_outputs) %in% rm_plot_names]
+    profile_data <- profile_data[!names(profile_data) %in% rm_plot_names]
   }
-  plot_outputs
+  list(plots = plot_outputs, data = profile_data)
 }
 
 #' Check overlap between existing and new slope rulesets
@@ -185,24 +190,30 @@ check_slope_rule_overlap <- function(existing, new, .keep = FALSE) {
 #' @param plot_outputs Named list of current plot outputs
 #' @param intervals_to_update Data frame of intervals to update (default: all in pknca_data)
 #' @return Updated plot_outputs (named list)
-update_plots_with_pknca <- function(pknca_data, plot_outputs, intervals_to_update = NULL) {
+update_plots_with_pknca <- function(pknca_data, plot_outputs,
+                                    profile_data = NULL,
+                                    intervals_to_update = NULL) {
   if (is.null(intervals_to_update)) {
     intervals_to_update <- pknca_data$intervals %>%
       select(any_of(c(group_vars(pknca_data), "start", "end"))) %>%
       distinct()
   }
-  if (nrow(intervals_to_update) == 0) return(plot_outputs)
+  if (nrow(intervals_to_update) == 0) {
+    return(list(plots = plot_outputs, data = profile_data))
+  }
   # Get the intervals of the plots affected by the current rules
   pknca_data$intervals <- inner_join(
     intervals_to_update,
     pknca_data$intervals,
     by = intersect(names(intervals_to_update), names(pknca_data$intervals))
   )
-  updated_plots <- suppressWarnings(
-    get_halflife_plots(pknca_data, title_vars = "ATPTREF")[["plots"]]
+  hl_result <- suppressWarnings(
+    get_halflife_plots(pknca_data, title_vars = "ATPTREF")
   )
-  plot_outputs[names(updated_plots)] <- updated_plots
-  plot_outputs
+  plot_outputs[names(hl_result[["plots"]])] <- hl_result[["plots"]]
+  if (is.null(profile_data)) profile_data <- list()
+  profile_data[names(hl_result[["data"]])] <- hl_result[["data"]]
+  list(plots = plot_outputs, data = profile_data)
 }
 
 #' Parse Plot Names to Data Frame
@@ -245,3 +256,92 @@ arrange_plots_by_groups <- function(named_list, group_cols) {
     arrange(across(all_of(group_cols)))
   named_list[arranged_df$PLOTID]
 }
+
+#' Identify profile IDs whose half-life results violate flag rules
+#'
+#' Evaluates each profile's NCA results against the checked flag rules
+#' and returns the IDs of profiles that are flagged (i.e. at least one
+#' rule is violated) or where lambda.z is NA (failed fit).
+#'
+#' @param profile_data Named list of per-profile data frames from
+#'   `get_halflife_plots()`. Each data frame contains columns like
+#'   `adj.r.squared`, `r.squared`, `span.ratio`, `lambda.z`.
+#' @param flags Named list of flag rules from NCA settings. Each element
+#'   has `is.checked` (logical) and `threshold` (numeric).
+#' @return Character vector of flagged profile IDs (names from profile_data).
+.get_flagged_profile_ids <- function(profile_data, flags) {
+  # Map flag names to the corresponding column in profile data
+  flag_col_map <- c(
+    R2ADJ = "adj.r.squared",
+    R2 = "r.squared",
+    LAMZSPN = "span.ratio"
+  )
+
+  # Only evaluate checked flags that have a matching column
+  active_flags <- purrr::keep(flags, function(f) isTRUE(f$is.checked))
+  active_flags <- active_flags[names(active_flags) %in% names(flag_col_map)]
+
+  if (length(active_flags) == 0) return(names(profile_data))
+
+  vapply(names(profile_data), function(pid) {
+    df <- profile_data[[pid]]
+    # Always show profiles where lambda.z failed
+    if (all(is.na(df$lambda.z))) return(TRUE)
+
+    # Check each active flag: value below threshold means flagged
+    any(vapply(names(active_flags), function(flag_name) {
+      col <- flag_col_map[[flag_name]]
+      if (!col %in% names(df)) return(FALSE)
+      val <- df[[col]][1]
+      if (is.na(val)) return(TRUE)
+      val < active_flags[[flag_name]]$threshold
+    }, logical(1)))
+  }, logical(1)) |>
+    Filter(isTRUE, x = _) |>
+    names()
+}
+
+#' Identify profile IDs whose half-life results violate flag rules
+#'
+#' Evaluates each profile's NCA results against the checked flag rules
+#' and returns the IDs of profiles that are flagged (i.e. at least one
+#' rule is violated) or where lambda.z is NA (failed fit).
+#'
+#' @param profile_data Named list of per-profile data frames from
+#'   `get_halflife_plots()`. Each data frame contains columns like
+#'   `adj.r.squared`, `r.squared`, `span.ratio`, `lambda.z`.
+#' @param flags Named list of flag rules from NCA settings. Each element
+#'   has `is.checked` (logical) and `threshold` (numeric).
+#' @return Character vector of flagged profile IDs (names from profile_data).
+.get_flagged_profile_ids <- function(profile_data, flags) {
+  # Map flag names to the corresponding column in profile data
+  flag_col_map <- c(
+    R2ADJ = "adj.r.squared",
+    R2 = "r.squared",
+    LAMZSPN = "span.ratio"
+  )
+
+  # Only evaluate checked flags that have a matching column
+  active_flags <- purrr::keep(flags, function(f) isTRUE(f$is.checked))
+  active_flags <- active_flags[names(active_flags) %in% names(flag_col_map)]
+
+  if (length(active_flags) == 0) return(names(profile_data))
+
+  vapply(names(profile_data), function(pid) {
+    df <- profile_data[[pid]]
+    # Always show profiles where lambda.z failed
+    if (all(is.na(df$lambda.z))) return(TRUE)
+
+    # Check each active flag: value below threshold means flagged
+    any(vapply(names(active_flags), function(flag_name) {
+      col <- flag_col_map[[flag_name]]
+      if (!col %in% names(df)) return(FALSE)
+      val <- df[[col]][1]
+      if (is.na(val)) return(TRUE)
+      val < active_flags[[flag_name]]$threshold
+    }, logical(1)))
+  }, logical(1)) |>
+    Filter(isTRUE, x = _) |>
+    names()
+}
+

inst/shiny/modules/tab_nca/nca_setup.R

@@ -198,10 +198,12 @@ nca_setup_server <- function(id, data, adnca_data, extra_group_vars, settings_ov
 
     # Collect all half life manual adjustments done in the `Slope Selector` section
     # and controls the half life plots that are displayed
+    flag_rules <- reactive(settings()$flags)
     slope_rules <- slope_selector_server(
       "slope_selector",
       processed_pknca_data,
-      imported_slopes
+      imported_slopes,
+      flag_rules
     )
 
     # Open comment modal before downloading settings

inst/shiny/modules/tab_nca/setup/slope_selector.R

@@ -17,6 +17,8 @@
 #' @param id Character. Shiny module id.
 #' @param processed_pknca_data Reactive. PKNCAdata object for plotting and table context.
 #' @param manual_slopes_override Reactive. Optional custom settings override for the slopes table.
+#' @param flag_rules Reactive. Named list of flag rules from NCA settings
+#'   (e.g. R2ADJ, R2, LAMZSPN), each with `is.checked` and `threshold`.
 #' @return manual_slopes (data.frame of user slope inclusions/exclusions)
 #'
 #' @details
@@ -105,6 +107,14 @@ slope_selector_ui <- function(id) {
           choices = NULL,
           multiple = TRUE
         ),
+      ),
+      div(
+        class = "plot-widget-group",
+        checkboxInput(
+          ns("filter_flagged"),
+          label = "Show only flagged profiles",
+          value = FALSE
+        )
       )
     ),
     fluidRow(
@@ -126,15 +136,33 @@ slope_selector_ui <- function(id) {
 }
 
 slope_selector_server <- function( # nolint
-  id, processed_pknca_data, manual_slopes_override
+  id, processed_pknca_data, manual_slopes_override, flag_rules = reactive(NULL)
 ) {
   moduleServer(id, function(input, output, session) {
     log_trace("{id}: Attaching server")
 
     ns <- session$ns
 
+    # Disable the flag filter checkbox when no half-life flag rules are checked
+    observe({
+      flags <- flag_rules()
+      hl_flags <- c("R2ADJ", "R2", "LAMZSPN")
+      has_active <- any(vapply(
+        flags[intersect(names(flags), hl_flags)],
+        function(f) isTRUE(f$is.checked),
+        logical(1)
+      ))
+      if (has_active) {
+        shinyjs::enable("filter_flagged")
+      } else {
+        updateCheckboxInput(session, "filter_flagged", value = FALSE)
+        shinyjs::disable("filter_flagged")
+      }
+    })
+
     pknca_data <- reactiveVal(NULL)
     plot_outputs <- reactiveVal(NULL)
+    plot_profile_data <- reactiveVal(NULL)
 
     observeEvent(processed_pknca_data(), {
       req(processed_pknca_data())
@@ -160,15 +188,25 @@ slope_selector_server <- function( # nolint
 
       if (changes$in_data || changes$in_options) {
         # New data or options changes (e.g. min.hl.points): regenerate all plots
-        plot_outputs(get_halflife_plots(
+        hl_result <- get_halflife_plots(
           new_pknca_data, title_vars = "ATPTREF"
-        )[["plots"]])
+        )
+        plot_outputs(hl_result[["plots"]])
+        plot_profile_data(hl_result[["data"]])
       } else if (changes$in_hl_adj) {
         # Modify plots with new half-life adjustments (inclusions/exclusions)
-        plot_outputs(handle_hl_adj_change(new_pknca_data, pknca_data(), plot_outputs()))
+        hl_result <- handle_hl_adj_change(
+          new_pknca_data, pknca_data(), plot_outputs(), plot_profile_data()
+        )
+        plot_outputs(hl_result$plots)
+        plot_profile_data(hl_result$data)
       } else if (changes$in_selected_intervals) {
         # Add/remove plots based on intervals (selection from nca_setup.R)
-        plot_outputs(handle_interval_change(new_pknca_data, pknca_data(), plot_outputs()))
+        hl_result <- handle_interval_change(
+          new_pknca_data, pknca_data(), plot_outputs(), plot_profile_data()
+        )
+        plot_outputs(hl_result$plots)
+        plot_profile_data(hl_result$data)
       }
 
       # Update the searching widget choices based on the new data
@@ -203,33 +241,51 @@ slope_selector_server <- function( # nolint
       pknca_data(new_pknca_data)
     })
 
+    # Apply flag-based filtering when the checkbox is checked
+    filtered_plot_outputs <- reactive({
+      plots <- plot_outputs()
+      req(!is.null(plots))
+      if (!isTRUE(input$filter_flagged) || is.null(flag_rules())) return(plots)
+
+      profile_data <- plot_profile_data()
+      if (is.null(profile_data) || length(profile_data) == 0) return(plots)
+
+      flagged_ids <- .get_flagged_profile_ids(profile_data, flag_rules())
+      plots[names(plots) %in% flagged_ids]
+    })
+
     # Call the pagination/searcher module to:
     # - Providing indices of plots for the selected subject(s)
     # - Providing indices for which plots to display based on pagination
     page_search <- page_and_searcher_server(
       id = "page_and_searcher",
       search_subject = reactive(input$search_subject),
-      plot_outputs = plot_outputs,
+      plot_outputs = filtered_plot_outputs,
       plots_per_page = reactive(input$plots_per_page)
     )
 
     observe({
-      req(!is.null(plot_outputs()))
+      req(!is.null(filtered_plot_outputs()))
       output$slope_plots_ui <- renderUI({
-        if (length(plot_outputs()) == 0) {
-          div(
-            class = "slope-selector-empty-state",
-            icon("info-circle"),
-            tags$p(
+        if (length(filtered_plot_outputs()) == 0) {
+          msg <- if (isTRUE(input$filter_flagged)) {
+            "No flagged profiles to display. All half-life fits satisfy the flag rules."
+          } else {
+            paste(
               "No slope plots to display.",
               "Half-life plots require at least one half-life",
               "related parameter to be selected",
               "(e.g., LAMZHL, LAMZ, R2ADJ, LAMZNPT)."
             )
+          }
+          div(
+            class = "slope-selector-empty-state",
+            icon("info-circle"),
+            tags$p(msg)
           )
         } else {
           shinyjs::enable(selector = ".btn-page")
-          plot_outputs() %>%
+          filtered_plot_outputs() %>%
             # Filter plots based on user search
             .[page_search$is_plot_searched()] %>%
             # Arrange plots by the specified group order