diff --git a/R/get_halflife_plots.R b/R/get_halflife_plots.R index 857a98b90..f0a81ca47 100644 --- a/R/get_halflife_plots.R +++ b/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) ) diff --git a/inst/shiny/functions/utils-slope_selector.R b/inst/shiny/functions/utils-slope_selector.R index 8374f7d21..b219ea5a8 100644 --- a/inst/shiny/functions/utils-slope_selector.R +++ b/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() +} + diff --git a/inst/shiny/modules/tab_nca/nca_setup.R b/inst/shiny/modules/tab_nca/nca_setup.R index 5ca278b0e..3a97b5b46 100644 --- a/inst/shiny/modules/tab_nca/nca_setup.R +++ b/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 diff --git a/inst/shiny/modules/tab_nca/setup/slope_selector.R b/inst/shiny/modules/tab_nca/setup/slope_selector.R index 7f3cfe0f1..25471ceec 100644 --- a/inst/shiny/modules/tab_nca/setup/slope_selector.R +++ b/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