Merge pull request #1087 from pharmaverse/1084-consolidate-update_main_intervals-and-units-update-into-pknca_update_data_object

Consolidate update_main_intervals and units update into PKNCA_update_data_object

Author: Gero1999

DESCRIPTION

@@ -1,6 +1,6 @@
 Package: aNCA
 Title: (Pre-)Clinical NCA in a Dynamic Shiny App
-Version: 0.1.0.9128
+Version: 0.1.0.9129
 Authors@R: c(
     person("Ercan", "Suekuer", email = "ercan.suekuer@roche.com", role = "aut",
            comment = c(ORCID = "0009-0001-1626-1526")),

NAMESPACE

@@ -105,9 +105,11 @@ importFrom(dplyr,n)
 importFrom(dplyr,n_distinct)
 importFrom(dplyr,rename)
 importFrom(dplyr,row_number)
+importFrom(dplyr,rows_update)
 importFrom(dplyr,rowwise)
 importFrom(dplyr,select)
 importFrom(dplyr,slice)
+importFrom(dplyr,slice_max)
 importFrom(dplyr,slice_tail)
 importFrom(dplyr,summarise)
 importFrom(dplyr,sym)

R/PKNCA.R

@@ -250,6 +250,11 @@ PKNCA_create_data_object <- function( # nolint: object_name_linter
 #'
 #' Step 6: Indicate points excluded / selected manually for half-life
 #'
+#' Step 7 (optional): Update intervals with parameter selections per study type
+#' and partial AUC ranges via [update_main_intervals()].
+#'
+#' Step 8 (optional): Apply custom units table for PPSTRESU overrides.
+#'
 #' Note*: The function assumes that the `adnca_data` object has been
 #' created using the `PKNCA_create_data_object()` function.
 #'
@@ -261,17 +266,26 @@ PKNCA_create_data_object <- function( # nolint: object_name_linter
 #' @param hl_adj_rules A data frame containing half-life adjustment rules. It must
 #' contain group columns and rule specification columns;
 #' TYPE: (Inclusion, Exclusion), RANGE: (start-end).
-#' @param should_impute_c0 Logical indicating whether to impute start concentration values
+#' @param start_impute Logical indicating whether to impute start concentration values.
+#' Also forwarded to [update_main_intervals()] when `parameter_selections` is provided.
 #' @param exclusion_list List of exclusion reasons and row indices to apply to the
 #' concentration data. Each item in the list should have:
 #' - reason: character string with the exclusion reason (e.g., "Vomiting")
 #' - rows: integer vector of row indices to apply the exclusion to
 #' @param keep_interval_cols Optional character vector of additional columns
 #' to keep in the intervals data frame and when the NCA is run (pk.nca) also in the results
+#' @param parameter_selections Optional named list of selected PKNCA parameters
+#' by study type (forwarded to [update_main_intervals()]).
+#' @param int_parameters Optional data frame containing partial AUC ranges
+#' (forwarded to [update_main_intervals()]).
+#' @param blq_imputation_rule Optional list defining the BLQ imputation rule
+#' (forwarded to [update_main_intervals()]).
+#' @param custom_units_table Optional data frame with PPSTRESU overrides.
+#' When provided, applied via [dplyr::rows_update()] on the PKNCAdata units table.
 #'
 #' @returns A fully configured `PKNCAdata` object.
 #'
-#' @importFrom dplyr filter mutate select
+#' @importFrom dplyr filter mutate select rows_update
 #' @importFrom tidyr crossing
 #' @importFrom rlang sym
 #' @importFrom purrr pmap
@@ -283,10 +297,14 @@ PKNCA_update_data_object <- function( # nolint: object_name_linter
     selected_analytes,
     selected_profile,
     selected_pcspec,
-    should_impute_c0 = TRUE,
+    start_impute = TRUE,
     hl_adj_rules = NULL,
     exclusion_list = NULL,
-    keep_interval_cols = NULL) {
+    keep_interval_cols = NULL,
+    parameter_selections = NULL,
+    int_parameters = NULL,
+    blq_imputation_rule = NULL,
+    custom_units_table = NULL) {
 
   data <- adnca_data
   analyte_column <- data$conc$columns$groups$group_analyte
@@ -316,7 +334,7 @@ PKNCA_update_data_object <- function( # nolint: object_name_linter
   data$intervals <- format_pkncadata_intervals(
     pknca_conc = data$conc,
     pknca_dose = data$dose,
-    start_from_last_dose = should_impute_c0,
+    start_from_last_dose = start_impute,
     keep_interval_cols = keep_interval_cols
   ) %>%
     # Join route information
@@ -341,6 +359,26 @@ PKNCA_update_data_object <- function( # nolint: object_name_linter
   if (!is.null(hl_adj_rules)) {
     data <- update_pknca_with_rules(data, hl_adj_rules)
   }
+
+  # Update intervals with parameter selections and partial AUCs
+  data <- update_main_intervals(
+    data = data,
+    parameter_selections = parameter_selections,
+    int_parameters = int_parameters,
+    impute = start_impute,
+    blq_imputation_rule = blq_imputation_rule
+  )
+
+  # Apply custom units table
+  if (!is.null(custom_units_table)) {
+    data$units <- rows_update(
+      data$units,
+      custom_units_table,
+      by = c("PPTESTCD", "PPORRESU"),
+      unmatched = "ignore"
+    )
+  }
+
   data
 }
 

R/intervals.R

@@ -82,7 +82,8 @@ format_pkncadata_intervals <- function(pknca_conc,
     )))
 
   # Based on dose times create a data frame with start and end times
-  dose_intervals <- left_join(sub_pknca_dose,
+  dose_intervals <- left_join(
+    sub_pknca_dose,
     sub_pknca_conc,
     by = intersect(names(sub_pknca_dose), c(conc_groups, "DOSNOA")),
     relationship = "many-to-many"
@@ -128,11 +129,74 @@ format_pkncadata_intervals <- function(pknca_conc,
     mutate(type_interval = "main")
 }
 
+#' Derive study types from a PKNCAdata object
+#'
+#' Extracts concentration and dose data, merges dose duration if needed,
+#' and calls [detect_study_types()] to classify each group.
+#'
+#' @param data A PKNCAdata object.
+#'
+#' @returns A deduplicated data frame with grouping columns and a `type` column.
+#'
+#' @importFrom dplyr mutate left_join filter select slice_max distinct across all_of
+#' @noRd
+#' @keywords internal
+.derive_study_types <- function(data) {
+  conc_data <- data$conc$data
+  conc_groups <- group_vars(data$conc)
+  dose_groups <- group_vars(data$dose)
+  groups <- intersect(dose_groups, conc_groups)
+  groups <- groups[vapply(groups, function(col) {
+    !is.null(col) && length(unique(conc_data[[col]])) > 1
+  }, logical(1))]
+
+  # Blank METABFL unconditionally so metabolite-specific types are not
+  # assigned at the interval level.
+  conc_data$METABFL <- ""
+
+  # Dose duration may live in dose data only; merge it for detect_study_types.
+  duration_col <- data$dose$columns$duration
+  if (!is.null(duration_col) && !duration_col %in% names(conc_data)) {
+    dose_data <- data$dose$data
+    if (duration_col %in% names(dose_data)) {
+      conc_time <- data$conc$columns$time
+      dose_time <- data$dose$columns$time
+      join_by <- intersect(dose_groups, conc_groups)
+
+      dose_subset <- dose_data[, unique(c(join_by, dose_time, duration_col)), drop = FALSE]
+      dose_subset <- unique(dose_subset)
+      names(dose_subset)[names(dose_subset) == dose_time] <- ".dose_time"
+
+      conc_data <- conc_data %>%
+        mutate(.ROWID = seq_len(n())) %>%
+        left_join(dose_subset, by = join_by, relationship = "many-to-many") %>%
+        filter(.dose_time <= .data[[conc_time]] | is.na(.dose_time)) %>%
+        slice_max(.dose_time, n = 1, by = .ROWID, with_ties = FALSE) %>%
+        select(-".ROWID", -".dose_time")
+    } else {
+      conc_data[[duration_col]] <- 0
+    }
+  }
+
+  study_types_df <- detect_study_types(
+    conc_data,
+    groups,
+    metabfl_column = "METABFL",
+    route_column = data$dose$columns$route,
+    volume_column = data$conc$columns$volume
+  )
+
+  # Deduplicate by grouping columns to prevent interval row duplication
+  # when detect_study_types produces multiple types per group.
+  grouping_cols <- setdiff(names(study_types_df), "type")
+  study_types_df %>%
+    distinct(across(all_of(grouping_cols)), .keep_all = TRUE)
+}
+
 #' Update an intervals data frame with user-selected parameters by study type
 #'
 #' @param data A PKNCAdata object containing intervals and dosing data.
 #' @param parameter_selections A named list of selected PKNCA parameters by study type.
-#' @param study_types_df A data frame mapping analysis profiles to their study type.
 #' @param int_parameters A data frame containing partial AUC ranges.
 #' @param impute Logical indicating whether to impute start values for parameters.
 #' @param blq_imputation_rule A list defining the Below Limit of Quantification (BLQ)
@@ -143,22 +207,30 @@ format_pkncadata_intervals <- function(pknca_conc,
 #' which does not specify any BLQ imputation in any interval.
 #'
 #' @importFrom dplyr left_join mutate across where select all_of if_else bind_rows filter
+#' @importFrom dplyr group_by ungroup slice_max distinct
 #' @importFrom purrr pmap
 #' @returns An updated PKNCAdata object with parameter intervals based on user selections.
 #' @export
 update_main_intervals <- function(
   data,
-  parameter_selections,
-  study_types_df, int_parameters,
+  parameter_selections = NULL,
+  int_parameters = NULL,
   impute = TRUE,
   blq_imputation_rule = NULL
 ) {
+  if (is.null(parameter_selections)) parameter_selections <- list()
+  if (is.null(int_parameters)) {
+    int_parameters <- data.frame(
+      parameter = character(), start_auc = numeric(), end_auc = numeric()
+    )
+  }
+
   all_pknca_params <- setdiff(names(PKNCA::get.interval.cols()), c("start", "end"))
 
-  # Determine the grouping columns from the study_types_df
-  grouping_cols <- setdiff(names(study_types_df), c("type"))
+  study_types_df <- .derive_study_types(data)
+
+  grouping_cols <- setdiff(names(study_types_df), "type")
   missing_columns <- setdiff(grouping_cols, colnames(data$intervals))
-  # check for grouping cols in intervals
   if (length(missing_columns) > 0) {
     stop(paste("Missing required columns:", paste(missing_columns, collapse = ", ")))
   }

R/zzz.R

@@ -1,8 +1,10 @@
 .onLoad <- function(libname, pkgname) {
   utils::globalVariables(c(
     ".",
+    ".dose_time",
     ".facet_label_values",
     ".facet_n",
+    ".ROWID",
     "facet_label",
     ":=",
     "ADOSEDUR",

inst/shiny/modules/tab_nca/nca_setup.R

@@ -100,39 +100,32 @@ nca_setup_server <- function(id, data, adnca_data, extra_group_vars, settings_ov
     # Update pknca data object and intervals using summary output
     processed_pknca_data <- reactive({
       req(adnca_data(), settings(),
-          parameters_output$selections(), parameters_output$types_df())
+          parameters_output$selections())
 
       log_trace("Updating PKNCA::data object.")
 
-      base_pknca_data <- PKNCA_update_data_object(
+      final_data <- PKNCA_update_data_object(
         adnca_data = adnca_data(),
         method = settings()$method,
         selected_analytes = settings()$analyte,
         selected_profile = settings()$profile,
         selected_pcspec = settings()$pcspec,
-        should_impute_c0 = settings()$data_imputation$impute_c0,
+        start_impute = settings()$data_imputation$impute_c0,
         hl_adj_rules = slope_rules(),
         exclusion_list = general_exclusions(),
-        keep_interval_cols = extra_group_vars()
+        keep_interval_cols = extra_group_vars(),
+        parameter_selections = parameters_output$selections(),
+        int_parameters = settings()$int_parameters,
+        blq_imputation_rule = settings()$data_imputation$blq_imputation_rule
       )
 
       # Show bioavailability widget if it is possible to calculate
-      if (base_pknca_data$dose$data$std_route %>% unique() %>% length() == 2) {
+      if (final_data$dose$data$std_route %>% unique() %>% length() == 2) {
         shinyjs::show(selector = ".bioavailability-picker")
       } else {
         shinyjs::hide(selector = ".bioavailability-picker")
       }
 
-      # Call the updated function with the direct inputs
-      final_data <- update_main_intervals(
-        data = base_pknca_data,
-        parameter_selections = parameters_output$selections(),
-        study_types_df = parameters_output$types_df(),
-        int_parameters = settings()$int_parameters,
-        impute = settings()$data_imputation$impute_c0,
-        blq_imputation_rule = settings()$data_imputation$blq_imputation_rule
-      )
-
       if (nrow(final_data$intervals) == 0) {
         showNotification(
           "All intervals were filtered. Please revise your settings",

inst/www/templates/script_template.R

@@ -19,7 +19,6 @@ time_duplicate_rows <- settings_list$time_duplicate_rows
 int_parameters <- settings_list$settings$int_parameters
 units_table <- settings_list$units_table
 parameters_selected_per_study <- settings_list$settings$parameters$selections
-study_types_df <- settings_list$settings$parameters$types_df
 extra_vars_to_keep <-  settings_list$extra_vars_to_keep
 slope_rules <- settings_list$slope_rules
 
@@ -32,38 +31,20 @@ pknca_obj <- adnca_data %>%
     time_duplicate_rows = time_duplicate_rows
   ) %>%
 
-  # Setup basic settings
+  # Setup NCA settings, intervals, parameter selections, and units
   PKNCA_update_data_object(
     method = settings_list$settings$method,
     selected_analytes = settings_list$settings$analyte,
     selected_profile = settings_list$settings$profile,
     selected_pcspec = settings_list$settings$pcspec,
-    should_impute_c0 = settings_list$settings$data_imputation$impute_c0,
+    start_impute = settings_list$settings$data_imputation$impute_c0,
     exclusion_list = settings_list$settings$general_exclusions,
     hl_adj_rules = slope_rules,
-    keep_interval_cols = setdiff(extra_vars_to_keep, c("DOSEA", "ATPTREF", "ROUTE"))
-  ) %>%
-
-  update_main_intervals(
-    int_parameters = int_parameters,
+    keep_interval_cols = setdiff(extra_vars_to_keep, c("DOSEA", "ATPTREF", "ROUTE")),
     parameter_selections = parameters_selected_per_study,
-    study_types_df =  study_types_df,
-    impute = settings_list$settings$data_imputation$impute_c0
-  ) %>%
-
-  # Define the desired units for the parameters (PPSTRESU)
-  {
-    pknca_obj <- .
-    if (!is.null(units_table)) {
-      pknca_obj[["units"]] <- dplyr::rows_update(
-        pknca_obj[["units"]],
-        units_table,
-        by = c("PPTESTCD", "PPORRESU"),
-        unmatched = "ignore"
-      )
-    }
-    pknca_obj
-  }
+    int_parameters = int_parameters,
+    custom_units_table = units_table
+  )
 
 ## Run NCA calculations ########################################
 flag_rules <- settings_list$settings$flags