diff --git a/.github/PULL_REQUEST_TEMPLATE.md b/.github/PULL_REQUEST_TEMPLATE.md index b64a3a610..ad5f31524 100644 --- a/.github/PULL_REQUEST_TEMPLATE.md +++ b/.github/PULL_REQUEST_TEMPLATE.md @@ -21,6 +21,7 @@ How to test features not covered by unit tests. - [ ] New logic is documented - [ ] App or package changes are reflected in NEWS - [ ] Package version is incremented +- [ ] R script works with the new implementation (if applicable) ## Notes to reviewer diff --git a/.lintr b/.lintr index 9a641ba55..a1383cecf 100644 --- a/.lintr +++ b/.lintr @@ -11,4 +11,4 @@ linters: seq_linter = seq_linter() ) encoding: "UTF-8" -exclusions: list("R/PKNCA_extra_parameters.R", "tests/testthat/test-PKNCA_extra_parameters.R") +exclusions: list("R/PKNCA_extra_parameters.R", "tests/testthat/test-PKNCA_extra_parameters.R", "inst/shiny/www/templates/script_template.R") diff --git a/NAMESPACE b/NAMESPACE index bbe8208fa..ba6100180 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -23,6 +23,7 @@ export(apply_mapping) export(calculate_f) export(calculate_ratios) export(calculate_summary_stats) +export(calculate_table_ratios) export(check_slope_rule_overlap) export(convert_volume_units) export(create_metabfl) @@ -46,6 +47,7 @@ export(g_pkcg03_log) export(generate_tooltip_text) export(get_conversion_factor) export(get_label) +export(get_session_code) export(interval_add_impute) export(interval_remove_impute) export(l_pkcl01) @@ -65,6 +67,7 @@ export(pknca_calculate_f) export(process_data_individual) export(process_data_mean) export(read_pk) +export(remove_pp_not_requested) export(run_app) export(simplify_unit) export(translate_terms) @@ -140,6 +143,8 @@ importFrom(stats,median) importFrom(stats,na.omit) importFrom(stats,sd) importFrom(stats,setNames) +importFrom(stringr,fixed) +importFrom(stringr,str_detect) importFrom(stringr,str_glue) importFrom(stringr,str_split) importFrom(stringr,str_trim) diff --git a/NEWS.md b/NEWS.md index 60d72cb00..b9b2497a6 100644 --- a/NEWS.md +++ b/NEWS.md @@ -4,6 +4,7 @@ * Enhancements to the slides outputs including grouping by PKNCA groups, dose profile, and additional grouping variables (#791) * Option to include and apply NCA flag rules with reasons (NCAwXRS) as defined by ADNCA standards. Any record populated within these columns will be excluded for the NCA (#752) +* R script exported in ZIP folder to re-run and replicate App outputs (#789) * Individual and Mean plots tabs now created using the same function, so the layout and plot themes are consistent across both plots (#712) * New flagging rule for lambda-z calculations based on r-squared, R2 (#834) * New Parameter Selection section in NCA tab allowing to select parameters by study type (#795) diff --git a/R/PKNCA.R b/R/PKNCA.R index 44400bc27..280250d2d 100644 --- a/R/PKNCA.R +++ b/R/PKNCA.R @@ -718,6 +718,37 @@ PKNCA_hl_rules_exclusion <- function(res, rules) { # nolint res } +#' Filter Out Parameters Not Requested in PKNCA Results (Pivot Version) +#' +#' This function removes parameters from the PKNCA results that were not requested by the user, +#' using a pivoted approach that also handles bioavailability settings. +#' +#' @param pknca_res A PKNCA results object containing at least $data$intervals and $result. +#' @return The PKNCA results object with non requested parameters removed from $result. +#' @export +remove_pp_not_requested <- function(pknca_res) { + params <- c(setdiff(names(PKNCA::get.interval.cols()), c("start", "end"))) + # Reshape intervals, filter + params_not_requested <- pknca_res$data$intervals %>% + pivot_longer( + cols = (any_of(params)), + names_to = "PPTESTCD", + values_to = "is_requested" + ) %>% + mutate(PPTESTCD = translate_terms(PPTESTCD, "PKNCA", "PPTESTCD")) %>% + group_by(across(c(-impute, -is_requested))) %>% + summarise( + is_requested = any(is_requested), + .groups = "drop" + ) %>% + filter(!is_requested) + + # Filter for requested params based on intervals + pknca_res$result <- pknca_res$result %>% + anti_join(params_not_requested, by = intersect(names(.), names(params_not_requested))) + pknca_res +} + #' Add Exclusion Reasons to PKNCAdata Object #' #' This function adds exclusion reasons to the `exclude` column of the concentration object diff --git a/R/get_session_code.R b/R/get_session_code.R new file mode 100644 index 000000000..85d6b77e8 --- /dev/null +++ b/R/get_session_code.R @@ -0,0 +1,191 @@ +#' Generate a session script code in R that can replicate the App outputs +#' +#' @param template_path Path to the R script template (e.g., script_template.R) +#' @param session The session object containing userData, etc. +#' @param output_path Path to write the resulting script file (e.g., "output_script.R") +#' @return The output_path (invisibly) +#' @export +get_session_code <- function(template_path, session, output_path) { + # Helper to get value from session$userData by path (e.g., 'settings$method') + get_session_value <- function(path) { + parts <- strsplit(path, "\\$")[[1]] + obj <- session$userData + for (p in parts) { + if (inherits(obj[[p]], "reactive")) { + obj <- obj[[p]]() + } else { + obj <- obj[[p]] + } + if (is.null(obj)) { + return(NULL) + } + } + obj + } + # Read template + script <- readLines(template_path, warn = FALSE) %>% + paste(collapse = "\n") + + # Find all session$userData$... + pattern <- "session\\$userData(\\$[a-zA-Z0-9_]+(\\(\\))?(\\$[a-zA-Z0-9_]+)*)" + matches <- gregexpr(pattern, script, perl = TRUE)[[1]] + if (matches[1] == -1) { + stop( + "Template has no placeholders (session$userData...) to substitute.", + "This may be due to an incorrect file path, a missing template, ", + "or a modified template without placeholders." + ) + } + + # Replace each match with deparsed value + for (i in rev(seq_along(matches))) { + start <- matches[i] + len <- attr(matches, "match.length")[i] + matched <- substr(script, start, start + len - 1) + # Extract the path after session$userData$ + path <- sub("^session\\$userData\\$", "", matched) + value <- get_session_value(path) + + deparsed <- clean_deparse(value, max_per_line = 15) + script <- paste0( + substr(script, 1, start - 1), + deparsed, + substr(script, start + len, nchar(script)) + ) + } + + # Split back into lines + script_lines <- strsplit(script, "\n")[[1]] + writeLines(script_lines, output_path) + invisible(output_path) +} + +#' Convert R objects into reproducible R code strings (internal) +#' +#' This internal S3 generic converts common R objects (data frames, lists, +#' atomic vectors, etc.) into character strings containing R code that will +#' reconstruct the object. It is used by the app script generator to +#' serialize `session$userData` values into a runnable R script. +#' +#' @param obj An R object to convert to a string of R code. +#' @param max_per_line Maximum number of elements to include per line for +#' long vectors/lists. +#' @param min_to_rep Minimum number of repeated elements to use `rep()` for +#' long vectors/lists. +#' @param indent Integer indentation level for multi-line outputs. +#' @return A single string containing R code that, when evaluated, will +#' reconstruct `obj` (or a close approximation for complex types). +#' @keywords internal +clean_deparse <- function(obj, indent = 0, max_per_line = 10, min_to_rep = 3) { + # Handle trivial length-0 constructors (character(0), numeric(0), list(), data.frame(), ...) + if (length(obj) == 0 && !is.null(obj)) { + return(paste0(class(obj)[1], "()")) + } + UseMethod("clean_deparse") +} + +#' @noRd +clean_deparse.default <- function(obj, indent = 0, max_per_line = 10, min_to_rep = 3) { + paste(deparse(obj, width.cutoff = 500), collapse = "") +} + +#' @noRd +clean_deparse.data.frame <- function(obj, indent = 0, max_per_line = 10, min_to_rep = 3) { + ind <- paste(rep(" ", indent), collapse = "") + + cols <- lapply(obj, function(col) { + clean_deparse(col, indent + 1, max_per_line = max_per_line) + }) + + col_strs <- paste0(ind, " ", names(obj), " = ", unlist(cols)) + if (length(col_strs) > 1) { + not_last <- seq_len(length(col_strs) - 1) + col_strs[not_last] <- paste0(col_strs[not_last], ",") + } + paste0("data.frame(\n", paste(col_strs, collapse = "\n"), "\n", ind, ")") +} + +#' @noRd +clean_deparse.list <- function(obj, indent = 0, max_per_line = 10, min_to_rep = 3) { + ind <- paste(rep(" ", indent), collapse = "") + n <- length(obj) + nms <- names(obj) + items <- vapply(seq_len(n), FUN.VALUE = "", function(i) { + name <- if (!is.null(nms) && nzchar(nms[i])) nms[i] else paste0("V", i) + # Quote name if not a valid R symbol + if (!grepl("^[A-Za-z.][A-Za-z0-9._]*$", name)) { + name <- sprintf('"%s"', name) + } + val <- obj[[i]] + val_str <- clean_deparse(val, indent + 1, max_per_line = max_per_line) + paste0(name, " = ", val_str) + }) + if (length(items) > 1) { + not_last <- seq_len(length(items) - 1) + items[not_last] <- paste0(items[not_last], ",") + } + item_strs <- paste0(ind, " ", items) + paste0("list(\n", paste(item_strs, collapse = "\n"), "\n", ind, ")") +} + +#' @noRd + +clean_deparse.character <- function(obj, indent = 0, max_per_line = 10, min_to_rep = 3) { + obj <- sprintf('"%s"', obj) + .deparse_vector(obj, indent, max_per_line, min_to_rep) +} + +#' @noRd + +clean_deparse.numeric <- function(obj, indent = 0, max_per_line = 10, min_to_rep = 3) { + obj <- sprintf("%s", obj) + .deparse_vector(obj, indent, max_per_line, min_to_rep) +} + +#' @noRd +clean_deparse.integer <- function(obj, indent = 0, max_per_line = 10, min_to_rep = 3) { + clean_deparse.numeric(obj, indent = indent, max_per_line = max_per_line, min_to_rep = min_to_rep) +} + +#' @noRd +clean_deparse.logical <- function(obj, indent = 0, max_per_line = 10, min_to_rep = 3) { + obj <- as.character(obj) + .deparse_vector(obj, indent, max_per_line, min_to_rep) +} + +#' Internal helper to deparse atomic vectors +#' using repetition simplification (rep) and line splitting +#' +#' @noRd +.deparse_vector <- function(obj, indent = 0, max_per_line = 10, min_to_rep = 3) { + n <- length(obj) + if (n == 1) { + return(obj) + } else { + rle_obj <- rle(obj) + lines_obj <- c() + for (i in seq_along(rle_obj$values)) { + val <- rle_obj$values[i] + len <- rle_obj$lengths[i] + if (len >= min_to_rep) { + rep_obj <- paste0("rep(", val, ", ", len, ")") + lines_obj <- c(lines_obj, rep_obj) + } else { + lines_obj <- c(lines_obj, rep(val, len)) + } + } + } + ind <- paste(rep(" ", indent), collapse = "") + lines <- split(lines_obj, ceiling(seq_along(lines_obj) / max_per_line)) + line_strs <- vapply(lines, function(x) paste(x, collapse = ", "), "") + if (is.list(lines) && length(lines) > 1) { + out <- paste0(ind, " ", line_strs, collapse = ",\n") + paste0("c(\n", out, "\n", ind, ")") + } else { + paste0("c(", paste0(line_strs, collapse = ",\n"), ")") + } +} + +# TODO (Gerardo): Create a linked function +# to obtain the code from a settings file +# (#826) diff --git a/R/pivot_wider_pknca_results.R b/R/pivot_wider_pknca_results.R index 6b495252c..ab6bada33 100644 --- a/R/pivot_wider_pknca_results.R +++ b/R/pivot_wider_pknca_results.R @@ -15,6 +15,13 @@ #' of the dose, relative to the last reference dose. #' 5) Temporarily: CDISC denomination of PK parameters related to half-life: "LAMZNPT", #' "LAMZLL", "LAMZ" Used to derive `LAMZNPT` and `LAMZMTD`. +#' @param flag_rules A named list of flagging rules to be applied to the results. Each rule +#' should be a list with two elements: `is.checked` (logical) indicating whether the rule +#' should be applied, and `threshold` (numeric) specifying the threshold value for flagging. +#' The name of each rule should correspond to a parameter in the results data.frame as a PPTESTCD +#' (e.g., "R2ADJ", "AUCPEO", "AUCPEP", "LAMZSPN"). +#' @param extra_vars_to_keep Optional character vector of variable names to join from the +#' concentration data to the output. Default is NULL. #' #' @returns A data frame which provides an easy overview on the results from the NCA #' in each profile/subject and how it was computed lambda (half life) and the results @@ -24,9 +31,11 @@ #' @importFrom dplyr filter slice across where #' @importFrom tidyr pivot_wider pivot_longer #' @importFrom purrr pmap_chr +#' @importFrom stringr str_detect fixed #' @export #' -pivot_wider_pknca_results <- function(myres) { + +pivot_wider_pknca_results <- function(myres, flag_rules = NULL, extra_vars_to_keep = NULL) { ############################################################################################ # Derive LAMZNPT & LAMZMTD # ToDo: At some point this will be integrated in PKNCA and will need to be removed//modified @@ -153,7 +162,32 @@ pivot_wider_pknca_results <- function(myres) { ungroup() # Add "label" attribute to columns - add_label_attribute(pivoted_res, myres) + pivoted_res <- add_label_attribute(pivoted_res, myres) + + # Add flagging columns for each rule and a general "flagged" column + out <- .create_flags_for_profiles( + final_results = pivoted_res, + myres = myres, + flag_rules = flag_rules + ) + + # If extra_vars_to_keep is provided, join these variables from the conc data + if (length(extra_vars_to_keep) > 0) { + conc_data <- myres$data$conc$data + # Only keep columns that exist in conc_data + vars_to_join <- intersect(extra_vars_to_keep, names(conc_data)) + group_vars <- group_vars(myres$data$conc) + if (length(vars_to_join) > 0) { + out <- out %>% + dplyr::inner_join( + dplyr::select(conc_data, dplyr::any_of(c(vars_to_join, group_vars))), + by = intersect(names(out), c(vars_to_join, group_vars)) + ) %>% + dplyr::distinct() + } + } + + out } #' Helper function to extract exclude values @@ -170,3 +204,60 @@ pivot_wider_pknca_results <- function(myres) { if (length(unique_values) == 0) NA_character_ else paste(unique_values, collapse = ", ") } + +#' Helper function to add "label" attribute to columns based on parameter names. +#' @noRd +#' @keywords internal +add_label_attribute <- function(df, myres) { + mapping_vr <- myres$result %>% + mutate( + PPTESTCD_unit = case_when( + type_interval == "manual" ~ paste0( + PPTESTCD, "_", start, "-", end, + ifelse(PPSTRESU != "", paste0("[", PPSTRESU, "]"), "") + ), + PPSTRESU != "" ~ paste0(PPTESTCD, "[", PPSTRESU, "]"), + TRUE ~ PPTESTCD + ), + PPTESTCD_cdisc = translate_terms(PPTESTCD, mapping_col = "PPTESTCD", target_col = "PPTEST") + ) %>% + select(PPTESTCD_cdisc, PPTESTCD_unit) %>% + distinct() %>% + pull(PPTESTCD_cdisc, PPTESTCD_unit) + + mapping_cols <- intersect(names(df), names(mapping_vr)) + attrs <- unname(mapping_vr[mapping_cols]) + + df[, mapping_cols] <- as.data.frame(mapply(function(col, bw) { + attr(col, "label") <- bw + col + }, df[, mapping_cols], attrs, SIMPLIFY = FALSE)) + df +} + +.create_flags_for_profiles <- function(final_results, myres, flag_rules) { + + # Add flaging columns in the pivoted results + applied_flags <- purrr::keep(flag_rules, function(x) x$is.checked) + flag_params <- names(flag_rules) + flag_thr <- sapply(flag_rules, FUN = \(x) x$threshold) + flag_rule_msgs <- paste0(flag_params, c(" < ", "<", " > ", " > ", " < "), flag_thr) + flag_cols <- names(final_results)[formatters::var_labels(final_results) + %in% translate_terms(flag_params, "PPTESTCD", "PPTEST")] + + if (length(flag_params) > 0) { + final_results <- final_results %>% + rowwise() %>% + mutate( + flagged = case_when( + is.na(Exclude) ~ "ACCEPTED", + any(sapply( + flag_rule_msgs, function(msg) str_detect(Exclude, fixed(msg)) + )) ~ "FLAGGED", + TRUE ~ "MISSING" + ) + ) %>% + ungroup() + } + final_results +} diff --git a/R/ratio_calculations.R b/R/ratio_calculations.R index 3ec8fa2af..8b09884be 100644 --- a/R/ratio_calculations.R +++ b/R/ratio_calculations.R @@ -85,30 +85,28 @@ multiple_matrix_ratios <- function(data, matrix_col, conc_col, units_col, #' @export #' @export calculate_ratios <- function( - data, - test_parameter, - ref_parameter = test_parameter, - match_cols, - ref_groups, - test_groups = NULL, - adjusting_factor = 1, - custom_pptestcd = NULL -) { + data, + test_parameter, + ref_parameter = test_parameter, + match_cols, + ref_groups, + test_groups = NULL, + adjusting_factor = 1, + custom_pptestcd = NULL) { UseMethod("calculate_ratios", data) } #' @export #' @export calculate_ratios.data.frame <- function( - data, - test_parameter, - ref_parameter = test_parameter, - match_cols, - ref_groups, - test_groups = NULL, - adjusting_factor = 1, - custom_pptestcd = NULL -) { + data, + test_parameter, + ref_parameter = test_parameter, + match_cols, + ref_groups, + test_groups = NULL, + adjusting_factor = 1, + custom_pptestcd = NULL) { if (!any(data$PPTESTCD == test_parameter)) { warning( paste0( @@ -237,15 +235,14 @@ calculate_ratios.data.frame <- function( #' @export calculate_ratios.PKNCAresults <- function( - data, - test_parameter, - ref_parameter = test_parameter, - match_cols, - ref_groups, - test_groups = NULL, - adjusting_factor = 1, - custom_pptestcd = NULL -) { + data, + test_parameter, + ref_parameter = test_parameter, + match_cols, + ref_groups, + test_groups = NULL, + adjusting_factor = 1, + custom_pptestcd = NULL) { # Check if match_cols and ref_groups are valid group columns # Make checks on the input formats cols_used_for_ratios <- c(match_cols, names(ref_groups), names(test_groups)) @@ -275,3 +272,150 @@ calculate_ratios.PKNCAresults <- function( data$result <- bind_rows(data$result, ratios_result) data } + +#' Apply Ratio Calculations to PKNCAresult Object +#' +#' This function takes a PKNCAresult object and a data.frame specifying ratio calculations. +#' +#' @param res A PKNCAresult object. +#' @param ratio_table Data.frame with columns: +#' TestParameter, RefParameter, Reference, Test, AggregateSubject, +#' AdjustingFactor, TestGroups, RefGroups, PPTESTCD. +#' @returns The updated PKNCAresult object with added rows in the `result` data.frame. +#' @export +calculate_table_ratios <- function(res, ratio_table) { + # Use lapply to process each row of ratio_table + ratio_results <- lapply(seq_len(nrow(ratio_table)), function(i) { + result <- calculate_ratio_app( + res = res, + test_parameter = ratio_table$TestParameter[i], + ref_parameter = ratio_table$RefParameter[i], + test_group = ratio_table$TestGroups[i], + ref_group = ratio_table$RefGroups[i], + aggregate_subject = ratio_table$AggregateSubject[i], + adjusting_factor = as.numeric(ratio_table$AdjustingFactor[i]), + custom_pptestcd = if (ratio_table$PPTESTCD[i] == "") NULL else ratio_table$PPTESTCD[i] + ) + if (nrow(result) == 0) { + warning( + "Ratio ", ratio_table$PPTESTCD[i], " not computed.", + "No comparable groups found between RefGroups", + " (", ratio_table$RefGroups[i], ")", + "and TestGroups", + " (", ratio_table$TestGroups[i], ")" + ) + } + result + }) + if (!"PPANMETH" %in% names(res$result)) { + res$result$PPANMETH <- "" + } + + # Combine all results into the original PKNCAresult object + res$result <- do.call(bind_rows, c(list(res$result), ratio_results)) + res +} + +#' Links the table ratio of the App with the ratio calculations via PKNCA results +#' +#' @param res A PKNCAresult object. +#' @param test_parameter Character. The PPTESTCD value to use as test (numerator). +#' @param ref_parameter Character. The PPTESTCD value to use as reference (denominator). +#' Defaults to test_parameter. +#' @param test_group Character. The test group (numerator). Default is "(all other levels)". +#' @param ref_group Character. The reference group (denominator). +#' @param aggregate_subject Character. Aggregation mode: "yes", "no", or "if-needed". +#' @param adjusting_factor Numeric that multiplies the calculated ratio. Default is 1. +#' @param custom_pptestcd Optional character. If provided, will be used as the PPTESTCD value. +#' @returns A data.frame with the calculated ratios for the specified settings. +calculate_ratio_app <- function( + res, + test_parameter, + ref_parameter = test_parameter, + test_group = "(all other levels)", + ref_group = "PARAM: Analyte01", + aggregate_subject = "no", + adjusting_factor = 1, + custom_pptestcd = NULL) { + reference_colname <- gsub("(.*): (.*)", "\\1", ref_group) + match_cols <- setdiff(unique(c(dplyr::group_vars(res), "start", "end")), reference_colname) + + ########### This is very App specific ############### + atptref_exists <- "ATPTREF" %in% reference_colname + route_and_aggregate <- "ROUTE" %in% reference_colname && aggregate_subject == "no" + if (atptref_exists || route_and_aggregate) { + match_cols <- setdiff(match_cols, c("start", "end")) + } + ##################################################### + + match_cols <- switch(aggregate_subject, + "yes" = { + list(setdiff(match_cols, "USUBJID")) + }, + "no" = { + if (!"USUBJID" %in% match_cols) { + stop("USUBJID must be included in match_cols when aggregate_subject is 'never'.") + } + list(match_cols) + }, + "if-needed" = { + match_cols <- list(match_cols) + if ("USUBJID" %in% match_cols) { + # Perform both individual & aggregated calculations, then eliminate duplicates + match_cols <- c(match_cols, list(setdiff(match_cols, "USUBJID"))) + } + match_cols + } + ) + + if (test_group == "(all other levels)") { + test_groups <- NULL + } else { + num_colname <- gsub("(.*): (.*)", "\\1", test_group) + num_value <- gsub("(.*): (.*)", "\\2", test_group) + test_groups <- data.frame( + matrix( + num_value, + nrow = 1, + ncol = length(num_colname), + dimnames = list(NULL, num_colname) + ) + ) + } + + reference_colname <- gsub("(.*): (.*)", "\\1", ref_group) + reference_value <- gsub("(.*): (.*)", "\\2", ref_group) + ref_groups <- data.frame( + matrix( + reference_value, + nrow = 1, + ncol = length(reference_colname), + dimnames = list(NULL, reference_colname) + ) + ) + + ratio_list <- lapply(seq_along(match_cols), function(ix) { + calculate_ratios( + data = res$result, + test_parameter = test_parameter, + ref_parameter = ref_parameter, + match_cols = match_cols[[ix]], + ref_groups = ref_groups, + test_groups = test_groups, + adjusting_factor = adjusting_factor, + custom_pptestcd = custom_pptestcd + ) + }) + all_ratios <- bind_rows(ratio_list) + + # Assuming there cannot be more than 1 reference + PPTESTCD combination for the same group... + # If aggregate_subject = 'if-needed', then this will remove cases when subject is not needed + all_ratios %>% + # Make sure there are no duplicate rows for: parameter, contrast_var, and match_cols + distinct( + across( + all_of(c("PPTESTCD", group_vars(res$data), "end")) + ), + .keep_all = TRUE + ) +} diff --git a/R/zzz.R b/R/zzz.R index 31b2752a9..9cf7c063d 100644 --- a/R/zzz.R +++ b/R/zzz.R @@ -113,6 +113,7 @@ "aucs", "aucs_extravascular", "aucs_intravascular", + "calculate_ratio_app", "color_var", "combn", "conv_factor", @@ -133,6 +134,7 @@ "id_list", "id_plot", "id_variable_col", + "impute", "install.packages", "interval_name", "interval_name_col", @@ -146,6 +148,7 @@ "is_extravascular", "is_metabolite", "is_one_dose", + "is_requested", "legend_group", "log10_CI", "log10_Mean", diff --git a/README.md b/README.md index 9601b03b9..a8df8986a 100644 --- a/README.md +++ b/README.md @@ -26,6 +26,7 @@ This application enables users to upload their datasets and perform Non-Compartm - **Visualize data and results** with interactive boxplots, summary statistic tables and scatter plots - **Produce PP and ADPP** dataset formats of the resulting parameters - **Save your analysis settings** and reupload them later to keep on analysing! +- **Reproduce your NCA outside of the app**, using the R script created ## Installation diff --git a/inst/WORDLIST b/inst/WORDLIST index 17b6350bb..a22754184 100644 --- a/inst/WORDLIST +++ b/inst/WORDLIST @@ -5,10 +5,14 @@ AEFRLT AFRLT ARRLT ATPTREF +AUCPEO +AUCPEP AUCinf AUClast AVAL AVALU +AdjustingFactor +AggregateSubject Analyte BLQ Buckeridge @@ -32,6 +36,8 @@ Kobana LAMZ LAMZLL LAMZNPT +LAMZSPN +Lineplot METABFL MRTMDO MRTMDP @@ -49,6 +55,7 @@ PKNCA PKNCAconc PKNCAdata PKNCAdose +PKNCAresult PKNCAresults PPORRES PPSTRES @@ -66,6 +73,8 @@ README RENALCL RRLTU RStudio +RefGroups +RefParameter Req Roadmap SBS @@ -77,6 +86,8 @@ TLGs TMAX TRT TRTRINT +TestGroups +TestParameter Tmax Tooltip UI @@ -139,6 +150,8 @@ roadmap rpptx ruleset rulesets +runnable +SBS signif src tibble @@ -150,6 +163,7 @@ tooltip tooltips ug unmapped +userData utilise visualizable yaml diff --git a/inst/shiny/functions/ratio_table.R b/inst/shiny/functions/ratio_table.R deleted file mode 100644 index 67b394462..000000000 --- a/inst/shiny/functions/ratio_table.R +++ /dev/null @@ -1,145 +0,0 @@ -#' Links the table ratio of the App with the ratio calculations via PKNCA results -#' -#' @param res A PKNCAresult object. -#' @param test_parameter Character. The PPTESTCD value to use as test (numerator). -#' @param ref_parameter Character. The PPTESTCD value to use as reference (denominator). -#' Defaults to test_parameter. -#' @param test_group Character. The test group (numerator). Default is "(all other levels)". -#' @param ref_group Character. The reference group (denominator). -#' @param aggregate_subject Character. Aggregation mode: "yes", "no", or "if-needed". -#' @param adjusting_factor Numeric that multiplies the calculated ratio. Default is 1. -#' @param custom_pptestcd Optional character. If provided, will be used as the PPTESTCD value. -#' @returns A data.frame with the calculated ratios for the specified settings. -calculate_ratio_app <- function( - res, - test_parameter, - ref_parameter = test_parameter, - test_group = "(all other levels)", - ref_group = "PARAM: Analyte01", - aggregate_subject = "no", - adjusting_factor = 1, - custom_pptestcd = NULL -) { - reference_colname <- gsub("(.*): (.*)", "\\1", ref_group) - match_cols <- setdiff(unique(c(dplyr::group_vars(res), "start", "end")), reference_colname) - - ########### This is very App specific ############### - if ("ATPTREF" %in% reference_colname) { - match_cols <- setdiff(match_cols, c("start", "end")) - } - if ("ROUTE" %in% reference_colname && aggregate_subject == "no") { - match_cols <- setdiff(match_cols, c("start", "end")) - } - ##################################################### - - if (aggregate_subject == "yes") { - match_cols <- list(setdiff(match_cols, "USUBJID")) - } else if (aggregate_subject == "no") { - if (!"USUBJID" %in% match_cols) { - stop("USUBJID must be included in match_cols when aggregate_subject is 'never'.") - } - match_cols <- list(match_cols) - } else if (aggregate_subject == "if-needed") { - if ("USUBJID" %in% match_cols) { - # Perform both individual & aggregated calculations, then eliminate duplicates - match_cols <- list(match_cols, setdiff(match_cols, "USUBJID")) - } - } - - if (test_group == "(all other levels)") { - test_groups <- NULL - } else { - num_colname <- gsub("(.*): (.*)", "\\1", test_group) - num_value <- gsub("(.*): (.*)", "\\2", test_group) - test_groups <- data.frame( - matrix( - num_value, - nrow = 1, - ncol = length(num_colname), - dimnames = list(NULL, num_colname) - ) - ) - } - - reference_colname <- gsub("(.*): (.*)", "\\1", ref_group) - reference_value <- gsub("(.*): (.*)", "\\2", ref_group) - ref_groups <- data.frame( - matrix( - reference_value, - nrow = 1, - ncol = length(reference_colname), - dimnames = list(NULL, reference_colname) - ) - ) - - - all_ratios <- data.frame() - - for (ix in seq_along(match_cols)) { - ratio_calculations <- calculate_ratios( - data = res$result, - test_parameter = test_parameter, - ref_parameter = ref_parameter, - match_cols = match_cols[[ix]], - ref_groups = ref_groups, - test_groups = test_groups, - adjusting_factor = adjusting_factor, - custom_pptestcd = custom_pptestcd - ) - all_ratios <- bind_rows(all_ratios, ratio_calculations) - } - - # Assuming there cannot be more than 1 reference + PPTESTCD combination for the same group... - # If aggregate_subject = 'if-needed', then this will remove cases when subject is not needed - all_ratios %>% - # Make sure there are no duplicate rows for: parameter, contrast_var, and match_cols - distinct(across( - all_of(c("PPTESTCD", group_vars(res$data), "end")) - ), - .keep_all = TRUE) -} - -#' Apply Ratio Calculations to PKNCAresult Object -#' -#' This function takes a PKNCAresult object and a data.frame specifying ratio calculations -#' -#' @param res A PKNCAresult object. -#' @param ratio_table Data.frame with columns: -#' TestParameter, RefParameter, Reference, Test, AggregateSubject, AdjustingFactor. -#' @returns The updated PKNCAresult object with added rows in the `result` data.frame. -#' @export -calculate_table_ratios_app <- function(res, ratio_table) { - # Make a list to save all results - ratio_results <- vector("list", nrow(ratio_table)) - - # Loop through each row of the ratio_table - for (i in seq_len(nrow(ratio_table))) { - ratio_results[[i]] <- calculate_ratio_app( - res = res, - test_parameter = ratio_table$TestParameter[i], - ref_parameter = ratio_table$RefParameter[i], - test_group = ratio_table$TestGroups[i], - ref_group = ratio_table$RefGroups[i], - aggregate_subject = ratio_table$AggregateSubject[i], - adjusting_factor = as.numeric(ratio_table$AdjustingFactor[i]), - custom_pptestcd = if (ratio_table$PPTESTCD[i] == "") NULL else ratio_table$PPTESTCD[i] - ) - - if (nrow(ratio_results[[i]]) == 0) { - warning( - "Ratio ", ratio_table$PPTESTCD[i], " not computed.", - "No comparable groups found between RefGroups", - " (", ratio_table$RefGroups[i], ")", - "and TestGroups", - " (", ratio_table$TestGroups[i], ")" - ) - } - } - if (!"PPANMETH" %in% names(res$result)) { - res$result$PPANMETH <- "" - } - - # Combine all results into the original PKNCAresult object - res$result <- do.call(bind_rows, c(list(res$result), ratio_results)) - res -} diff --git a/inst/shiny/modules/tab_data/data_filtering.R b/inst/shiny/modules/tab_data/data_filtering.R index c553ce2e6..81ac5ba1c 100644 --- a/inst/shiny/modules/tab_data/data_filtering.R +++ b/inst/shiny/modules/tab_data/data_filtering.R @@ -112,6 +112,9 @@ data_filtering_server <- function(id, raw_adnca_data) { paste0("Submitting the following filters:\n", .) %>% log_info() + # Save the filters object + session$userData$applied_filters <- applied_filters + # Filter and return data withCallingHandlers({ apply_filters(raw_adnca_data(), applied_filters) diff --git a/inst/shiny/modules/tab_data/data_mapping.R b/inst/shiny/modules/tab_data/data_mapping.R index caf8eaefa..5f6a7ee5c 100644 --- a/inst/shiny/modules/tab_data/data_mapping.R +++ b/inst/shiny/modules/tab_data/data_mapping.R @@ -220,6 +220,9 @@ data_mapping_server <- function(id, adnca_data, trigger) { # Subset the list with the final names mapping_list[names_to_keep] }) + observe({ + session$userData$mapping <- mapping() + }) mapped_data <- reactive({ req(adnca_data()) diff --git a/inst/shiny/modules/tab_data/data_upload.R b/inst/shiny/modules/tab_data/data_upload.R index ca13c9fb7..d8c0fb2f5 100644 --- a/inst/shiny/modules/tab_data/data_upload.R +++ b/inst/shiny/modules/tab_data/data_upload.R @@ -51,6 +51,13 @@ data_upload_server <- function(id) { }) datapath <- getOption("aNCA.datapath", NULL) + observe({ + if (!is.null(input$data_upload$datapath)) { + session$userData$data_path <- input$data_upload$datapath + } else { + session$userData$data_path <- system.file("shiny/data/example-ADNCA.csv", package = "aNCA") + } + }) raw_data <- ( reactive({ diff --git a/inst/shiny/modules/tab_nca.R b/inst/shiny/modules/tab_nca.R index fd50b43e0..ec4a00da8 100644 --- a/inst/shiny/modules/tab_nca.R +++ b/inst/shiny/modules/tab_nca.R @@ -86,6 +86,11 @@ tab_nca_server <- function(id, pknca_data, extra_group_vars) { slope_rules = slope_rules$manual_slopes ) # This will be saved in the results zip folder + # This will be saved in the results zip folder + session$userData$settings <- settings + session$userData$ratio_table <- ratio_table + session$userData$slope_rules <- slope_rules + reactable_server("manual_slopes", slope_rules$manual_slopes) # List all irrelevant warnings to suppres in the NCA calculation @@ -149,7 +154,9 @@ tab_nca_server <- function(id, pknca_data, extra_group_vars) { purrr::map(\(x) x$threshold) ) %>% # Add parameter ratio calculations - calculate_table_ratios_app(ratio_table = ratio_table()) + calculate_table_ratios(ratio_table = ratio_table()) %>% + # Keep only parameters requested by the user + remove_pp_not_requested() }, warning = function(w) { if (!grepl(paste(irrelevant_regex_warnings, collapse = "|"), @@ -170,33 +177,6 @@ tab_nca_server <- function(id, pknca_data, extra_group_vars) { log_success("NCA results calculated.") - params_requested <- c(setdiff(names(PKNCA::get.interval.cols()), c("start", "end")), - settings()$bioavailability) - # Reshape intervals, filter - params_not_requested <- res$data$intervals %>% - # add bioavailability if requested - mutate(!!!rlang::set_names(TRUE, settings()$bioavailability)) %>% - # pivot for requested params - pivot_longer( - cols = (any_of(params_requested)), - names_to = "PPTESTCD", - values_to = "is_requested" - ) %>% - # Translate terms - mutate(PPTESTCD = translate_terms(PPTESTCD, "PKNCA", "PPTESTCD")) %>% - # Group by all identifying cols EXCEPT the impute column and the value column - group_by(across(c(-impute, -is_requested))) %>% - # If all are FALSE, any(is_requested) will be FALSE. - summarise( - is_requested = any(is_requested), - .groups = "drop" - ) %>% - filter(!is_requested) - - # Filter for requested params based on intervals - res$result <- res$result %>% - anti_join(params_not_requested, by = intersect(names(.), names(params_not_requested))) - res }, error = function(e) { log_error("Error calculating NCA results:\n{conditionMessage(e)}") @@ -209,6 +189,11 @@ tab_nca_server <- function(id, pknca_data, extra_group_vars) { }) %>% bindEvent(input$run_nca) + observe({ + req(res_nca()) + session$userData$final_units <- res_nca()$data$units + }) + #' Show slopes results pivoted_slopes <- reactive({ req(res_nca()) diff --git a/inst/shiny/modules/tab_nca/nca_results.R b/inst/shiny/modules/tab_nca/nca_results.R index c5e0a7190..9e9eccb61 100644 --- a/inst/shiny/modules/tab_nca/nca_results.R +++ b/inst/shiny/modules/tab_nca/nca_results.R @@ -79,47 +79,15 @@ nca_results_server <- function(id, pknca_data, res_nca, settings, ratio_table, g results <- res_nca() # Transform results - final_results <- pivot_wider_pknca_results(results) - - # Join subject data to allow the user to group by it - conc_data_to_join <- res_nca()$data$conc$data %>% - select(any_of(c( - grouping_vars(), - unname(unlist(res_nca()$data$conc$columns$groups)), - "DOSEA", - "ATPTREF", - "ROUTE" - ))) - - final_results <- final_results %>% - inner_join(conc_data_to_join, by = intersect(names(.), names(conc_data_to_join))) %>% - distinct() %>% - mutate( - flagged = "NOT DONE" - ) - - # Add flaging column in the pivoted results - applied_flags <- purrr::keep(settings()$flags, function(x) x$is.checked) - flag_params <- names(settings()$flags) - flag_thr <- sapply(settings()$flags, FUN = function(x) x$threshold) - flag_rule_msgs <- paste0(flag_params, c(" < ", " < ", " > ", " > ", " < "), flag_thr) - flag_cols <- names(final_results)[formatters::var_labels(final_results) - %in% translate_terms(flag_params, "PPTESTCD", "PPTEST")] - - if (length(flag_params) > 0) { - final_results <- final_results %>% - rowwise() %>% - mutate( - flagged = case_when( - is.na(Exclude) ~ "ACCEPTED", - any(sapply( - flag_rule_msgs, function(msg) str_detect(Exclude, fixed(msg)) - )) ~ "FLAGGED", - TRUE ~ "MISSING" - ) - ) %>% - ungroup() - } + extra_vars_to_keep <- c(grouping_vars(), "DOSEA", "ATPTREF", "ROUTE") + session$userData$extra_vars_to_keep <- extra_vars_to_keep + + final_results <- pivot_wider_pknca_results( + results, + flag_rules = settings()$flags, + extra_vars_to_keep = extra_vars_to_keep + ) + final_results }) diff --git a/inst/shiny/modules/tab_nca/parameter_datasets.R b/inst/shiny/modules/tab_nca/parameter_datasets.R index 41d64806e..903fefb3d 100644 --- a/inst/shiny/modules/tab_nca/parameter_datasets.R +++ b/inst/shiny/modules/tab_nca/parameter_datasets.R @@ -11,24 +11,7 @@ parameter_datasets_server <- function(id, res_nca) { moduleServer(id, function(input, output, session) { CDISC <- reactive({ req(res_nca()) - - # Only select from results the requested parameters by the user - ############################################################################ - # TODO (Gerardo): Once PKNCA non covered parameters start being covered, - # this can be done instead using filter_requested = TRUE - res_nca_req <- res_nca() - params_not_requested <- res_nca_req$data$intervals %>% - select(any_of(setdiff(names(PKNCA::get.interval.cols()), c("start", "end")))) %>% - # For all logical columns, mutate FALSE to NA - mutate(across(where(is.logical), ~ ifelse(.x, TRUE, NA))) %>% - # Only select column that are only NA - select(where(~ all(is.na(.x)))) %>% - names() - res_nca_req$result <- res_nca_req$result %>% - filter(!PPTESTCD %in% translate_terms(params_not_requested, "PKNCA", "PPTESTCD")) - ############################################################################ - - export_cdisc(res_nca_req) + export_cdisc(res_nca()) }) reactable_server( diff --git a/inst/shiny/modules/tab_nca/setup.R b/inst/shiny/modules/tab_nca/setup.R index 9ce30f2f8..1bd32631d 100644 --- a/inst/shiny/modules/tab_nca/setup.R +++ b/inst/shiny/modules/tab_nca/setup.R @@ -111,12 +111,13 @@ setup_server <- function(id, data, adnca_data, extra_group_vars) { ) final_settings <- reactive({ - req(settings(), parameters_output$selections(), general_exclusions) - + req(settings(), parameters_output$selections()) current_settings <- settings() current_settings$general_exclusions <- general_exclusions - current_settings$parameter_selections <- parameters_output$selections() - + current_settings$parameters <- list( + selections = parameters_output$selections(), + types_df = parameters_output$types_df() + ) current_settings }) @@ -153,7 +154,6 @@ setup_server <- function(id, data, adnca_data, extra_group_vars) { adnca_data = processed_pknca_data, extra_group_vars = extra_group_vars ) - session$userData$ratio_table <- reactive(ratio_table()) # Automatically update the units table when settings are uploaded. observeEvent(settings_override(), { diff --git a/inst/shiny/modules/tab_nca/zip.R b/inst/shiny/modules/tab_nca/zip.R index b7c11ca08..4bddb572c 100644 --- a/inst/shiny/modules/tab_nca/zip.R +++ b/inst/shiny/modules/tab_nca/zip.R @@ -177,12 +177,34 @@ zip_server <- function(id, res_nca, settings, grouping_vars) { if ("settings_file" %in% input$res_tree) { setts_tmpdir <- file.path(output_tmpdir, "settings") dir.create(setts_tmpdir, recursive = TRUE) - settings_list <- session$userData$settings - setings_to_save <- list( - settings = settings_list$settings(), - slope_rules = settings_list$slope_rules() + settings_list <- session$userData$settings() + settings_to_save <- list( + settings = settings_list, + slope_rules = list( + manual_slopes = session$userData$slope_rules$manual_slopes(), + profiles_per_subject = session$userData$slope_rules$profiles_per_subject(), + slopes_groups = session$userData$slope_rules$slopes_groups() + ) + ) + saveRDS(settings_to_save, paste0(setts_tmpdir, "/settings.rds")) + } + + # Save input dataset used + data_tmpdir <- file.path(output_tmpdir, "data") + dir.create(data_tmpdir, recursive = TRUE) + data <- read_pk(session$userData$data_path) + saveRDS(data, paste0(data_tmpdir, "/data.rds")) + + # Save a code R script template for the session + if ("r_script" %in% input$res_tree) { + script_tmpdir <- file.path(output_tmpdir, "code") + dir.create(script_tmpdir, recursive = TRUE) + script_template_path <- "www/templates/script_template.R" + get_session_code( + template_path = script_template_path, + session = session, + output_path = paste0(script_tmpdir, "/session_code.R") ) - saveRDS(setings_to_save, paste0(setts_tmpdir, "/settings.rds")) } # Filter files by selected formats (for demonstration, not full implementation) @@ -194,7 +216,7 @@ zip_server <- function(id, res_nca, settings, grouping_vars) { if (length(table_formats) > 0) paste0("\\.", table_formats), if (length(plot_formats) > 0) paste0("\\.", plot_formats), if (length(slide_formats) > 0) paste0("results_slides\\.", slide_formats), - if ("r_script" %in% input$res_tree) "r_script\\.R", + if ("r_script" %in% input$res_tree) "session_code\\.R", if ("settings_file" %in% input$res_tree) "settings\\.rds" ), collapse = "|"), ")$" diff --git a/inst/shiny/www/templates/script_template.R b/inst/shiny/www/templates/script_template.R new file mode 100644 index 000000000..62fef40ec --- /dev/null +++ b/inst/shiny/www/templates/script_template.R @@ -0,0 +1,131 @@ +# Load the package (https://github.com/pharmaverse/aNCA) # +########################################################### +## Please, set your working directory to this file: +# setwd("path/to/this/file/script_template.R") + +if (!require("aNCA")) install.packages("aNCA") +library(aNCA) +library(dplyr) + +# Load raw data # +data_path <- "../data/data.rds" +adnca_data <- read_pk(data_path) + +## Preprocess data ######################################## +mapping <- session$userData$mapping +names(mapping) <- gsub("select_", "", names(mapping)) +applied_filters <- session$userData$applied_filters + +preprocessed_adnca <- adnca_data %>% + + # Filter the data + apply_filters(applied_filters) %>% + + # Map columns to their standards + apply_mapping( + mapping = mapping, + desired_order = c( + "STUDYID", "USUBJID", "PARAM", "PCSPEC", "ATPTREF", + "AVAL", "AVALU", "AFRLT", "ARRLT", "NRRLT", "NFRLT", + "RRLTU", "ROUTE", "DOSETRT", "DOSEA", "DOSEU", "ADOSEDUR", + "VOLUME", "VOLUMEU", "TRTRINT", "METABFL" + ), + silent = FALSE + ) %>% + + # Derive METABFL column using PARAM metabolites + create_metabfl(mapping$Metabolites) %>% + + # Make sure all variables are in its correct class + adjust_class_and_length(metadata_nca_variables) + +## Setup NCA settings in the PKNCA object ######################## +auc_data <- session$userData$settings$partial_aucs +units_table <- session$userData$final_units +parameters_selected_per_study <- session$userData$settings$parameters$selections +study_types_df <- session$userData$settings$parameters$types_df + +pknca_obj <- preprocessed_adnca %>% + + # Create from ADNCA the PKNCA object + PKNCA_create_data_object( + nca_exclude_reason_columns = c("DTYPE", mapping$NCAwXRS) + ) %>% + + # Setup basic settings + PKNCA_update_data_object( + method = session$userData$settings$method, + selected_analytes = session$userData$settings$analyte, + selected_profile = session$userData$settings$profile, + selected_pcspec = session$userData$settings$pcspec, + should_impute_c0 = session$userData$settings$data_imputation$impute_c0, + exclusion_list = session$userData$settings$general_exclusions$exclusion_list + ) %>% + + update_main_intervals( + auc_data = auc_data, + parameter_selections = parameters_selected_per_study, + study_types_df = study_types_df, + impute = session$userData$settings$data_imputation$impute_c0 + ) %>% + + # Define the desired units for the parameters (PPSTRESU) + { + pknca_obj <- . + if (!is.null(units_table)) { + pknca_obj[["units"]] <- units_table + } + pknca_obj + } + +## Run NCA calculations ######################################## +slope_rules <- list( + manual_slopes = session$userData$slope_rules$manual_slopes, + profiles_per_subject = session$userData$slope_rules$profiles_per_subject, + slopes_groups = session$userData$slope_rules$slopes_groups +) +flag_rules <- session$userData$settings$flags +ratio_table <- session$userData$ratio_table +extra_vars_to_keep <- session$userData$extra_vars_to_keep + +pknca_res <- pknca_obj %>% + + # Apply half-life adjustments + filter_slopes( + slope_rules$manual_slopes, + slope_rules$profiles_per_subject, + slope_rules$slopes_groups, + check_reasons = TRUE + ) %>% + + # Run pk.nca and join subject and dose information to the results + PKNCA_calculate_nca() %>% + + # Add bioavailability results if requested + add_f_to_pknca_results(session$userData$settings$bioavailability) %>% + + # Apply standard CDISC names + mutate(PPTESTCD = translate_terms(PPTESTCD, "PKNCA", "PPTESTCD")) %>% + + # Flag relevant parameters based on AUCPEO, AUCPEP & lambda span + PKNCA_hl_rules_exclusion( + rules = flag_rules %>% + purrr::keep(\(x) x$is.checked) %>% + purrr::map(\(x) x$threshold) + ) %>% + + # Derive secondary parameters (ratio parameters) + calculate_table_ratios(ratio_table) %>% + + # Filter only parameters that have been requested + remove_pp_not_requested() + +## Obtain PP, ADPP, ADNCA & Pivoted results ######################### +cdisc_datasets <- pknca_res %>% + export_cdisc() + +pivoted_results <- pivot_wider_pknca_results( + myres = pknca_res, + flag_rules = flag_rules, + extra_vars_to_keep = extra_vars_to_keep +) diff --git a/man/calculate_ratio_app.Rd b/man/calculate_ratio_app.Rd new file mode 100644 index 000000000..55322344e --- /dev/null +++ b/man/calculate_ratio_app.Rd @@ -0,0 +1,41 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/ratio_calculations.R +\name{calculate_ratio_app} +\alias{calculate_ratio_app} +\title{Links the table ratio of the App with the ratio calculations via PKNCA results} +\usage{ +calculate_ratio_app( + res, + test_parameter, + ref_parameter = test_parameter, + test_group = "(all other levels)", + ref_group = "PARAM: Analyte01", + aggregate_subject = "no", + adjusting_factor = 1, + custom_pptestcd = NULL +) +} +\arguments{ +\item{res}{A PKNCAresult object.} + +\item{test_parameter}{Character. The PPTESTCD value to use as test (numerator).} + +\item{ref_parameter}{Character. The PPTESTCD value to use as reference (denominator). +Defaults to test_parameter.} + +\item{test_group}{Character. The test group (numerator). Default is "(all other levels)".} + +\item{ref_group}{Character. The reference group (denominator).} + +\item{aggregate_subject}{Character. Aggregation mode: "yes", "no", or "if-needed".} + +\item{adjusting_factor}{Numeric that multiplies the calculated ratio. Default is 1.} + +\item{custom_pptestcd}{Optional character. If provided, will be used as the PPTESTCD value.} +} +\value{ +A data.frame with the calculated ratios for the specified settings. +} +\description{ +Links the table ratio of the App with the ratio calculations via PKNCA results +} diff --git a/man/calculate_table_ratios.Rd b/man/calculate_table_ratios.Rd new file mode 100644 index 000000000..cd2173407 --- /dev/null +++ b/man/calculate_table_ratios.Rd @@ -0,0 +1,21 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/ratio_calculations.R +\name{calculate_table_ratios} +\alias{calculate_table_ratios} +\title{Apply Ratio Calculations to PKNCAresult Object} +\usage{ +calculate_table_ratios(res, ratio_table) +} +\arguments{ +\item{res}{A PKNCAresult object.} + +\item{ratio_table}{Data.frame with columns: +TestParameter, RefParameter, Reference, Test, AggregateSubject, +AdjustingFactor, TestGroups, RefGroups, PPTESTCD.} +} +\value{ +The updated PKNCAresult object with added rows in the \code{result} data.frame. +} +\description{ +This function takes a PKNCAresult object and a data.frame specifying ratio calculations. +} diff --git a/man/clean_deparse.Rd b/man/clean_deparse.Rd new file mode 100644 index 000000000..835abff28 --- /dev/null +++ b/man/clean_deparse.Rd @@ -0,0 +1,30 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/get_session_code.R +\name{clean_deparse} +\alias{clean_deparse} +\title{Convert R objects into reproducible R code strings (internal)} +\usage{ +clean_deparse(obj, indent = 0, max_per_line = 10, min_to_rep = 3) +} +\arguments{ +\item{obj}{An R object to convert to a string of R code.} + +\item{indent}{Integer indentation level for multi-line outputs.} + +\item{max_per_line}{Maximum number of elements to include per line for +long vectors/lists.} + +\item{min_to_rep}{Minimum number of repeated elements to use \code{rep()} for +long vectors/lists.} +} +\value{ +A single string containing R code that, when evaluated, will +reconstruct \code{obj} (or a close approximation for complex types). +} +\description{ +This internal S3 generic converts common R objects (data frames, lists, +atomic vectors, etc.) into character strings containing R code that will +reconstruct the object. It is used by the app script generator to +serialize \code{session$userData} values into a runnable R script. +} +\keyword{internal} diff --git a/man/get_session_code.Rd b/man/get_session_code.Rd new file mode 100644 index 000000000..cb339ee55 --- /dev/null +++ b/man/get_session_code.Rd @@ -0,0 +1,21 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/get_session_code.R +\name{get_session_code} +\alias{get_session_code} +\title{Generate a session script code in R that can replicate the App outputs} +\usage{ +get_session_code(template_path, session, output_path) +} +\arguments{ +\item{template_path}{Path to the R script template (e.g., script_template.R)} + +\item{session}{The session object containing userData, etc.} + +\item{output_path}{Path to write the resulting script file (e.g., "output_script.R")} +} +\value{ +The output_path (invisibly) +} +\description{ +Generate a session script code in R that can replicate the App outputs +} diff --git a/man/pivot_wider_pknca_results.Rd b/man/pivot_wider_pknca_results.Rd index 23cdd77f8..da37f2f27 100644 --- a/man/pivot_wider_pknca_results.Rd +++ b/man/pivot_wider_pknca_results.Rd @@ -4,7 +4,7 @@ \alias{pivot_wider_pknca_results} \title{Reshape PKNCA Results} \usage{ -pivot_wider_pknca_results(myres) +pivot_wider_pknca_results(myres, flag_rules = NULL, extra_vars_to_keep = NULL) } \arguments{ \item{myres}{The output of PKNCA::pk.nca. It makes some additional assumptions: @@ -18,6 +18,15 @@ of the dose, relative to the last reference dose. \item Temporarily: CDISC denomination of PK parameters related to half-life: "LAMZNPT", "LAMZLL", "LAMZ" Used to derive \code{LAMZNPT} and \code{LAMZMTD}. }} + +\item{flag_rules}{A named list of flagging rules to be applied to the results. Each rule +should be a list with two elements: \code{is.checked} (logical) indicating whether the rule +should be applied, and \code{threshold} (numeric) specifying the threshold value for flagging. +The name of each rule should correspond to a parameter in the results data.frame as a PPTESTCD +(e.g., "R2ADJ", "AUCPEO", "AUCPEP", "LAMZSPN").} + +\item{extra_vars_to_keep}{Optional character vector of variable names to join from the +concentration data to the output. Default is NULL.} } \value{ A data frame which provides an easy overview on the results from the NCA diff --git a/man/remove_pp_not_requested.Rd b/man/remove_pp_not_requested.Rd new file mode 100644 index 000000000..36d3c721a --- /dev/null +++ b/man/remove_pp_not_requested.Rd @@ -0,0 +1,18 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/PKNCA.R +\name{remove_pp_not_requested} +\alias{remove_pp_not_requested} +\title{Filter Out Parameters Not Requested in PKNCA Results (Pivot Version)} +\usage{ +remove_pp_not_requested(pknca_res) +} +\arguments{ +\item{pknca_res}{A PKNCA results object containing at least $data$intervals and $result.} +} +\value{ +The PKNCA results object with non requested parameters removed from $result. +} +\description{ +This function removes parameters from the PKNCA results that were not requested by the user, +using a pivoted approach that also handles bioavailability settings. +} diff --git a/tests/testthat/test-get_session_code.R b/tests/testthat/test-get_session_code.R new file mode 100644 index 000000000..773decb54 --- /dev/null +++ b/tests/testthat/test-get_session_code.R @@ -0,0 +1,169 @@ +# Tests for clean_deparse function +describe("clean_deparse()", { + it("formats character single and vector correctly", { + expect_equal(clean_deparse("hello"), '"hello"') + expect_equal(clean_deparse(c("a", "b")), 'c("a", "b")') + }) + + it("formats numeric and integer values correctly", { + expect_equal(clean_deparse(1.23), "1.23") + expect_equal(clean_deparse(c(1, 2)), "c(1, 2)") + expect_equal(clean_deparse(as.integer(3)), "3") + expect_equal(clean_deparse(as.integer(c(4L, 5L))), "c(4, 5)") + }) + + it("formats logical values correctly", { + expect_equal(clean_deparse(TRUE), "TRUE") + expect_equal(clean_deparse(c(TRUE, FALSE)), "c(TRUE, FALSE)") + expect_equal(clean_deparse(logical()), "logical()") + }) + + it("formats named lists correctly", { + l <- list(a = 1, b = "x") + exp_named <- "list(\n a = 1,\n b = \"x\"\n)" + expect_equal(clean_deparse(l), exp_named) + }) + + it("formats named lists with non-syntactic names correctly", { + l <- list("first item" = 1, "second-item" = "x") + exp_named <- "list(\n \"first item\" = 1,\n \"second-item\" = \"x\"\n)" + expect_equal(clean_deparse(l), exp_named) + }) + + it("renders data.frame as data.frame(...) with per-column vectors", { + df <- data.frame(x = c(1, 2), y = c("a", "b"), stringsAsFactors = FALSE) + exp_df <- paste0( + "data.frame(\n", + " x = c(1, 2),\n", + " y = c(\"a\", \"b\")\n", + ")" + ) + expect_equal(clean_deparse(df), exp_df) + }) + + it("renders tbl_df as data.frame(...)", { + df <- dplyr::tibble(x = c(1, 2), y = c("a", "b")) + exp_df <- paste0( + "data.frame(\n", + " x = c(1, 2),\n", + " y = c(\"a\", \"b\")\n", + ")" + ) + expect_equal(clean_deparse(df), exp_df) + }) + + it("renders a NULL object correctly", { + expect_equal(clean_deparse(NULL), "NULL") + }) + + it("renders empty classes correctly", { + expect_equal(clean_deparse(list()), "list()") + expect_equal(clean_deparse(data.frame()), "data.frame()") + expect_equal(clean_deparse(character(0)), "character()") + expect_equal(clean_deparse(numeric(0)), "numeric()") + }) + + it("renders data.frame with long columns using newlines and indentation", { + long_vec <- as.character(1:25) + df <- data.frame(x = 1:25, y = long_vec, stringsAsFactors = FALSE) + out <- clean_deparse(df) + expect_match(out, "c\\(\n") # Should use newlines for long columns + expect_match(out, " 1, 2, 3") # Indentation present + expect_match(out, "x = c\\(") # Column x uses c( ... ) + expect_match(out, "y = c\\(") # Column y uses c( ... ) + }) + + it("respects max_per_line for character vectors", { + v <- as.character(1:6) + out <- clean_deparse(v, max_per_line = 2) + exp_out <- "c(\n \"1\", \"2\",\n \"3\", \"4\",\n \"5\", \"6\"\n)" + expect_equal(out, exp_out) + }) + + it("respects max_per_line for numeric vectors", { + v <- 1:6 + out <- clean_deparse(v, max_per_line = 2) + exp_out <- "c(\n 1, 2,\n 3, 4,\n 5, 6\n)" + expect_equal(out, exp_out) + }) + + it("respects max_per_line for lists of vectors", { + l <- list(a = 1:4, b = letters[1:4]) + out <- clean_deparse(l, max_per_line = 2) + exp_out <- paste0( + "list(\n", + " a = c(\n", + " 1, 2,\n", + " 3, 4\n", + " ),\n", + " b = c(\n", + ' "a", "b",\n', + ' "c", "d"\n', + " )\n", + ")" + ) + expect_equal(out, exp_out) + }) + + it("respects max_per_line for data.frames", { + df <- data.frame(x = 1:4, y = letters[1:4], stringsAsFactors = FALSE) + out <- clean_deparse(df, max_per_line = 2) + exp_out <- paste0( + "data.frame(\n", + " x = c(\n", + " 1, 2,\n", + " 3, 4\n", + " ),\n", + " y = c(\n", + ' "a", "b",\n', + ' "c", "d"\n', + " )\n", + ")" + ) + expect_equal(out, exp_out) + }) + + it("uses rep(...) when values are repeated at least min_to_rep times", { + # Test character + char_vec <- c(rep("apple", 5), "banana", "cherry", rep("date", 3)) + out_char <- clean_deparse.character(char_vec, max_per_line = 3, min_to_rep = 2) + exp_out_char <- paste0( + "c(\n", + " rep(\"apple\", 5), \"banana\", \"cherry\",\n", + " rep(\"date\", 3)\n", + ")" + ) + expect_equal(out_char, exp_out_char) + + # Test numeric + vec <- c(rep(5, 10), 6, 7, rep(8, 5)) + out_vec <- clean_deparse(vec, max_per_line = 3, min_to_rep = 2) + exp_out_vec <- paste0( + "c(\n", + " rep(5, 10), 6, 7,\n", + " rep(8, 5)\n", + ")" + ) + expect_equal(out_vec, exp_out_vec) + + # Test min_to_rep greater than any repetition + vec <- c(1, rep(2, 2), rep(3, 3), rep(4, 4)) + + out_no_rep <- clean_deparse(vec, max_per_line = 10, min_to_rep = Inf) + out_1_to_rep <- clean_deparse(vec, max_per_line = 10, min_to_rep = 1) + out_2_to_rep <- clean_deparse(vec, max_per_line = 10, min_to_rep = 2) + out_3_to_rep <- clean_deparse(vec, max_per_line = 10, min_to_rep = 3) + out_4_to_rep <- clean_deparse(vec, max_per_line = 10, min_to_rep = 4) + + exp_out_no_rep <- "c(1, 2, 2, 3, 3, 3, 4, 4, 4, 4)" + exp_out_1_to_rep <- "c(rep(1, 1), rep(2, 2), rep(3, 3), rep(4, 4))" + exp_out_2_to_rep <- "c(1, rep(2, 2), rep(3, 3), rep(4, 4))" + exp_out_3_to_rep <- "c(1, 2, 2, rep(3, 3), rep(4, 4))" + exp_out_4_to_rep <- "c(1, 2, 2, 3, 3, 3, rep(4, 4))" + + expect_equal(out_no_rep, exp_out_no_rep) + expect_equal(out_2_to_rep, exp_out_2_to_rep) + expect_equal(out_3_to_rep, exp_out_3_to_rep) + expect_equal(out_4_to_rep, exp_out_4_to_rep) + }) +}) diff --git a/tests/testthat/test-pivot_wider_pknca_results.R b/tests/testthat/test-pivot_wider_pknca_results.R index 519bf18c5..fbdcc5ff8 100644 --- a/tests/testthat/test-pivot_wider_pknca_results.R +++ b/tests/testthat/test-pivot_wider_pknca_results.R @@ -207,4 +207,55 @@ describe("pivot_wider_pknca_results", { expect_false("PPANMETH" %in% result) }) + + it("includes the flagged column and the flag rule columns when flag_rules are provided", { + + # Prepare a PKNCA results object with the exclusions to flag + flag_rules <- list( + R2ADJ = list(is.checked = TRUE, threshold = 0.99), + R2 = list(is.checked = TRUE, threshold = 0.99) + ) + flag_rules_pknca <- flag_rules %>% + purrr::keep(\(x) x$is.checked) %>% + purrr::map(\(x) x$threshold) + pknca_res <- PKNCA_hl_rules_exclusion(res = pknca_res, rules = flag_rules_pknca) + + # Produce the output to be tested + piv_result <- pivot_wider_pknca_results(pknca_res, flag_rules = flag_rules) + + # Missing results produce "MISSING" flag + na_result <- piv_result %>% + filter(is.na(R2) | is.na(R2ADJ)) %>% + + # TODO (Gerardo): Exclude test on SUBJ 4 because + # is a weird case scenario that PKNCA does not detect + # It is a straight line, R2 = NA, but PKNCA does not flag exclude + filter(USUBJID != 4) + + expect_equal(unique(na_result$flagged), "MISSING") + + # Invalid rules produce "FLAGGED" flag + flagged_result <- piv_result %>% + filter(!is.na(R2) & !is.na(R2ADJ)) %>% + filter(R2 < flag_rules$R2$threshold | R2ADJ < flag_rules$R2ADJ$threshold) + expect_equal(unique(flagged_result$flagged), "FLAGGED") + + # Passed rules produce "ACCEPTED" flag + accepted_result <- piv_result %>% + filter(!is.na(R2) & !is.na(R2ADJ)) %>% + filter(R2 >= flag_rules$R2$threshold & R2ADJ >= flag_rules$R2ADJ$threshold) + expect_equal(unique(accepted_result$flagged), "ACCEPTED") + }) + + it("includes extra_vars_to_keep columns when provided", { + pknca_res <- FIXTURE_PKNCA_RES + extra_vars <- c("ROUTE", "DOSEA", "ATPTREF") + pivoted_res <- pivot_wider_pknca_results(pknca_res, extra_vars_to_keep = extra_vars) + + # All requested extra_vars should be present in the output (if present in conc data) + present_vars <- intersect(extra_vars, names(pknca_res$data$conc$data)) + + # Check all extra_vars present are added in the pivoted result + expect_true(all(present_vars %in% names(pivoted_res))) + }) })