fix: generate HL plots when any half.life-dependent param is selected

Gero1999 · ona-agent · Gero1999 · commit 48b978decc5a · 2026-04-02T05:41:16.000Z
Keep intervals where half.life or any dependent parameter
(PKNCA::get.parameter.deps('half.life')) is TRUE, then reduce them to
compute only half.life. Strips imputation and other params to avoid
PKNCA_impute_method_blq errors and tidyr::spread duplicate-key issues.

Co-authored-by: Ona &lt;no-reply@ona.com&gt;
diff --git a/R/get_halflife_plots.R b/R/get_halflife_plots.R
@@ -16,39 +16,39 @@
 #' @export
 get_halflife_plots <- function(pknca_data, add_annotations = TRUE,
                                title_vars = NULL) {
-  
+
   # If the input has empty concentration or intervals, just return an empty list
   if (nrow(pknca_data$conc$data) == 0 || nrow(pknca_data$intervals) == 0) {
     return(list(plots = list(), data = list()))
   }
-  
+
   # Identify column names
   time_col <- pknca_data$conc$columns$time
   conc_col <- pknca_data$conc$columns$concentration
   timeu_col <- pknca_data$conc$columns$timeu
   concu_col <- pknca_data$conc$columns$concu
   exclude_hl_col <- pknca_data$conc$columns$exclude_half.life
-  
+
   # Define which columns use for the title to keep it short
   group_conc_cols <- group_vars(pknca_data)
   group_conc_n_levels <- sapply(
     pknca_data$conc$data[group_conc_cols], \(x) length(unique(x))
   )
   title_cols <- group_conc_cols[group_conc_n_levels > 1]
-  
+
   # Append caller-specified title variables that exist in the data
   extra <- intersect(title_vars, names(pknca_data$conc$data))
   title_cols <- unique(c(extra, title_cols))
-  
+
   # Make sure to create a default exclude half life column if it does not exist
   if (is.null(exclude_hl_col)) {
     pknca_data$conc$data[["exclude_half.life"]] <- FALSE
     exclude_hl_col <- "exclude_half.life"
   }
-  
+
   # Adjust the input to compute half-life & show original row number
   pknca_data$conc$data$ROWID <- seq_len(nrow(pknca_data$conc$data))
-  
+
   # Keep intervals where half.life or any dependent parameter is selected,
   # then reduce them to only compute half.life (which yields lambda.z,
   # r.squared, etc. as side-effects). This avoids imputation and duplicate-key
@@ -62,20 +62,20 @@ get_halflife_plots <- function(pknca_data, add_annotations = TRUE,
     names(pknca_data$intervals)
   )
   other_params <- setdiff(all_params, "half.life")
-  
+
   pknca_data$intervals <- pknca_data$intervals %>%
     filter(type_interval == "main") %>%
     filter(half.life | if_any(all_of(hl_dep_params))) %>%
     mutate(half.life = TRUE, across(all_of(other_params), ~FALSE)) %>%
     mutate(impute = NA_character_) %>%
     unique()
   pknca_data$impute <- NA_character_
-  
+
   d_conc_with_res <- .merge_conc_with_nca_results(
     pknca_data, time_col, conc_col, timeu_col,
     concu_col, exclude_hl_col, title_vars
   )
-  
+
   # Mark points used in half-life calculation
   info_per_plot_list <- d_conc_with_res %>%
     # Indicate plot details
@@ -124,7 +124,7 @@ get_halflife_plots <- function(pknca_data, add_annotations = TRUE,
     filter(.[[time_col]] <= tlast) %>%
     # Disconsider BLQ points at the middle as well
     filter(.[[conc_col]] > 0)
-  
+
   info_per_plot_list <- info_per_plot_list %>%
     mutate(
       color = "black",
@@ -134,12 +134,12 @@ get_halflife_plots <- function(pknca_data, add_annotations = TRUE,
     ) %>%
     group_by(!!!syms(c(group_vars(pknca_data), "start", "end"))) %>%
     group_split()
-  
+
   plot_list <- list()
   data_list <- list()
   for (i in seq_along(info_per_plot_list)) {
     df <- info_per_plot_list[[i]]
-    
+
     # Create line data
     if (any(df$is_halflife_used, na.rm = TRUE)) {
       df_fit <- df[df$is_halflife_used, ]
@@ -154,7 +154,7 @@ get_halflife_plots <- function(pknca_data, add_annotations = TRUE,
       )
       colnames(fit_line_data)[1] <- time_col
     }
-    
+
     # Unique plot ID based on grouping variables and interval times
     plotid_vars <- c(group_vars(pknca_data), "start", "end")
     plotid <- paste0(
@@ -163,7 +163,7 @@ get_halflife_plots <- function(pknca_data, add_annotations = TRUE,
         collapse = "_"
       )
     )
-    
+
     # Create the plot
     available_title_cols <- intersect(title_cols, names(df))
     plot_list[[plotid]] <- get_halflife_plots_single(
@@ -203,14 +203,14 @@ get_halflife_plots <- function(pknca_data, add_annotations = TRUE,
                                          exclude_hl_col,
                                          extra_vars = NULL) {
   o_nca <- suppressWarnings(PKNCA::pk.nca(pknca_data))
-  
+
   if (!"PPSTRES" %in% names(o_nca$result)) {
     o_nca$result$PPSTRES <- o_nca$result$PPORRES
     if ("PPORRESU" %in% names(o_nca$result)) {
       o_nca$result$PPSTRESU <- o_nca$result$PPORRESU
     }
   }
-  
+
   wide_output <- o_nca
   wide_output$result <- wide_output$result %>%
     filter(
@@ -219,17 +219,17 @@ get_halflife_plots <- function(pknca_data, add_annotations = TRUE,
     ) %>%
     select(-any_of(c("PPORRESU", "PPSTRESU", "PPSTRES"))) %>%
     mutate(exclude = paste0(na.omit(unique(exclude)), collapse = ". "))
-  
+
   wide_output <- as.data.frame(wide_output, out_format = "wide") %>%
     unique()
-  
+
   conc_select_cols <- c(group_vars(pknca_data), time_col, conc_col,
                         timeu_col, concu_col, exclude_hl_col, "ROWID")
   merge_by <- c(group_vars(pknca_data))
   extra <- intersect(extra_vars, names(pknca_data$conc$data))
   conc_select_cols <- c(conc_select_cols, extra)
   merge_by <- c(merge_by, extra)
-  
+
   merge(
     pknca_data$conc$data %>%
       select(!!!syms(conc_select_cols)),
@@ -262,19 +262,19 @@ get_halflife_plots <- function(pknca_data, add_annotations = TRUE,
 #' @returns A plotly object representing the scatter points (plot_data)
 #' @noRd
 get_halflife_plots_single <- function(
-    plot_data,
-    fit_line_data,
-    time_col,
-    conc_col,
-    group_vars,
-    title,
-    subtitle,
-    xlab,
-    ylab,
-    color,
-    symbol,
-    add_annotations = TRUE,
-    text = NULL
+  plot_data,
+  fit_line_data,
+  time_col,
+  conc_col,
+  group_vars,
+  title,
+  subtitle,
+  xlab,
+  ylab,
+  color,
+  symbol,
+  add_annotations = TRUE,
+  text = NULL
 ) {
   if (is.null(text)) {
     text <- paste0(
diff --git a/inst/shiny/modules/tab_nca/setup/slope_selector.R b/inst/shiny/modules/tab_nca/setup/slope_selector.R
@@ -28,7 +28,7 @@
 slope_selector_ui <- function(id) {
   ns <- NS(id)
   assets <- system.file("shiny/www", package = "aNCA")
-  
+
   div(
     class = "slope-selector-module",
     manual_slopes_table_ui(ns("manual_slopes")),
@@ -45,36 +45,36 @@ slope_selector_ui <- function(id) {
                 Please remember to apply your changes once you are done by clicking Run NCA again!
               "),
             div(class = "gif-grid",
-                div(
-                  class = "gif-container",
-                  tags$h1("Check"),
-                  tags$h6("Hover the mouse over points to inspect individual samples."),
-                  img(src = "images/slope_plot_check.gif", alt = "Check")
-                ),
-                div(
-                  class = "gif-container",
-                  tags$h1("Zoom"),
-                  tags$h6("Click and drag to select and zoom in a specific area.",
-                          " Double click to zoom out."
-                  ),
-                  img(src = "images/slope_plot_zoom.gif", alt = "Zoom")
+              div(
+                class = "gif-container",
+                tags$h1("Check"),
+                tags$h6("Hover the mouse over points to inspect individual samples."),
+                img(src = "images/slope_plot_check.gif", alt = "Check")
+              ),
+              div(
+                class = "gif-container",
+                tags$h1("Zoom"),
+                tags$h6("Click and drag to select and zoom in a specific area.",
+                  " Double click to zoom out."
                 ),
-                div(
-                  class = "gif-container",
-                  tags$h1("Select"),
-                  tags$h6("Click the first and then the last point",
-                          " you want to include in the slope."),
-                  img(src = "images/slope_plot_select.gif", alt = "Select")
+                img(src = "images/slope_plot_zoom.gif", alt = "Zoom")
+              ),
+              div(
+                class = "gif-container",
+                tags$h1("Select"),
+                tags$h6("Click the first and then the last point",
+                        " you want to include in the slope."),
+                img(src = "images/slope_plot_select.gif", alt = "Select")
+              ),
+              div(
+                class = "gif-container",
+                tags$h1("Exclude"),
+                tags$h6(
+                  tags$div("Double click a point to exclude it."),
+                  tags$div("Double click it again to include it back.")
                 ),
-                div(
-                  class = "gif-container",
-                  tags$h1("Exclude"),
-                  tags$h6(
-                    tags$div("Double click a point to exclude it."),
-                    tags$div("Double click it again to include it back.")
-                  ),
-                  img(src = "images/slope_plot_exclude.gif", alt = "Exclude")
-                )
+                img(src = "images/slope_plot_exclude.gif", alt = "Exclude")
+              )
             )
           ),
           style = "unite",
@@ -130,32 +130,25 @@ slope_selector_server <- function( # nolint
 ) {
   moduleServer(id, function(input, output, session) {
     log_trace("{id}: Attaching server")
-    
+
     ns <- session$ns
-    
+
     pknca_data <- reactiveVal(NULL)
     plot_outputs <- reactiveVal(NULL)
-    
+
     observeEvent(processed_pknca_data(), {
       req(processed_pknca_data())
-      
+
       new_pknca_data <- processed_pknca_data()
-      # Keep main intervals where half.life or any dependent param is selected.
-      # get_halflife_plots() handles the rest (forcing half.life, clearing impute).
-      hl_dep_params <- intersect(
-        PKNCA::get.parameter.deps("half.life"),
-        names(new_pknca_data$intervals)
-      )
       new_pknca_data$intervals <- new_pknca_data$intervals %>%
-        filter(type_interval == "main") %>%
-        filter(half.life | if_any(all_of(hl_dep_params))) %>%
+        filter(type_interval == "main", half.life) %>%
         unique()
       changes <- detect_pknca_data_changes(
         old = pknca_data(),
         new = new_pknca_data,
         reason_col = "REASON"
       )
-      
+
       if (changes$in_data) {
         # New data or major changes: regenerate all plots
         plot_outputs(get_halflife_plots(
@@ -168,7 +161,7 @@ slope_selector_server <- function( # nolint
         # Add/remove plots based on intervals (selection from nca_setup.R)
         plot_outputs(handle_interval_change(new_pknca_data, pknca_data(), plot_outputs()))
       }
-      
+
       # Update the searching widget choices based on the new data
       if (changes$in_data | changes$in_selected_intervals) {
         updateSelectInput(
@@ -186,21 +179,21 @@ slope_selector_server <- function( # nolint
         group_conc_cols <- group_vars(pknca_data)
         group_conc_n_levels <- sapply(pknca_data$conc$data[group_conc_cols], \(x) length(unique(x)))
         group_cols_to_order <- group_conc_cols[group_conc_n_levels > 1]
-        
+
         updateOrderInput(
           session = session,
           inputId = "order_groups",
           items = group_cols_to_order
         )
       }
-      
+
       # Save the plots for the zip download (nca_results.R)
       session$userData$results$slope_selector <- plot_outputs()
-      
+
       # Update the object for future comparisons
       pknca_data(new_pknca_data)
     })
-    
+
     # 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
@@ -210,7 +203,7 @@ slope_selector_server <- function( # nolint
       plot_outputs = plot_outputs,
       plots_per_page = reactive(input$plots_per_page)
     )
-    
+
     observe({
       req(plot_outputs())
       output$slope_plots_ui <- renderUI({
@@ -224,13 +217,13 @@ slope_selector_server <- function( # nolint
           .[page_search$page_start():page_search$page_end()]
       })
     })
-    
+
     # Creates an initial version of the manual slope adjustments table with pknca_data
     # and handles the addition and deletion of rows through the UI
     slopes_table <- manual_slopes_table_server("manual_slopes", pknca_data, manual_slopes_override)
     manual_slopes <- slopes_table$manual_slopes
     refresh_reactable <- slopes_table$refresh_reactable
-    
+
     # Define the click events for the point exclusion and selection in the slope plots
     last_click_data <- reactiveVal(NULL)
     observeEvent(event_data("plotly_click", priority = "event"), {
@@ -245,24 +238,24 @@ slope_selector_server <- function( # nolint
       # Update reactive values: last click & manual slopes table
       last_click_data(click_result$last_click_data)
       manual_slopes(click_result$manual_slopes)
-      
+
       # render rectable anew #
       shinyjs::runjs("memory = {};") # needed to properly reset reactable.extras widgets
       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.
     observeEvent(manual_slopes(), {
       req(manual_slopes())
-      
+
       # Update reactable with rules
       reactable::updateReactable(
         outputId = "manual_slopes",
         data = manual_slopes()
       )
-      
+
     })
     #' returns half life adjustments rules to update processed_pknca_data in nca_setup.R
     manual_slopes
diff --git a/inst/shiny/www/main.css b/inst/shiny/www/main.css
