diff --git a/NAMESPACE b/NAMESPACE
index ba6100180..6a67f4d6e 100644
--- a/NAMESPACE
+++ b/NAMESPACE
@@ -24,7 +24,6 @@ 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)
export(create_start_impute)
@@ -32,7 +31,6 @@ export(detect_study_types)
export(dose_profile_duplicates)
export(export_cdisc)
export(filter_breaks)
-export(filter_slopes)
export(flexible_violinboxplot)
export(format_pkncaconc_data)
export(format_pkncadata_intervals)
@@ -51,7 +49,6 @@ export(get_session_code)
export(interval_add_impute)
export(interval_remove_impute)
export(l_pkcl01)
-export(lambda_slope_plot)
export(multiple_matrix_ratios)
export(parse_annotation)
export(pivot_wider_pknca_results)
@@ -79,6 +76,7 @@ import(rlistings)
import(tidyr)
importFrom(PKNCA,exclude)
importFrom(PKNCA,pk.calc.c0)
+importFrom(PKNCA,pk.nca)
importFrom(dplyr,"%>%")
importFrom(dplyr,`%>%`)
importFrom(dplyr,across)
@@ -92,6 +90,7 @@ importFrom(dplyr,distinct)
importFrom(dplyr,everything)
importFrom(dplyr,filter)
importFrom(dplyr,group_by)
+importFrom(dplyr,group_split)
importFrom(dplyr,if_else)
importFrom(dplyr,inner_join)
importFrom(dplyr,left_join)
@@ -107,10 +106,17 @@ importFrom(dplyr,where)
importFrom(flextable,flextable)
importFrom(formatters,var_labels)
importFrom(ggplot2,aes)
+importFrom(ggplot2,facet_wrap)
+importFrom(ggplot2,geom_point)
+importFrom(ggplot2,ggplot)
importFrom(ggplot2,ggplot_build)
importFrom(ggplot2,ggplot_gtable)
importFrom(ggplot2,labs)
+importFrom(ggplot2,scale_alpha_manual)
+importFrom(ggplot2,scale_colour_manual)
+importFrom(ggplot2,scale_shape_manual)
importFrom(ggplot2,scale_x_continuous)
+importFrom(ggplot2,theme_bw)
importFrom(grid,convertUnit)
importFrom(magrittr,`%>%`)
importFrom(methods,is)
@@ -124,23 +130,24 @@ importFrom(officer,ph_location_type)
importFrom(officer,ph_slidelink)
importFrom(officer,ph_with)
importFrom(officer,read_pptx)
+importFrom(plotly,add_lines)
importFrom(plotly,add_trace)
-importFrom(plotly,config)
importFrom(plotly,ggplotly)
importFrom(plotly,layout)
importFrom(plotly,plot_ly)
-importFrom(plotly,style)
+importFrom(plotly,plotly_build)
importFrom(purrr,imap)
importFrom(purrr,pmap)
importFrom(purrr,pmap_chr)
importFrom(purrr,reduce)
importFrom(rlang,expr)
-importFrom(rlang,set_names)
importFrom(rlang,sym)
importFrom(rlang,syms)
importFrom(stats,as.formula)
+importFrom(stats,lm)
importFrom(stats,median)
importFrom(stats,na.omit)
+importFrom(stats,predict)
importFrom(stats,sd)
importFrom(stats,setNames)
importFrom(stringr,fixed)
diff --git a/R/PKNCA.R b/R/PKNCA.R
index 280250d2d..d299c1358 100644
--- a/R/PKNCA.R
+++ b/R/PKNCA.R
@@ -117,7 +117,7 @@ PKNCA_create_data_object <- function(adnca_data, nca_exclude_reason_columns = NU
# Set default settings
df_conc$is.excluded.hl <- FALSE
df_conc$is.included.hl <- FALSE
- df_conc$REASON <- NA
+ df_conc$REASON <- ""
df_conc$exclude_half.life <- FALSE
# Create PKNCA conc object
@@ -198,6 +198,8 @@ PKNCA_create_data_object <- function(adnca_data, nca_exclude_reason_columns = NU
#'
#' Step 5: Impute start values if requested
#'
+#' Step 6: Indicate points excluded / selected manually for half-life
+#'
#' Note*: The function assumes that the `adnca_data` object has been
#' created using the `PKNCA_create_data_object()` function.
#'
@@ -206,6 +208,9 @@ PKNCA_create_data_object <- function(adnca_data, nca_exclude_reason_columns = NU
#' @param selected_analytes User selected analytes
#' @param selected_profile User selected dose numbers/profiles
#' @param selected_pcspec User selected specimen
+#' @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 exclusion_list List of exclusion reasons and row indices to apply to the
#' concentration data. Each item in the list should have:
@@ -229,8 +234,10 @@ PKNCA_update_data_object <- function( # nolint: object_name_linter
selected_profile,
selected_pcspec,
should_impute_c0 = TRUE,
+ hl_adj_rules = NULL,
exclusion_list = NULL,
keep_interval_cols = NULL) {
+
data <- adnca_data
analyte_column <- data$conc$columns$groups$group_analyte
unique_analytes <- unique(data$conc$data[[analyte_column]])
@@ -274,6 +281,10 @@ PKNCA_update_data_object <- function( # nolint: object_name_linter
PCSPEC %in% selected_pcspec
)
+ # Update concentration data to indicate points excluded / selected manually for half-life
+ if (!is.null(hl_adj_rules)) {
+ data <- update_pknca_with_rules(data, hl_adj_rules)
+ }
data
}
@@ -718,6 +729,53 @@ PKNCA_hl_rules_exclusion <- function(res, rules) { # nolint
res
}
+
+#' Checks Before Running NCA
+#'
+#' This function checks that:
+#' 1) exclusions_have_reasons: all manually excluded half-life points in the concentration data
+#' have a non-empty reason provided. If any exclusions are missing a reason, it stops with an error
+#' and prints the affected rows (group columns and time column).
+#'
+#' @param processed_pknca_data A processed PKNCA data object.
+#' @param exclusions_have_reasons Logical; Check that all exclusions have a reason (default: TRUE).
+#'
+#' @return The processed_pknca_data object (input), if checks are successful.
+#'
+#' @details
+#' - If any excluded half-life points are missing a reason, an error is thrown.
+#' - If no exclusions or all have reasons, the function returns the input object.
+#' - Used to enforce good practice/documentation before NCA calculation.
+#'
+#' @examples
+#' # Suppose processed_pknca_data is a valid PKNCA data object
+#' # check_valid_pknca_data(processed_pknca_data)
+check_valid_pknca_data <- function(processed_pknca_data, exclusions_have_reasons = TRUE) {
+ if (exclusions_have_reasons) {
+ excl_hl_col <- processed_pknca_data$conc$columns$exclude_half.life
+
+ if (!is.null(excl_hl_col)) {
+ data_conc <- processed_pknca_data$conc$data
+ conc_groups <- group_vars(processed_pknca_data$conc)
+ time_col <- processed_pknca_data$conc$columns$time
+
+ missing_reasons <- data_conc[[excl_hl_col]] & nchar(data_conc[["REASON"]]) == 0
+ missing_reasons_rows <- data_conc[missing_reasons, ] %>%
+ select(any_of(c(conc_groups, time_col)))
+
+ if (nrow(missing_reasons_rows) > 0) {
+ stop(
+ "No reason provided for the following half-life exclusions:\n",
+ "\n",
+ paste(capture.output(print(missing_reasons_rows)), collapse = "\n"),
+ "\n",
+ "Please go to `Slope Selection` table and include it"
+ )
+ }
+ }
+ }
+ processed_pknca_data
+}
#' 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,
diff --git a/R/g_pkcg.R b/R/g_pkcg.R
index 39a3944d7..81961d0c0 100644
--- a/R/g_pkcg.R
+++ b/R/g_pkcg.R
@@ -49,6 +49,7 @@ g_pkcg01_log <- function(data, ...) {
#' @importFrom ggplot2 aes scale_x_continuous labs
#' @importFrom tern g_ipp
#' @importFrom stats setNames
+#' @importFrom plotly ggplotly layout
#'
#' @examples
#' adnca <- read.csv(system.file("shiny/data/example-ADNCA.csv", package = "aNCA"))
@@ -56,7 +57,7 @@ g_pkcg01_log <- function(data, ...) {
#' attr(adnca[["AFRLT"]], "label") <- "Actual time from first dose"
#' attr(adnca[["AVAL"]], "label") <- "Analysis val"
#'
-#' plots_lin <- pkcg01(adnca = adnca, xmax = 1)
+#' plots_lin <- pkcg01(adnca = adnca, xmax = 1, scale = "LIN")
#'
#' @export
#' @author Gerardo Rodriguez
diff --git a/R/get_halflife_plots.R b/R/get_halflife_plots.R
new file mode 100644
index 000000000..f7e55a090
--- /dev/null
+++ b/R/get_halflife_plots.R
@@ -0,0 +1,278 @@
+#' Create a Plotly Half-life Plot
+#'
+#' Generates a plotly plot for NCA half-life visualization, with a fit line and scatter points.
+#'
+#' @param pknca_data PKNCA data object
+#' @param add_annotations Logical, whether to add the subtitle annotation
+#' @return A list with plotly objects and data
+#' @importFrom dplyr filter select mutate group_by ungroup group_split %>% any_of
+#' @importFrom stats lm predict as.formula
+#' @importFrom plotly plot_ly add_lines layout add_trace plotly_build
+#' @importFrom PKNCA pk.nca
+get_halflife_plots <- function(pknca_data, add_annotations = TRUE) {
+
+ # 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
+
+ # 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))
+ pknca_data$intervals <- pknca_data$intervals %>%
+ filter(type_interval == "main", half.life) %>%
+ unique()
+ 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
+ }
+ }
+
+ # Prepare an object with all plot information
+ wide_output <- o_nca
+ 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")
+ ) %>%
+ 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()
+
+ d_conc_with_res <- merge(
+ pknca_data$conc$data %>%
+ select(
+ !!!syms(c(group_vars(pknca_data), time_col, conc_col,
+ timeu_col, concu_col, exclude_hl_col, "ROWID"))
+ ),
+ wide_output,
+ all.x = TRUE,
+ by = c(group_vars(pknca_data))
+ ) %>%
+ dplyr::filter(.[[time_col]] >= start & .[[time_col]] <= end)
+
+ # Mark points used in half-life calculation
+ info_per_plot_list <- d_conc_with_res %>%
+ # Indicate plot details
+ dplyr::mutate(
+ subtitle = ifelse(
+ is.na(lambda.z),
+ exclude,
+ paste0(
+ "R2adj = ",
+ signif(adj.r.squared, 2),
+ " ",
+ "span ratio = ",
+ signif(span.ratio, 2)
+ )
+ ),
+ xlab = ifelse(
+ !is.null(timeu_col),
+ paste0(time_col, " (", unique(.[[timeu_col]]), ")"),
+ time_col
+ ),
+ ylab = ifelse(
+ !is.null(concu_col),
+ paste0(conc_col, " (", unique(.[[concu_col]]), ")"),
+ conc_col
+ )
+ ) %>%
+ # Mark points used in half-life calculation
+ mutate(
+ lambda.z.time.first = lambda.z.time.first + start,
+ lambda.z.time.last = lambda.z.time.last + start,
+ tlast = tlast + start,
+ is_halflife_used = .[[time_col]] >= lambda.z.time.first &
+ .[[time_col]] <= lambda.z.time.last &
+ !.[[exclude_hl_col]]
+ ) %>%
+ group_by(!!!syms(c(group_vars(pknca_data), "start", "end"))) %>%
+ mutate(
+ is_halflife_used = if (any(is.na(lambda.z.time.first))) {
+ NA
+ } else {
+ is_halflife_used
+ }
+ ) %>%
+ ungroup() %>%
+ # Disconsider BLQ points at the end (never used for half-life)
+ 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 = ifelse(is.na(is_halflife_used), "black",
+ ifelse(is_halflife_used, "green", "red")),
+ symbol = ifelse(.[[exclude_hl_col]], "x", "circle")
+ ) %>%
+ 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(!is.na(df$is_halflife_used))) {
+ df_fit <- df[df$is_halflife_used, ]
+ fit <- stats::lm(as.formula(paste0("log10(", conc_col, ") ~ ", time_col)), df_fit)
+ fit_line_data <- data.frame(x = c(df$lambda.z.time.first[1], df$tlast[1]))
+ colnames(fit_line_data) <- time_col
+ fit_line_data$y <- stats::predict(fit, fit_line_data)
+ } else {
+ fit_line_data <- data.frame(
+ x = c(df$start[1], df$start[1]),
+ y = c(0, 0)
+ )
+ 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(
+ paste0(
+ plotid_vars, "=", df[1, plotid_vars, drop = FALSE],
+ collapse = "_"
+ )
+ )
+
+ # Create the plot
+ plot_list[[plotid]] <- get_halflife_plots_single(
+ fit_line_data = fit_line_data,
+ plot_data = df,
+ time_col = time_col,
+ conc_col = conc_col,
+ title = paste0(
+ paste0(group_vars(pknca_data), ": "),
+ df[1, group_vars(pknca_data), drop = FALSE],
+ collapse = ", "
+ ),
+ xlab = df$xlab[1],
+ ylab = df$ylab[1],
+ subtitle = df$subtitle[1],
+ color = df$color,
+ symbol = df$symbol,
+ group_vars = group_vars(pknca_data),
+ add_annotations = add_annotations
+ )
+ data_list[[plotid]] <- df
+ }
+ list(plots = plot_list, data = data_list)
+}
+
+#' Internal helper for plotting a single half-life plot
+#'
+#' Generates a single plotly for NCA half-life visualization, with a fit line and scatter points.
+#'
+#' @keywords internal
+#' @param fit_line_data Data frame for the fit line (must have columns for time and y)
+#' @param plot_data Data frame for the scatter points
+#' @param time_col Name of the time column (string)
+#' @param conc_col Name of the concentration column (string)
+#' @param title Plot title
+#' @param xlab X axis label
+#' @param ylab Y axis label
+#' @param subtitle Subtitle/annotation (HTML allowed)
+#' @param color Vector of colors for points (same length as plot_data)
+#' @param symbol Vector of marker symbols for points (same length as plot_data)
+#' @param group_vars Character vector of grouping variable names (for `customdata`)
+#' @param add_annotations Logical, whether to add the subtitle annotation
+#' @param text Optional vector of hover text for points (same length as plot_data)
+#' @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
+) {
+ if (is.null(text)) {
+ text <- paste0(
+ "Data Point: ", seq_len(nrow(plot_data)), "\n(",
+ plot_data[[time_col]], ", ", signif(plot_data[[conc_col]], 3), ")"
+ )
+ }
+ plotly::plot_ly() %>%
+ plotly::add_lines(
+ data = fit_line_data,
+ x = ~get(time_col),
+ y = ~10^y,
+ line = list(color = "green", width = 2),
+ name = "Fit",
+ inherit = FALSE,
+ showlegend = TRUE
+ ) %>%
+ plotly::layout(
+ title = title,
+ xaxis = list(
+ title = xlab,
+ linecolor = "black",
+ gridcolor = "white",
+ zeroline = FALSE
+ ),
+ yaxis = list(
+ title = ylab,
+ type = "log",
+ tickformat = "f",
+ linecolor = "black",
+ gridcolor = "white",
+ zeroline = FALSE
+ ),
+ annotations = list(
+ text = subtitle,
+ showarrow = FALSE,
+ xref = "paper",
+ yref = "paper",
+ y = 1
+ )
+ ) %>%
+ plotly::add_trace(
+ data = plot_data,
+ x = ~plot_data[[time_col]],
+ y = ~plot_data[[conc_col]],
+ text = text,
+ hoverinfo = "text",
+ showlegend = FALSE,
+ type = "scatter",
+ mode = "markers",
+ marker = list(
+ color = color,
+ size = 15,
+ symbol = symbol
+ ),
+ customdata = apply(
+ plot_data[, c(group_vars, "ROWID"), drop = FALSE],
+ 1,
+ function(row) as.list(setNames(row, c(group_vars, "ROWID")))
+ )
+ ) %>%
+ plotly::plotly_build()
+}
diff --git a/R/lambda_slope_plot.R b/R/lambda_slope_plot.R
deleted file mode 100644
index 69eb499de..000000000
--- a/R/lambda_slope_plot.R
+++ /dev/null
@@ -1,291 +0,0 @@
-#' Generate a Lambda Slope Plot
-#'
-#' This function generates a lambda slope plot using pharmacokinetic data. It calculates relevant
-#' lambda parameters and visualizes the data points used for lambda calculation, along with
-#' a linear regression line and additional plot annotations.
-#'
-#' @param conc_pknca_df Data frame containing the concentration data
-#' (default is `mydata$conc$data`).
-#' @param row_values A list containing the values for the column_names used for filtering.
-#' @param myres A PKNCAresults object containing the results of the NCA analysis
-#' @param r2adj_threshold Numeric value representing the R-squared adjusted threshold for
-#' determining the subtitle color (default is 0.7).
-#' @param time_column The name of the time column in the concentration data frame.
-#' (default is "AFRLT").
-#'
-#' @return A plotly object representing the lambda slope plot.
-#'
-#' @details
-#' The function performs the following steps:
-#' \itemize{
-#' \item{Creates duplicates of the pre-dose and last doses of concentration data.}
-#' \item{Filters and arranges the input data to obtain relevant lambda calculation information.}
-#' \item{Identifies the data points used for lambda calculation.}
-#' \item{Calculates the fitness, intercept, and time span of the half-life estimate.}
-#' \item{
-#' Determines the subtitle color based on the R-squared adjusted value and half-life estimate.
-#' }
-#' \item{
-#' Generates a ggplot object with the relevant data points,
-#' linear regression line, and annotations.
-#' }
-#' \item{Converts the ggplot object to a plotly object for interactive visualization.}
-#' }
-#'
-#' @examples
-#' \donttest{
-#' if (interactive()) {
-#' # Load a small packaged example dataset
-#' adnca <- read.csv(system.file("shiny/data/example-ADNCA.csv", package = "aNCA"))
-#'
-#' # Subset to a single subject to keep the example fast
-#' subj1 <- unique(adnca$USUBJID)[3]
-#' dose1 <- unique(adnca$DOSNOP)[1]
-#' adnca_sub <- adnca[adnca$USUBJID == subj1 & adnca$DOSNOP == dose1, ]
-#'
-#' # Analysis details (minimal example)
-#' method <- "lin up/log down"
-#' params <- c("cmax", "tmax", "auclast", "aucinf.obs")
-#' analytes <- unique(adnca_sub$PARAM)
-#' dosnos <- unique(adnca_sub$ATPTREF)
-#' pcspecs <- unique(adnca_sub$PCSPEC)
-#' auc_data <- data.frame(start_auc = numeric(), end_auc = numeric())
-#'
-#' # Build a minimal PKNCA data object and run NCA (kept in \donttest for CRAN safety)
-#' pknca_data <- PKNCA_create_data_object(adnca_sub)
-#' pknca_data <- create_start_impute(pknca_data)
-#' pknca_data <- PKNCA_update_data_object(
-#' pknca_data,
-#' auc_data = auc_data,
-#' method = method,
-#' params = params,
-#' selected_analytes = analytes,
-#' selected_profile = dosnos,
-#' selected_pcspec = pcspecs
-#' )
-#'
-#' pknca_res <- PKNCA_calculate_nca(pknca_data)
-#'
-#' # Create the lambda slope plot for the example subject
-#' plot <- lambda_slope_plot(
-#' conc_pknca_df = pknca_data$conc$data,
-#' row_values = list(USUBJID = subj1, STUDYID = unique(adnca_sub$STUDYID)[1], DOSNOA = 1),
-#' myres = pknca_res,
-#' r2adj_threshold = 0.7
-#' )
-#' print(plot)
-#' }
-#' }
-#' @import dplyr
-#' @import ggplot2
-#' @importFrom plotly ggplotly layout config style add_trace
-#' @importFrom rlang set_names
-#' @export
-lambda_slope_plot <- function(
- conc_pknca_df,
- row_values,
- myres = myres,
- r2adj_threshold = 0.7,
- time_column = "AFRLT"
-) {
-
- column_names <- names(row_values)
- grouping_names <- setdiff(column_names, "ATPTREF")
- #Create duplicates for predose and last dose points per profile
- conc_pknca_df <- dose_profile_duplicates(conc_pknca_df, grouping_names)
- #Obtain values for slopes selection
- lambda_res <- myres$result %>%
- filter(if_all(all_of(column_names), ~ .x == row_values[[deparse(substitute(.x))]])) %>%
- arrange(across(all_of(column_names)), start_dose, desc(end_dose)) %>%
- filter(!duplicated(paste0(!!!rlang::syms(column_names), PPTESTCD)))
-
- lambda_z_n_points <- as.numeric(lambda_res$PPSTRES[lambda_res$PPTESTCD == "lambda.z.n.points"])
- if (is.na(lambda_z_n_points)) lambda_z_n_points <- 0
-
- grouping_values <- row_values[grouping_names]
-
- lambda_z_ix_rows <- conc_pknca_df %>%
- ungroup() %>%
- filter(
- if_all(all_of(grouping_names), ~ .x == row_values[[deparse(substitute(.x))]]),
- !exclude_half.life,
- !!sym(time_column) >= sum(
- subset(
- lambda_res,
- lambda_res$PPTESTCD == "lambda.z.time.first",
- select = c("start", "PPSTRES")
- )
- )
- ) %>%
- arrange(IX) %>%
- slice(0:lambda_z_n_points)
-
- #Obtain parameter values for subtitle
- r2_value <- signif(as.numeric(lambda_res$PPSTRES[lambda_res$PPTESTCD == "r.squared"]), 3)
- r2adj_value <- signif(as.numeric(lambda_res$PPSTRES[lambda_res$PPTESTCD == "adj.r.squared"]), 3)
- half_life_value <- signif(as.numeric(lambda_res$PPSTRES[lambda_res$PPTESTCD == "half.life"]), 3)
- time_span <- signif(
- abs(dplyr::last(lambda_z_ix_rows[[time_column]])
- - dplyr::first(lambda_z_ix_rows[[time_column]])), 3
- )
-
- subtitle_color <- ifelse(
- r2adj_value < r2adj_threshold | half_life_value > (time_span / 2),
- "red",
- "black"
- )
- subtitle_text <- paste0(
- " R2adj: ", r2adj_value,
- " HL \u03BBz = ", half_life_value, " ",
- lambda_res$PPSTRESU[lambda_res$PPTESTCD == "half.life"],
- " (T", lambda_z_ix_rows$IX[nrow(lambda_z_ix_rows)], " - T",
- lambda_z_ix_rows$IX[1], ")/2 = ", time_span / 2, " ",
- lambda_res$PPSTRESU[lambda_res$PPTESTCD == "half.life"]
- )
-
- #Create error text if Cmax used in calculation
- cmax_error_text <- NULL
- tmax_value <- lambda_res$PPSTRES[lambda_res$PPTESTCD == "tmax"]
- lower_limit <- lambda_res$PPSTRES[lambda_res$PPTESTCD == "lambda.z.time.first"]
- if (!is.na(tmax_value) && !is.na(lower_limit) && tmax_value >= lower_limit) {
- subtitle_color <- "red"
- cmax_error_text <- list(
- text = "Cmax should not be included in lambda calculation",
- font = list(size = 15, color = "red", family = "times"),
- x = 1,
- y = 1,
- xref = "paper",
- yref = "paper",
- xanchor = "right",
- yanchor = "top",
- showarrow = FALSE
- )
- }
-
- # Create the title
- title_text <- paste(
- paste0(column_names, ": ", sapply(column_names, function(col) row_values[[col]])),
- collapse = ", "
- )
-
- #Filter the data set for subject profile
- plot_data <- conc_pknca_df %>%
- ungroup() %>%
- filter(
- if_all(all_of(grouping_names), ~ .x == grouping_values[[deparse(substitute(.x))]])
- ) %>%
- arrange(IX) %>%
- mutate(
- IX_shape = ifelse(is.excluded.hl, "excluded", "included"),
- IX_stroke = ifelse(is.excluded.hl, 4, 1),
- IX_color = case_when(
- is.excluded.hl ~ "excluded",
- IX %in% lambda_z_ix_rows$IX ~ "hl.included",
- TRUE ~ "hl.excluded"
- )
- ) %>%
- filter(AVAL > 0) %>%
- as.data.frame()
-
- if (nrow(plot_data) == 0) {
- warning("Not enough data for plotting. Returning empty plot.")
- return(.plotly_empty_plot("No valid lambda calculations available"))
- }
-
- #Create initial plot
- ggplot_obj <- plot_data %>%
- ggplot(aes(x = ARRLT, y = AVAL)) +
- geom_line(color = "gray70", linetype = "solid", linewidth = 1) +
- geom_smooth(
- data = subset(plot_data, IX_color == "hl.included"),
- method = "lm",
- se = FALSE,
- formula = y ~ x,
- color = "green3",
- linetype = "solid",
- linewidth = 1
- ) +
- geom_point(
- data = plot_data,
- aes(shape = IX_shape, color = IX_color, stroke = IX_stroke),
- size = 5
- ) +
- labs(
- title = title_text,
- y = paste0("Log10 Concentration (", conc_pknca_df $PCSTRESU[1], ")"),
- x = paste0("Actual Time Post Dose (", conc_pknca_df $RRLTU[1], ")")
- ) +
- theme_bw() +
- theme(
- plot.title = element_text(hjust = 0.5, face = "bold", size = 15, family = "serif"),
- legend.position = "none",
- axis.text = element_text(size = 15),
- axis.title.x = element_text(size = 15, family = "serif", margin = margin(t = 0)),
- axis.title.y = element_text(size = 15, family = "serif", margin = margin(r = 10)),
- panel.border = element_rect(colour = "gray35", fill = NA, linewidth = 1),
- panel.grid.major = element_line(colour = "gray90"),
- plot.margin = margin(t = 5, r = 5, b = 35, l = 5)
- ) +
- scale_shape_manual(values = c("included" = 16, "excluded" = 3)) +
- scale_color_manual(values = c(
- "hl.included" = "green4", "hl.excluded" = "black", "excluded" = "red3"
- )) +
- scale_y_log10()
-
- plotly_obj <- ggplotly(ggplot_obj) %>%
- layout(
- margin = list(t = 80),
- annotations = list(
- list(
- text = subtitle_text,
- showarrow = TRUE,
- arrowcolor = "transparent",
- xref = "paper",
- yref = "paper",
- xanchor = "right",
- yanchor = "top",
- font = list(size = 15, color = subtitle_color, family = "times"),
- x = 1,
- y = 1
- ),
- cmax_error_text
- ),
- hoverlabel = list(font = list(family = "times", size = 20))
- ) %>%
- config(mathjax = "cdn")
-
- num_traces <- length(plotly_obj$x$data)
-
- for (i in seq_len(num_traces)) {
- plotly_obj <- plotly_obj %>%
- style(hovertext = ~paste0("Data Point: ", IX), hoverinfo = "none", traces = i)
- }
-
- customdata <- apply(
- plot_data[, c(column_names, "IX"), drop = FALSE],
- 1,
- function(row) as.list(set_names(row, c(column_names, "IX")))
- )
-
- # Add tracing for interactive plots
- plotly_obj %>%
- add_trace(
- plot_data,
- x = ~ARRLT, y = ~log10(AVAL),
- customdata = customdata,
- text = ~paste0(
- "Data Point: ", IX, "\n",
- "(", round(ARRLT, 1), " , ", signif(AVAL, 3), ")"
- ),
- type = "scatter",
- mode = "markers",
- name = "Data Points",
- hoverinfo = "text",
- marker = list(color = case_when(
- plot_data$is.excluded.hl ~ "red",
- plot_data$IX %in% lambda_z_ix_rows$IX ~ "green",
- TRUE ~ "black"
- ), size = 12, opacity = 0), # Make points semi-transparent
- showlegend = FALSE
- )
-}
diff --git a/R/pivot_wider_pknca_results.R b/R/pivot_wider_pknca_results.R
index ab6bada33..ebbcdc9bc 100644
--- a/R/pivot_wider_pknca_results.R
+++ b/R/pivot_wider_pknca_results.R
@@ -62,7 +62,7 @@ pivot_wider_pknca_results <- function(myres, flag_rules = NULL, extra_vars_to_ke
group_by(!!!syms(conc_groups), DOSNOA) %>%
# Derive LAMZMTD: was lambda.z manually customized?
mutate(LAMZMTD = ifelse(
- any(is.excluded.hl) | any(is.included.hl), "Manual", "Best slope"
+ any(exclude_half.life) | any(include_half.life), "Manual", "Best slope"
)) %>%
filter(!exclude_half.life | is.na(LAMZLL) | is.na(LAMZNPT)) %>%
filter(!!sym(time_col) >= (LAMZLL + start) | is.na(LAMZLL)) %>%
diff --git a/R/pk_dose_qc_plot.R b/R/pk_dose_qc_plot.R
index 84984e69c..7f81cd617 100644
--- a/R/pk_dose_qc_plot.R
+++ b/R/pk_dose_qc_plot.R
@@ -34,6 +34,9 @@
#' @return A `ggplot` object or, if `as_plotly = TRUE`, a `plotly` object.
#'
#' @export
+#' @importFrom ggplot2 ggplot aes geom_point facet_wrap scale_shape_manual
+#' scale_colour_manual scale_alpha_manual labs theme_bw
+#' @importFrom plotly ggplotly layout
#' @examples
#'
#' # Sample concentration data
diff --git a/R/utils-slope_selector.R b/R/utils-slope_selector.R
index 9f682c861..def5f10d4 100644
--- a/R/utils-slope_selector.R
+++ b/R/utils-slope_selector.R
@@ -1,170 +1,45 @@
-#' Filter dataset based on slope selections and exclusions
-#'
-#' This function filters main dataset based on provided slope selections an exclusions.
-#'
-#' @param data Data to filter. Must be `PKNCAdata` list, containing the `conc` element with
-#' `PKNCAconc` list and appropriate data frame included under data.
-#' @param slopes A data frame containing slope rules, including `TYPE`, `RANGE`,
-#' and `REASON` columns. May also have grouping columns (expected to match slope_groups)
-#' @param profiles List with available profiles for each `SUBJECT`.
-#' @param slope_groups List with column names that define the groups.
-#' @param check_reasons Whether to check if all selections have REASONS stated. If this is `TRUE`
-#' and not all selections have a reason provided, an error will be thrown.
-#'
-#' @returns Original dataset, with `is.included.hl`, `is.excluded.hl` and `exclude_half.life`
-#' columns modified in accordance to the provided slope filters.
-#' @importFrom dplyr filter group_by mutate select all_of
-#' @export
-filter_slopes <- function(data, slopes, profiles, slope_groups, check_reasons = FALSE) {
- if (is.null(data) || is.null(data$conc) || is.null(data$conc$data))
- stop("Please provide valid data.")
-
- # If there is no specification there is nothing to save #
- if (is.null(slopes) || nrow(slopes) == 0) {
- return(data)
- }
-
- if (check_reasons) {
- exclusions <- filter(slopes, TYPE == "Exclusion")
- if (any(exclusions$REASON == "")) {
- missing_reasons <- filter(exclusions, REASON == "") %>%
- select(-REASON) %>%
- apply(1, function(x) paste0(x, collapse = " "))
-
- stop(
- "No reason provided for the following exclusions:\n",
- missing_reasons
- )
- }
- }
-
- # Reset to 0 all previous (if done) changes #
- data$conc$data$is.included.hl <- FALSE
- data$conc$data$is.excluded.hl <- FALSE
- data$conc$data$exclude_half.life <- FALSE
- data$conc$data$include_half.life <- NA
-
- # Eliminate all rows with conflicting or blank values
- slopes <- slopes %>%
- semi_join(
- profiles,
- by = slope_groups
- ) %>%
- filter(all(!is.na(sapply(RANGE, .eval_range))))
-
- if (nrow(slopes) != 0) {
- # Go over all rules and check if there is no overlap - if there is, edit accordingly
- slopes <- purrr::reduce(
- split(slopes, seq_len(nrow(slopes))),
- .f = ~ check_slope_rule_overlap(.x, .y, slope_groups, .keep = TRUE)
- )
- }
-
- # Update the exclusion/selection data for Lambda based on the current exc/sel table
- data <- .apply_slope_rules(data, slopes, slope_groups)
-
- data$conc$data <- data$conc$data %>%
- group_by(!!!syms(slope_groups)) %>%
- mutate(exclude_half.life = {
- if (any(is.included.hl)) {
- is.excluded.hl | !is.included.hl
- } else {
- is.excluded.hl
- }
- },
- include_half.life = case_when(
- is.included.hl ~ TRUE,
- TRUE ~ NA
- )) %>%
- ungroup()
-
- data
-}
-
-#' Check overlap between existing and new slope rulesets
-#'
-#' Takes in tables with existing and incoming selections and exclusions, finds any overlap and
-#' differences, edits the ruleset table accordingly.
-#'
-#' @param existing Data frame with existing selections and exclusions.
-#' @param new Data frame with new rule to be added or removed.
-#' @param slope_groups List with column names that define the groups.
-#' @param .keep Whether to force keep fully overlapping rulesets. If FALSE, it will be assumed
-#' that the user wants to remove rule if new range already exists in the dataset.
-#' If TRUE, in that case full range will be kept.
-#' @returns Data frame with full ruleset, adjusted for new rules.
-#' @export
-check_slope_rule_overlap <- function(existing, new, slope_groups, .keep = FALSE) {
-
- # check if any rule already exists for specific subject and profile #
- existing_index <- which(
- existing$TYPE == new$TYPE &
- Reduce(`&`, lapply(slope_groups, function(col) {
- existing[[col]] == new[[col]]
- }))
- )
-
- if (length(existing_index) != 1) {
- if (length(existing_index) > 1)
- warning("More than one range for single subject, profile and rule type detected.")
- return(rbind(existing, new))
- }
-
- existing_range <- .eval_range(existing$RANGE[existing_index])
- new_range <- .eval_range(new$RANGE)
-
- is_inter <- length(intersect(existing_range, new_range)) != 0
- is_diff <- length(setdiff(new_range, existing_range)) != 0
-
- if (is_diff || .keep) {
- existing$RANGE[existing_index] <- unique(c(existing_range, new_range)) %>%
- .compress_range()
-
- } else if (is_inter) {
- existing$RANGE[existing_index] <- setdiff(existing_range, new_range) %>%
- .compress_range()
- }
-
- dplyr::filter(existing, !is.na(RANGE))
-}
-
#' Apply Slope Rules to Update Data
#'
-#' This function iterates over the given slopes and updates the `data$conc$data` object
-#' by setting inclusion or exclusion flags based on the slope conditions.
-#'
-#' @param data A list containing concentration data (`data$conc$data`) with columns that
-#' need to be updated based on the slope rules.
-#' @param slopes A data frame containing slope rules, including `TYPE`, `RANGE`,
-#' and `REASON` columns. May also have grouping columns (expected to match slope_groups)
-#' @param slope_groups A character vector specifying the group columns used for filtering.
-#'
-#' @returns description The modified `data` object with updated inclusion/exclusion flags
-#' and reasons in `data$conc$data`.
-.apply_slope_rules <- function(data, slopes, slope_groups) {
-
- conc_data <- data$conc$data %>%
- group_by(!!!syms(slope_groups)) %>%
- mutate(index = seq_len(n())) %>%
- ungroup()
-
+#' Iterates over the given rules and updates the PKNCA object setting inclusion/exclusion flags.
+#' @param data PKNCA data object
+#' @param slopes Data frame of slope rules (TYPE, RANGE, REASON, group columns)
+#' @return Modified data object with updated flags
+update_pknca_with_rules <- function(data, slopes) {
+ slope_groups <- intersect(group_vars(data), names(slopes))
+ time_col <- data$conc$columns$time
+ exclude_hl_col <- data$conc$columns$exclude_half.life
+ include_hl_col <- data$conc$columns$include_half.life
+
+ #####################################################
+ # TODO: Make a better fix to understand why slopes is constructed 2 times
+ # when adding exclusion, running NCA and then removing slope (#641)
+
+ # Make sure when rows are removed no NA value is left
+ slopes <- na.omit(slopes)
+ #####################################################
for (i in seq_len(nrow(slopes))) {
- # Build the condition dynamically for group columns
- selection_index <- which(
+ # Determine the time range for the points adjusted
+ range <- strsplit(as.character(slopes$RANGE[i]), ":")[[1]] %>%
+ as.numeric() %>%
+ range()
+ # Build the condition dynamically for group columns and time range
+ pnt_idx <- which(
Reduce(`&`, lapply(slope_groups, function(col) {
- conc_data[[col]] == slopes[[col]][i]
+ data$conc$data[[col]] == slopes[[col]][i]
})) &
- conc_data$index %in% .eval_range(slopes$RANGE[i])
+ between(data$conc$data[[time_col]], range[[1]], range[[2]])
)
-
if (slopes$TYPE[i] == "Selection") {
- data$conc$data$is.included.hl[selection_index] <- TRUE
+ data$conc$data[[include_hl_col]][pnt_idx] <- TRUE
+ } else if (slopes$TYPE[i] == "Exclusion") {
+ data$conc$data[[exclude_hl_col]][pnt_idx] <- TRUE
} else {
- data$conc$data$is.excluded.hl[selection_index] <- TRUE
+ stop("Unknown TYPE in slopes: ", slopes$TYPE[i])
}
-
- data$conc$data$REASON[selection_index] <- slopes$REASON[i]
+ data$conc$data$REASON[pnt_idx] <- paste0(
+ data$conc$data$REASON[pnt_idx],
+ rep(slopes$REASON[i], length(pnt_idx))
+ )
}
-
data
}
diff --git a/R/zzz.R b/R/zzz.R
index 9cf7c063d..c9ae729bc 100644
--- a/R/zzz.R
+++ b/R/zzz.R
@@ -105,11 +105,11 @@
"TRTRINT",
"TYPE",
"Type",
- "type",
"USUBJID",
"VOLUME",
"Value",
"Variable",
+ "adj.r.squared",
"aucs",
"aucs_extravascular",
"aucs_intravascular",
@@ -130,10 +130,13 @@
"exclude_half.life",
"facet_title",
"format_fun",
+ "ggplotly",
+ "half.life",
"has_param_to_impute",
"id_list",
"id_plot",
"id_variable_col",
+ "include_half.life",
"impute",
"install.packages",
"interval_name",
@@ -148,6 +151,11 @@
"is_extravascular",
"is_metabolite",
"is_one_dose",
+ "is_halflife_used",
+ "lambda.z",
+ "lambda.z.time.first",
+ "lambda.z.time.last",
+ "layout",
"is_requested",
"legend_group",
"log10_CI",
@@ -169,14 +177,18 @@
"pknca_units_tbl",
"ppanmeth_ref_groups",
"ppanmeth_test_groups",
+ "predict",
"prev_dosno",
"single_dose_present",
+ "span.ratio",
"start",
"start_auc",
"start_dose",
"strata_cols_comb",
+ "tlast",
"time",
"tooltip_text",
+ "type",
"type_interval",
"var_name",
"validate",
diff --git a/inst/shiny/functions/handle_plotly_click.R b/inst/shiny/functions/handle_plotly_click.R
index aca9ad98c..b0c8412bb 100644
--- a/inst/shiny/functions/handle_plotly_click.R
+++ b/inst/shiny/functions/handle_plotly_click.R
@@ -1,76 +1,92 @@
-#' Update Last Click Data for Slope Selection
-#'
-#' Checks if the user clicked on a different plot or dataset and updates
-#' `last_click_data` accordingly. If an update is needed, the function exits early.
+
+#' Handle Plotly Click for Slope Selection
#'
-#' @param last_click_data A reactive Values object storing the last clicked data.
-#' @param manual_slopes A reactive Values object storing the manually added slope rules.
-#' @param slopes_groups A character vector of slope grouping column names.
-#' @param click_data A list containing the custom data from the plotly click event.
+#' This function processes a plotly click event in the slope selection UI. It determines whether
+#' the double click should add a new exclusion or selection rule to the manual slopes table
+#' (same point = exclusion, two points in same plot = selection).
#'
-#' @returns Returns a list with updated `last_click_data` and `manual_slopes`.
+#' @param last_click_data A reactiveVal storing the last clicked plotly data (or NULL).
+#' @param manual_slopes A reactiveVal storing the current manual slopes table (data.frame).
+#' @param click_data The new plotly click event data (list with customdata).
+#' @param pknca_data The current PKNCA data object (for context and group info).
+#' @return List with updated last_click_data and manual_slopes.
#'
-handle_plotly_click <- function(last_click_data, manual_slopes, slopes_groups, click_data) {
+#' @details
+#' - If the user clicks the same point twice, an exclusion rule is added for that point.
+#' - If the user clicks two points in the same interval, a selection rule is added for the range.
+#' - Otherwise, no rule is added and the click is just stored.
+handle_plotly_click <- function(last_click_data, manual_slopes, click_data, pknca_data) {
req(click_data, click_data$customdata)
-
- identifiers <- click_data$customdata
- if (!all(names(identifiers) %in% c(slopes_groups, "IX", "DOSNOA"))) {
- stop("Error: Missing expected keys in customdata")
+ # If there is no previous click, store this click and do nothing else
+ if (is.null(last_click_data())) {
+ return(list(
+ last_click_data = click_data,
+ manual_slopes = manual_slopes()
+ ))
}
- # Map identifiers dynamically
- dynamic_values <- setNames(
- lapply(slopes_groups, function(col) identifiers[[col]]),
- slopes_groups
- )
-
- # Extract additional information for idx_pnt
- idx_pnt <- identifiers$IX
-
- # Create a copy of last_click_data
- updated_click_data <- last_click_data
+ # Extract info for current and last click (group, interval, time, etc.)
+ pnt <- .extract_click_info(click_data, pknca_data)
+ lstpnt <- .extract_click_info(last_click_data(), pknca_data)
- # Check if the selection has changed
- updated <- any(
- sapply(
- slopes_groups,
- function(col) dynamic_values[[col]] != updated_click_data[[tolower(col)]]
+ # Decide what rule to add based on click context
+ new_rule <- pnt$group
+ if (pnt$idx == lstpnt$idx) {
+ # Same point clicked twice: add exclusion rule for that point
+ new_rule$TYPE <- "Exclusion"
+ new_rule$RANGE <- paste0(pnt$time)
+ new_rule$REASON <- ""
+ } else if (identical(pnt$int, lstpnt$int)) {
+ # Two points in same interval: add selection rule for the range
+ new_rule$TYPE <- "Selection"
+ new_rule$RANGE <- paste0(
+ sort(c(pnt$time, lstpnt$time)),
+ collapse = ":"
)
- )
-
- if (updated) {
- for (col in slopes_groups) {
- updated_click_data[[tolower(col)]] <- dynamic_values[[col]]
- }
- updated_click_data$idx_pnt <- idx_pnt
-
- # Return updated last_click_data, but do not modify global state
- return(list(last_click_data = updated_click_data, manual_slopes = manual_slopes()))
+ new_rule$REASON <- ""
+ } else {
+ # Clicks not in same interval: just update last_click_data, no rule
+ return(list(
+ last_click_data = click_data,
+ manual_slopes = manual_slopes()
+ ))
}
- # Create new rule as a local object
- new_rule <- as.data.frame(
- lapply(
- c(
- dynamic_values,
- TYPE = if (idx_pnt != updated_click_data$idx_pnt) "Selection" else "Exclusion",
- RANGE = paste0(updated_click_data$idx_pnt, ":", idx_pnt),
- REASON = ""
- ),
- as.character # Convert everything to character
- ),
- stringsAsFactors = FALSE
+ # Add or update the rule in the manual_slopes table
+ updated_slopes <- check_slope_rule_overlap(manual_slopes(), new_rule)
+
+ # Return updated values (reset last_click_data to NULL to await next click)
+ list(
+ last_click_data = NULL,
+ manual_slopes = updated_slopes
)
+}
- # Update manual_slopes without modifying it globally
- updated_slopes <- check_slope_rule_overlap(manual_slopes(), new_rule, slopes_groups)
- # Reset last_click_data dynamically
- for (col in names(dynamic_values)) {
- updated_click_data[[tolower(col)]] <- ""
- }
- updated_click_data$idx_pnt <- ""
-
- # Return updated values
- list(last_click_data = updated_click_data, manual_slopes = updated_slopes)
+#' Extract Click Info for Slope Selection
+#'
+#' Helper for handle_plotly_click. Given plotly click data and PKNCA data, returns a list with:
+#' - idx: row index in conc data
+#' - time: time value of click
+#' - row: full row from conc data
+#' - int: interval(s) in which the point falls
+#' - group: grouping columns for the interval
+#'
+#' @param click_data List from plotly click event
+#' @param pknca_data PKNCA data object
+#' @return List with idx, time, row, int, group
+.extract_click_info <- function(click_data, pknca_data) {
+ idx <- as.numeric(click_data$customdata$ROWID)
+ time <- as.numeric(click_data$x)
+ row <- pknca_data$conc$data[idx, ]
+ int <- pknca_data$intervals %>%
+ merge(row, by = c(group_vars(pknca_data))) %>%
+ filter(
+ start <= row[[pknca_data$conc$columns$time]] &
+ end >= row[[pknca_data$conc$columns$time]]
+ ) %>%
+ select(any_of(names(pknca_data$intervals)))
+ group <- int %>%
+ select(any_of(c(group_vars(pknca_data), "ATPTREF")))
+ list(idx = idx, time = time, row = row, int = int, group = group)
}
diff --git a/inst/shiny/functions/utils-slope_selector.R b/inst/shiny/functions/utils-slope_selector.R
new file mode 100644
index 000000000..b02a9ff51
--- /dev/null
+++ b/inst/shiny/functions/utils-slope_selector.R
@@ -0,0 +1,236 @@
+#' Slope Selector Utility Functions
+#'
+#' These helpers support the slope selection workflow by detecting changes in PKNCA data,
+#' updating plots, and managing slope rule logic. Used internally by the slope selector module.
+
+#' Detect changes between old and new PKNCA data
+#'
+#' Compares two PKNCA data objects to determine if the underlying data, half-life adjustments,
+#' or selected intervals have changed. Used to decide when to update plots.
+#' @param old Previous PKNCA data object
+#' @param new New PKNCA data object
+#' @return List with logicals: `in_data`, `in_hl_adj`, `in_selected_intervals`
+detect_pknca_data_changes <- function(old, new) {
+ excl_hl_col <- new$conc$columns$exclude_half.life
+ incl_hl_col <- new$conc$columns$include_half.life
+ list(
+ in_data = if (is.null(old) & !is.null(new)) {
+ TRUE
+ } else {
+ !identical(
+ dplyr::select(
+ old$conc$data,
+ -any_of(c(excl_hl_col, incl_hl_col))
+ ),
+ dplyr::select(
+ new$conc$data,
+ -any_of(c(excl_hl_col, incl_hl_col))
+ )
+ )
+ },
+ in_hl_adj = !identical(
+ old$conc$data[[excl_hl_col]],
+ new$conc$data[[excl_hl_col]]
+ ) |
+ !identical(
+ old$conc$data[[incl_hl_col]],
+ new$conc$data[[incl_hl_col]]
+ ),
+ in_selected_intervals = !identical(new$intervals, old$intervals)
+ )
+}
+
+
+#' Handle half-life adjustment changes
+#'
+#' Updates only the plots affected by changes in half-life inclusion/exclusion columns.
+#' @param new_pknca_data New PKNCA data object
+#' @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) {
+ excl_hl_col <- new_pknca_data$conc$columns$exclude_half.life
+ incl_hl_col <- new_pknca_data$conc$columns$include_half.life
+ affected_groups <- anti_join(
+ dplyr::select(
+ new_pknca_data$conc$data,
+ any_of(c(group_vars(new_pknca_data), "ATPTREF", excl_hl_col, incl_hl_col))
+ ),
+ dplyr::select(
+ old_pknca_data$conc$data,
+ any_of(c(group_vars(old_pknca_data), "ATPTREF", excl_hl_col, incl_hl_col))
+ ),
+ by = c(group_vars(new_pknca_data), "ATPTREF", excl_hl_col, incl_hl_col)
+ ) %>%
+ select(any_of(c(group_vars(new_pknca_data), "ATPTREF"))) %>%
+ distinct()
+ update_plots_with_pknca(new_pknca_data, plot_outputs, affected_groups)
+}
+
+
+#' Handle interval changes
+#'
+#' Updates plots when the set of selected intervals changes (e.g., analyte/profile selection).
+#' @param new_pknca_data New PKNCA data object
+#' @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) {
+ new_intervals <- anti_join(
+ new_pknca_data$intervals,
+ old_pknca_data$intervals,
+ by = intersect(
+ names(new_pknca_data$intervals),
+ names(old_pknca_data$intervals)
+ )
+ )
+ rm_intervals <- anti_join(
+ old_pknca_data$intervals,
+ new_pknca_data$intervals,
+ by = intersect(
+ names(new_pknca_data$intervals),
+ names(old_pknca_data$intervals)
+ )
+ )
+ if (nrow(new_intervals) > 0) {
+ affected_groups <- new_intervals %>%
+ select(any_of(c(group_vars(new_pknca_data), "start", "end"))) %>%
+ 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
+ )
+ }
+ if (nrow(rm_intervals) > 0) {
+ rm_plot_names <- rm_intervals %>%
+ select(any_of(c(group_vars(new_pknca_data), "start", "end"))) %>%
+ merge(unique(PKNCA::getGroups(new_pknca_data$conc)), all.x = TRUE) %>%
+ select(any_of(c(group_vars(new_pknca_data), "start", "end"))) %>%
+ distinct() %>%
+ mutate(across(everything(), as.character)) %>%
+ mutate(id = purrr::pmap_chr(
+ .,
+ function(...) {
+ vals <- list(...)
+ paste0(names(vals), "=", vals, collapse = "_")
+ }
+ )) %>%
+ pull(id)
+ plot_outputs <- plot_outputs[!names(plot_outputs) %in% rm_plot_names]
+ }
+ plot_outputs
+}
+
+
+#' Parse Plot Names to Data Frame
+#'
+#' Converts a named list of plots (with names in the format 'col1: val1, col2: val2, ...')
+#' into a data frame with one row per plot and columns for each key.
+#'
+#' @param named_list A named list or vector, where names are key-value pairs separated by commas.
+#' @return A data frame with columns for each key and a `PLOTID` column with the original names.
+parse_plot_names_to_df <- function(named_list) {
+ plot_names <- names(named_list)
+ parsed <- lapply(plot_names, function(x) {
+ pairs <- strsplit(x, "_\\s*")[[1]]
+ kv <- strsplit(pairs, "=\\s*")
+ setNames(
+ vapply(kv, function(y) y[2], character(1)),
+ vapply(kv, function(y) y[1], character(1))
+ )
+ })
+ as.data.frame(
+ do.call(rbind, parsed),
+ stringsAsFactors = FALSE
+ ) %>%
+ mutate(PLOTID = names(named_list))
+}
+
+
+#' Arrange Plots by Group Columns
+#'
+#' Orders a named list of plots according to specified grouping columns.
+#' Assumes a specific naming format (i.e, 'col1: val1, col2: val2, ...').
+#'
+#' @param named_list A named list of plots, with names in the format 'col1: val1, col2: val2, ...'.
+#' @param group_cols Character vector of column names to sort by.
+#' @importFrom dplyr arrange across all_of
+#' @return A named list of plots, ordered by the specified group columns.
+arrange_plots_by_groups <- function(named_list, group_cols) {
+ plot_df <- parse_plot_names_to_df(named_list)
+ arranged_df <- plot_df %>%
+ arrange(across(all_of(group_cols)))
+ named_list[arranged_df$PLOTID]
+}
+
+#' Check overlap between existing and new slope rulesets
+#'
+#' Takes in tables with existing and incoming selections and exclusions, finds any overlap and
+#' differences, edits the ruleset table accordingly.
+#' @param existing Data frame with existing selections and exclusions.
+#' @param new Data frame with new rule to be added or removed.
+#' @param .keep Whether to force keep fully overlapping rulesets. If FALSE, it will be assumed
+#' that the user wants to remove rule if new range already exists in the dataset.
+#' If TRUE, in that case full range will be kept.
+#' @return Data frame with full ruleset, adjusted for new rules.
+#' @export
+check_slope_rule_overlap <- function(existing, new, .keep = FALSE) {
+ slope_groups <- setdiff(names(new), c("TYPE", "RANGE", "REASON"))
+ # check if any rule already exists for specific subject and profile
+ existing_index <- which(
+ existing$TYPE == new$TYPE &
+ Reduce(
+ `&`,
+ lapply(slope_groups, function(col) {
+ existing[[col]] == new[[col]]
+ })
+ )
+ )
+ if (length(existing_index) != 1) {
+ if (length(existing_index) > 1)
+ warning(
+ "More than one range for single subject, profile and rule type detected."
+ )
+ return(rbind(existing, new))
+ }
+ existing_range <- .eval_range(existing$RANGE[existing_index])
+ new_range <- .eval_range(new$RANGE)
+ is_inter <- length(intersect(existing_range, new_range)) != 0
+ is_diff <- length(setdiff(new_range, existing_range)) != 0
+ if (is_diff || .keep) {
+ existing$RANGE[existing_index] <- unique(c(existing_range, new_range)) %>%
+ .compress_range()
+ } else if (is_inter) {
+ existing$RANGE[existing_index] <- setdiff(existing_range, new_range) %>%
+ .compress_range()
+ }
+ dplyr::filter(existing, !is.na(RANGE))
+}
+
+#' Update plots with PKNCA data (for affected intervals)
+#'
+#' Regenerates plots for the specified intervals in the plot_outputs list.
+#' @param pknca_data PKNCA data object
+#' @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) {
+ 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)
+ # 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)[["plots"]])
+ plot_outputs[names(updated_plots)] <- updated_plots
+ plot_outputs
+}
diff --git a/inst/shiny/modules/tab_nca.R b/inst/shiny/modules/tab_nca.R
index ec4a00da8..bafbb5a94 100644
--- a/inst/shiny/modules/tab_nca.R
+++ b/inst/shiny/modules/tab_nca.R
@@ -131,12 +131,8 @@ tab_nca_server <- function(id, pknca_data, extra_group_vars) {
#' Calculate results
res <- withCallingHandlers({
processed_pknca_data %>%
- filter_slopes(
- slope_rules$manual_slopes(),
- slope_rules$profiles_per_subject(),
- slope_rules$slopes_groups(),
- check_reasons = TRUE
- ) %>%
+ # Check if there are exclusions that contains a filled reason
+ check_valid_pknca_data() %>%
# Perform PKNCA parameter calculations
PKNCA_calculate_nca(
blq_rule = settings()$data_imputation$blq_imputation_rule
diff --git a/inst/shiny/modules/tab_nca/descriptive_statistics.R b/inst/shiny/modules/tab_nca/descriptive_statistics.R
index ac512169b..0ebaed74a 100644
--- a/inst/shiny/modules/tab_nca/descriptive_statistics.R
+++ b/inst/shiny/modules/tab_nca/descriptive_statistics.R
@@ -152,6 +152,5 @@ descriptive_statistics_server <- function(id, res_nca, grouping_vars) {
write.csv(summary_stats_filtered(), file)
}
)
-
})
}
diff --git a/inst/shiny/modules/tab_nca/setup.R b/inst/shiny/modules/tab_nca/setup.R
index 1bd32631d..d22a9a25d 100644
--- a/inst/shiny/modules/tab_nca/setup.R
+++ b/inst/shiny/modules/tab_nca/setup.R
@@ -90,6 +90,7 @@ setup_server <- function(id, data, adnca_data, extra_group_vars) {
selected_profile = settings()$profile,
selected_pcspec = settings()$pcspec,
should_impute_c0 = settings()$data_imputation$impute_c0,
+ hl_adj_rules = slope_rules$manual_slopes(),
exclusion_list = general_exclusions$exclusion_list(),
keep_interval_cols = extra_group_vars()
)
@@ -164,38 +165,11 @@ setup_server <- function(id, data, adnca_data, extra_group_vars) {
# Parameter unit changes option: Opens a modal message with a units table to edit
units_table_server("units_table", processed_pknca_data)
- # Create version for slope plots
- # Only parameters required for the slope plots are set in intervals
- # NCA dynamic changes/filters based on user selections
- slopes_pknca_data <- reactive({
- req(
- adnca_data(), settings(), settings()$profile,
- settings()$analyte, settings()$pcspec
- )
- log_trace("Updating PKNCA::data object for slopes.")
-
- df <- 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
- )
-
- params <- c("lambda.z.n.points", "lambda.z.time.first",
- "r.squared", "adj.r.squared", "tmax")
-
- df$intervals <- df$intervals %>%
- mutate(across(any_of(params), ~ TRUE, .names = "{.col}"),
- impute = NA)
-
- df
- })
-
+ # Collect all half life manual adjustments done in the `Slope Selector` section
+ # and controls the half life plots that are displayed
slope_rules <- slope_selector_server(
"slope_selector",
- slopes_pknca_data,
+ processed_pknca_data,
manual_slopes_override
)
diff --git a/inst/shiny/modules/tab_nca/setup/manual_slopes_table.R b/inst/shiny/modules/tab_nca/setup/manual_slopes_table.R
deleted file mode 100644
index 3ed402302..000000000
--- a/inst/shiny/modules/tab_nca/setup/manual_slopes_table.R
+++ /dev/null
@@ -1,203 +0,0 @@
-manual_slopes_table_ui <- function(id) {
- ns <- NS(id)
-
- fluidRow(
- # Selection and exclusion controls #
- div(
- class = "plot-widget-group",
- actionButton(ns("add_rule"), "+ Exclusion/Selection", class = "btn-success")
- ),
- div(
- class = "plot-widget-group",
- actionButton(ns("remove_rule"), "- Remove selected rows", class = "btn-warning")
- ),
- # Table with selections and exclusions #
- fluidRow(
- reactableOutput(ns("manual_slopes"))
- )
- )
-}
-
-
-manual_slopes_table_server <- function(
- id, mydata, profiles_per_subject, slopes_groups
-) {
- moduleServer(id, function(input, output, session) {
-
- ns <- session$ns
-
- # Reactive for Slope selector columns
- slope_selector_columns <- reactive({
- req(slopes_groups())
- c(slopes_groups(), "TYPE", "RANGE", "REASON")
- })
-
- #' Object for storing exclusion and selection data for lambda slope calculation
- manual_slopes <- reactiveVal({
- data.frame(
- TYPE = character(),
- RANGE = character(),
- REASON = character(),
- stringsAsFactors = FALSE
- )
- })
-
- observeEvent(mydata(), {
-
- current_slopes <- manual_slopes()
- # Add missing dynamic columns with default values (e.g., NA_character_)
- for (col in slopes_groups()) {
- if (!col %in% colnames(current_slopes)) {
- current_slopes[[col]] <- character()
- }
- }
- # Define the desired column order
- ordered_cols <- c(slopes_groups(), "TYPE", "RANGE", "REASON")
- current_slopes <- current_slopes[, ordered_cols, drop = FALSE]
-
- # Update the reactive Val
- manual_slopes(current_slopes)
- })
-
- #' Adds new row to the selection/exclusion datatable
- observeEvent(input$add_rule, {
- log_trace("{id}: adding manual slopes row")
-
- # Create a named list for dynamic columns based on `profiles_per_subject`
- dynamic_values <- lapply(slopes_groups(), function(col) {
- value <- as.character(unique(profiles_per_subject()[[col]]))
- if (length(value) > 0) value[1] else NA_character_ # Handle empty or NULL cases
- })
-
- names(dynamic_values) <- slopes_groups()
-
- # Create the new row with both fixed and dynamic columns
- new_row <- as.data.frame(c(
- dynamic_values,
- TYPE = "Selection",
- RANGE = "1:3",
- REASON = ""
- ), stringsAsFactors = FALSE)
-
- updated_data <- as.data.frame(rbind(manual_slopes(), new_row), stringsAsFactors = FALSE)
- manual_slopes(updated_data)
- reset_reactable_memory()
- refresh_reactable(refresh_reactable() + 1)
- })
-
- #' Removes selected row
- observeEvent(input$remove_rule, {
- log_trace("{id}: removing manual slopes row")
-
- selected <- getReactableState("manual_slopes", "selected")
- req(selected)
- edited_slopes <- manual_slopes()[-selected, ]
- manual_slopes(edited_slopes)
- reset_reactable_memory()
- refresh_reactable(refresh_reactable() + 1)
- })
-
- #' Render manual slopes table
- refresh_reactable <- reactiveVal(1)
- output$manual_slopes <- renderReactable({
- log_trace("{id}: rendering slope edit data table")
- # Isolate to prevent unnecessary re-renders on every edit
- isolate({
- data <- manual_slopes()
- })
-
- # Fixed columns (TYPE, RANGE, REASON)
- fixed_columns <- list(
- TYPE = colDef(
- cell = dropdown_extra(
- id = ns("edit_TYPE"),
- choices = c("Selection", "Exclusion"),
- class = "dropdown-extra"
- ),
- width = 200
- ),
- RANGE = colDef(
- cell = text_extra(
- id = ns("edit_RANGE")
- )
- ),
- REASON = colDef(
- cell = text_extra(
- id = ns("edit_REASON")
- ),
- width = 400
- )
- )
-
- # Dynamic group column definitions
- dynamic_columns <- lapply(slopes_groups(), function(col) {
- colDef(
- cell = dropdown_extra(
- id = ns(paste0("edit_", col)),
- choices = unique(profiles_per_subject()[[col]]), # Dynamically set choices
- class = "dropdown-extra"
- ),
- width = 150
- )
- })
- names(dynamic_columns) <- slopes_groups()
-
- # Combine columns in the desired order
- all_columns <- c(
- dynamic_columns,
- list(
- TYPE = fixed_columns$TYPE,
- RANGE = fixed_columns$RANGE,
- REASON = fixed_columns$REASON
- )
- )
-
- # Render reactable
- reactable(
- data = data,
- defaultColDef = colDef(
- align = "center"
- ),
- columns = all_columns,
- selection = "multiple",
- defaultExpanded = TRUE,
- borderless = TRUE,
- theme = reactableTheme(
- rowSelectedStyle = list(backgroundColor = "#eee", boxShadow = "inset 2px 0 0 0 #ffa62d")
- )
- )
- }) %>%
- shiny::bindEvent(refresh_reactable())
-
- #' 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(), {
-
- reactable::updateReactable(
- outputId = "manual_slopes",
- data = manual_slopes()
- )
- })
-
- #' For each of the columns in slope selector data frame, attach an event that will read
- #' edits for that column made in the reactable.
- observe({
- req(slope_selector_columns())
- # Dynamically attach observers for each column
- purrr::walk(slope_selector_columns(), function(colname) {
- observeEvent(input[[paste0("edit_", colname)]], {
- edit <- input[[paste0("edit_", colname)]]
- edited_slopes <- manual_slopes()
- edited_slopes[edit$row, edit$column] <- edit$value
- manual_slopes(edited_slopes)
- })
- })
- })
-
- list(
- manual_slopes = manual_slopes,
- refresh_reactable = refresh_reactable
- )
- })
-}
diff --git a/inst/shiny/modules/tab_nca/setup/page_and_searcher.R b/inst/shiny/modules/tab_nca/setup/page_and_searcher.R
new file mode 100644
index 000000000..7f880ac1b
--- /dev/null
+++ b/inst/shiny/modules/tab_nca/setup/page_and_searcher.R
@@ -0,0 +1,122 @@
+#' Page and Searcher UI (pagination controls only)
+#'
+#' This UI module provides the page navigation controls (previous, next, selector, number).
+#' The search_subject input remains outside for now in the parent (slope_selector.R)
+page_and_searcher_ui <- function(id) {
+ ns <- NS(id)
+ fluidRow(
+ class = "plot-widgets-container-2",
+ div(
+ class = "plot-widget-group",
+ actionButton(
+ ns("previous_page"),
+ "Previous Page",
+ class = "btn-page"
+ )
+ ),
+ div(
+ class = "plot-widget-group",
+ tags$span("Page "),
+ pickerInput(ns("select_page"), "", choices = c(), width = "100px"),
+ tags$span("of "),
+ uiOutput(ns("page_number"), inline = TRUE)
+ ),
+ div(
+ class = "plot-widget-group",
+ actionButton(
+ ns("next_page"),
+ "Next Page",
+ class = "btn-page"
+ )
+ )
+ )
+}
+
+#' Page and Searcher Server
+#'
+#' Handles pagination and subject search logic for displaying plots.
+#' Outputs: list of reactives: page_start, page_end, is_plot_searched, num_pages
+page_and_searcher_server <- function(id, search_subject, plot_outputs, plots_per_page) {
+ moduleServer(id, function(input, output, session) {
+ ns <- session$ns
+
+ # Internalize current page state
+ current_page <- reactiveVal(1)
+
+ # Calculate is_plot_searched
+ is_plot_searched <- reactive({
+ req(plot_outputs())
+ search_val <- search_subject()
+ if (is.null(search_val) || length(search_val) == 0) {
+ rep(TRUE, length(names(plot_outputs())))
+ } else {
+ grepl(
+ paste0("USUBJID=(", paste0(search_val, collapse = ")|("), ")"),
+ names(plot_outputs())
+ )
+ }
+ })
+
+ num_plots <- reactive(sum(is_plot_searched()))
+ plots_per_page_num <- reactive(as.numeric(plots_per_page()))
+ num_pages <- reactive(ceiling(num_plots() / plots_per_page_num()))
+
+ # Navigation events
+ observeEvent(input$next_page, {
+ if (current_page() < num_pages()) {
+ current_page(current_page() + 1)
+ }
+ })
+ observeEvent(input$previous_page, {
+ if (current_page() > 1) {
+ current_page(current_page() - 1)
+ }
+ })
+ observeEvent(input$select_page, {
+ val <- as.numeric(input$select_page)
+ if (!is.na(val)) current_page(val)
+ })
+ observeEvent(list(plots_per_page(), search_subject()), {
+ current_page(1)
+ })
+
+ page_end <- reactive({
+ min(current_page() * plots_per_page_num(), num_plots())
+ })
+ page_start <- reactive({
+ max(page_end() - plots_per_page_num() + 1, 1)
+ })
+
+ # UI outputs for page number and page selector
+ output$page_number <- renderUI(num_pages())
+ observe({
+ updatePickerInput(
+ session = session,
+ inputId = "select_page",
+ choices = 1:num_pages(),
+ selected = current_page()
+ )
+ })
+ # Enable/disable page buttons based on current page
+ observe({
+ curr_page <- current_page()
+ last_page <- num_pages()
+ shinyjs::toggleState(id = "previous_page", condition = curr_page > 1)
+ shinyjs::toggleState(id = "next_page", condition = curr_page < last_page)
+ })
+
+ observe({
+ shinyjs::toggleClass(
+ selector = ".slope-plots-container",
+ class = "multiple",
+ condition = plots_per_page_num() != 1
+ )
+ })
+
+ list(
+ page_start = page_start,
+ page_end = page_end,
+ is_plot_searched = is_plot_searched
+ )
+ })
+}
diff --git a/inst/shiny/modules/tab_nca/setup/slope_selector.R b/inst/shiny/modules/tab_nca/setup/slope_selector.R
index 540b7ab6e..20d00fc4d 100644
--- a/inst/shiny/modules/tab_nca/setup/slope_selector.R
+++ b/inst/shiny/modules/tab_nca/setup/slope_selector.R
@@ -1,18 +1,29 @@
-#' NCA Slope selector module handling slope selection via interactive plots and tables.
+
+#' Slope Selector Module (Server/UI)
+#'
+#' This module manages the half life point selection or exclusion via plots and a table UI.
+#' It coordinates the display and update of plots and the manual slopes table.
+#'
+#' --- Reactivity Flow Schema ---
#'
-#' Generates appropriate interface and gathers user input from the table, as well as interactive
-#' plotly plots, with with user can define inclusions and exclusions for the data.
+#' processed_pknca_data (input, from parent)
+#' └─> slope_selector_server
+#' ├──> plot_outputs (reactive, updated by processed_pknca_data changes)
+#' └──> ├> handle_plotly_click (updates manual_slopes on plot click)
+#' └> slopes_table (updates manual_slopes on user edits & setting overrides)
+#' └─> manual_slopes (output, used by parent to update processed_pknca_data)
#'
-#' @param id ID of the module.
-#' @param pknca_data `PKNCAdata` object with data to base the plots on.
-#' @param manual_slopes_override Reactive experssion with override for the manual slopes selection.
-#' If changes are detected, current settings will be overwritten with
-#' values from that reactive.
#'
-#' @returns List with reactive expressions:
-#' * manual_slopes - Data frame containing inclusions / exclusions.
-#' * profiles_per_subject - Grouping for each subject.
-#' * slopes_groups - Grouping for the slopes, in accordance to the settings.
+#' @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.
+#' @return manual_slopes (data.frame of user slope inclusions/exclusions)
+#'
+#' @details
+#' - The module's main output is the manual_slopes table, which is updated by user
+#' edits in the table UI (slopes_table) or by plot clicking (handle_plotly_click).
+#' - The parent module (setup.R) uses manual_slopes to update processed_pknca_data,
+#' which is then fed back in this module to update plots.
slope_selector_ui <- function(id) {
ns <- NS(id)
@@ -20,7 +31,7 @@ slope_selector_ui <- function(id) {
div(
class = "slope-selector-module",
- manual_slopes_table_ui(ns("manual_slopes")),
+ slopes_table_ui(ns("manual_slopes")),
# Help widget #
dropdown(
div(
@@ -61,7 +72,6 @@ slope_selector_ui <- function(id) {
# Widgets for manipulating plots display #
fluidRow(
class = "plot-widgets-container",
-
div(
class = "plot-widget-group",
selectInput(
@@ -71,7 +81,6 @@ slope_selector_ui <- function(id) {
selected = 1
)
),
-
div(
class = "plot-widget-group",
selectInput(
@@ -79,302 +88,152 @@ slope_selector_ui <- function(id) {
label = "Search Subject",
choices = NULL,
multiple = TRUE
- )
+ ),
+ )
+ ),
+ fluidRow(
+ orderInput(
+ ns("order_groups"),
+ label = "Order plots by:",
+ items = NULL,
+ width = "100%"
)
),
br(),
# Plots display #
uiOutput(ns("slope_plots_ui"), class = "slope-plots-container"),
br(),
- fluidRow(
- class = "plot-widgets-container-2",
- div(
- class = "plot-widget-group",
- actionButton(
- ns("previous_page"),
- "Previous Page",
- class = "btn-page"
- )
- ),
-
- div(
- class = "plot-widget-group",
- tags$span("Page "),
- pickerInput(ns("select_page"), "", choices = c(),
- width = "100px"),
- tags$span("of "),
- uiOutput(ns("page_number"), inline = TRUE)
- ),
-
- div(
- class = "plot-widget-group",
- actionButton(
- ns("next_page"),
- "Next Page",
- class = "btn-page"
- )
- )
- ),
+ # Use the new pagination UI module
+ page_and_searcher_ui(ns("page_and_searcher")),
br()
)
}
-
slope_selector_server <- function( # nolint
- id, pknca_data, manual_slopes_override
+ id, processed_pknca_data, manual_slopes_override
) {
moduleServer(id, function(input, output, session) {
log_trace("{id}: Attaching server")
ns <- session$ns
- #Get grouping columns for plots and tables
- slopes_groups <- reactive({
- req(pknca_data())
-
- pknca_data()$conc$columns$groups %>%
- purrr::list_c() %>%
- append(c("ATPTREF", "DOSNOA")) %>%
- purrr::keep(\(col) {
- !is.null(col) && col != "DOSETRT" && length(unique(pknca_data()$conc$data[[col]])) > 1
- })
- })
-
- # HACK: workaround to avoid plotly_click not being registered warning
- session$userData$plotlyShinyEventIDs <- "plotly_click-A"
+ pknca_data <- reactiveVal(NULL)
+ plot_outputs <- reactiveVal(NULL)
- current_page <- reactiveVal(1)
+ observeEvent(processed_pknca_data(), {
+ req(processed_pknca_data())
- #' updating current page based on user input
- observeEvent(input$next_page, {
- current_page(current_page() + 1)
- shinyjs::disable(selector = ".btn-page")
- })
- observeEvent(input$previous_page, {
- if (current_page() == 1) return(NULL)
- current_page(current_page() - 1)
- shinyjs::disable(selector = ".btn-page")
- })
- observeEvent(input$select_page, current_page(as.numeric(input$select_page)))
- observeEvent(list(input$plots_per_page, input$search_subject), current_page(1))
-
- #' Plot data is a local reactive copy of full data. The purpose is to display data that
- #' is already adjusted with the applied rules, so that the user can verify added selections
- #' and exclusions before applying them to the actual dataset.
- plot_data <- reactive({
- req(pknca_data(), manual_slopes(), profiles_per_subject())
- filter_slopes(pknca_data(), manual_slopes(), profiles_per_subject(), slopes_groups())
- }) %>%
- shiny::debounce(750)
-
- # Generate dynamically the minimum results you need for the lambda plots
- lambdas_res <- reactive({
- req(plot_data())
- if (!"type_interval" %in% names(plot_data()$intervals)) {
- NULL
- } else if (all(!unlist(plot_data()$intervals[sapply(plot_data()$intervals, is.logical)]))) {
- NULL
- } else {
- result_obj <- suppressWarnings(PKNCA::pk.nca(data = plot_data(), verbose = FALSE))
- result_obj$result <- result_obj$result %>%
- mutate(start_dose = start, end_dose = end)
+ new_pknca_data <- processed_pknca_data()
+ new_pknca_data$intervals <- new_pknca_data$intervals %>%
+ filter(type_interval == "main", half.life) %>%
+ unique()
+ changes <- detect_pknca_data_changes(
+ old = pknca_data(),
+ new = new_pknca_data
+ )
- result_obj
+ if (changes$in_data) {
+ # New data or major changes: regenerate all plots
+ plot_outputs(get_halflife_plots(new_pknca_data)[["plots"]])
+ } 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()))
+ } else if (changes$in_selected_intervals) {
+ # Add/remove plots based on intervals (analyte, profile, specimen selection from setup.R)
+ plot_outputs(handle_interval_change(new_pknca_data, pknca_data(), plot_outputs()))
}
- })
-
- # Profiles per Patient ----
- # Define the profiles per patient
- profiles_per_subject <- reactive({
- req(pknca_data())
-
- pknca_data()$intervals %>%
- mutate(USUBJID = as.character(USUBJID),
- ATPTREF = as.character(ATPTREF),
- DOSNOA = as.character(DOSNOA)) %>%
- group_by(!!!syms(c(unname(unlist(pknca_data()$conc$columns$groups)), "DOSNOA"))) %>%
- summarise(ATPTREF = unique(ATPTREF), .groups = "drop") %>%
- unnest(ATPTREF) # Convert lists into individual rows
- })
- #' Updating plot outputUI, dictating which plots get displayed to the user.
- #' Scans for any related reactives (page number, subject filter etc) and updates the plot output
- #' UI to have only plotlyOutput elements for desired plots.
- observeEvent(list(
- plot_data(), lambdas_res(), input$plots_per_page, input$search_subject, current_page()
- ), {
- req(lambdas_res())
- log_trace("{id}: Updating displayed plots")
-
- # Make sure the search_subject input is not NULL
- search_subject <- {
- if (is.null(input$search_subject) || length(input$search_subject) == 0) {
- unique(lambdas_res()$result$USUBJID)
- } else {
- input$search_subject
- }
+ # Update the searching widget choices based on the new data
+ if (changes$in_data | changes$in_selected_intervals) {
+ updateSelectInput(
+ session = session,
+ inputId = "search_subject",
+ label = "Search Subject",
+ choices = unique(new_pknca_data$intervals$USUBJID)
+ )
}
-
- # create plot ids based on available data #
- subject_profile_plot_ids <- pknca_data()$intervals %>%
- select(any_of(c(unname(unlist(pknca_data()$dose$columns$groups)),
- unname(unlist(pknca_data()$conc$columns$groups)),
- "ATPTREF", "DOSNOA"))) %>%
- filter(USUBJID %in% search_subject) %>%
- select(slopes_groups(), USUBJID, DOSNOA) %>%
- unique() %>%
- arrange(USUBJID)
-
- # find which plots should be displayed based on page #
- num_plots <- nrow(subject_profile_plot_ids)
- plots_per_page <- as.numeric(input$plots_per_page)
- num_pages <- ceiling(num_plots / plots_per_page)
-
- if (current_page() > num_pages) {
- current_page(current_page() - 1)
- return(NULL)
+ if (changes$in_data) {
+ updateOrderInput(
+ session = session,
+ inputId = "order_groups",
+ items = group_vars(new_pknca_data)
+ )
}
+ # Save the plots for the zip download (nca_results.R)
+ session$userData$results$slope_selector <- plot_outputs()
- page_end <- current_page() * plots_per_page
- page_start <- page_end - plots_per_page + 1
- if (page_end > num_plots) page_end <- num_plots
-
- # update page number display #
- output$page_number <- renderUI(num_pages)
-
- plots_to_render <- slice(ungroup(subject_profile_plot_ids), page_start:page_end)
-
- plot_outputs <- apply(plots_to_render, 1, function(row) {
-
- lambda_slope_plot(
- conc_pknca_df = plot_data()$conc$data,
- row_values = as.list(row),
- myres = lambdas_res(),
- r2adj_threshold = 0.7,
- time_column = pknca_data()$conc$columns$time
- ) %>%
- htmlwidgets::onRender(
- # nolint start
- "function(el, x) {
- const plotlyElements = $('.slope-selector-module .plotly.html-widget.html-fill-item.html-widget-static-bound.js-plotly-plot');
- plotlyElements.css('height', '100%');
- plotlyElements.css('aspect-ratio', '1');
- window.dispatchEvent(new Event('resize'));
- }"
- # nolint end
- )
- })
+ # 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
+ page_search <- page_and_searcher_server(
+ id = "page_and_searcher",
+ search_subject = reactive(input$search_subject),
+ plot_outputs = plot_outputs,
+ plots_per_page = reactive(input$plots_per_page)
+ )
+ observe({
+ req(plot_outputs())
output$slope_plots_ui <- renderUI({
shinyjs::enable(selector = ".btn-page")
- plot_outputs
+ plot_outputs() %>%
+ # Filter plots based on user search
+ .[page_search$is_plot_searched()] %>%
+ # Arrange plots by the specified group order
+ arrange_plots_by_groups(input$order_groups) %>%
+ # Display only the plots for the current page
+ .[page_search$page_start():page_search$page_end()]
})
-
- # update jump to page selector #
- updatePickerInput(
- session = session,
- inputId = "select_page",
- choices = 1:num_pages,
- selected = current_page()
- )
-
- # update plot display #
- shinyjs::toggleClass(
- selector = ".slope-plots-container",
- class = "multiple",
- condition = plots_per_page != 1
- )
-
- # disable buttons if necessary #
- shinyjs::toggleState(id = ns("previous_page"), condition = current_page() == 1)
- shinyjs::toggleState(id = ns("next_page"), condition = current_page() == num_pages)
- })
-
- #' Rendering slope plots based on nca data.
- observeEvent(lambdas_res(), {
- req(
- lambdas_res(),
- profiles_per_subject()
- )
- log_trace("{id}: Rendering plots")
- # Update the subject search input to make available choices for the user
- updateSelectInput(
- session = session,
- inputId = "search_subject",
- label = "Search Subject",
- choices = unique(lambdas_res()$result$USUBJID)
- )
})
- slopes_table <- manual_slopes_table_server("manual_slopes", pknca_data,
- profiles_per_subject, slopes_groups)
-
+ # 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 <- 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 <- reactiveValues()
-
- observeEvent(slopes_groups(), {
- # Reinitialize dynamic columns when slopes_groups changes
- for (col in tolower(slopes_groups())) {
- last_click_data[[col]] <- ""
- }
- last_click_data$idx_pnt <- ""
- })
-
+ last_click_data <- reactiveVal(NULL)
observeEvent(event_data("plotly_click", priority = "event"), {
log_trace("slope_selector: plotly click detected")
- result <- handle_plotly_click(last_click_data,
- manual_slopes,
- slopes_groups(),
- event_data("plotly_click"))
- # Update reactive values in the observer
- last_click_data <- result$last_click_data
- manual_slopes(result$manual_slopes)
+ click_result <- handle_plotly_click(
+ last_click_data,
+ manual_slopes,
+ event_data("plotly_click"),
+ pknca_data()
+ )
+ # 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)
})
- #' If any settings are uploaded by the user, overwrite current rules
- observeEvent(manual_slopes_override(), {
- req(manual_slopes_override())
-
- if (nrow(manual_slopes_override()) == 0) return(NULL)
-
- log_debug_list("Manual slopes override:", manual_slopes_override())
+ #' 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())
- override_valid <- apply(manual_slopes_override(), 1, function(r) {
- dplyr::filter(
- plot_data()$conc$data,
- PCSPEC == r["PCSPEC"],
- USUBJID == r["USUBJID"],
- PARAM == r["PARAM"],
- ATPTREF == r["ATPTREF"],
- DOSNOA == r["DOSNOA"]
- ) %>%
- NROW() != 0
- }) %>%
- all()
-
- if (!override_valid) {
- msg <- "Manual slopes not compatible with current data, leaving as default."
- log_warn(msg)
- showNotification(msg, type = "warning", duration = 5)
- return(NULL)
- }
+ # Update reactable with rules
+ reactable::updateReactable(
+ outputId = "manual_slopes",
+ data = manual_slopes()
+ )
- manual_slopes(manual_slopes_override())
+ # Load it to the session objects
+ session$userData$slope_rules <- manual_slopes()
})
-
- #' return reactive with slope exclusions data to be displayed in Results -> Exclusions tab
+ #' returns half life adjustments rules to update processed_pknca_data in setup.R
list(
- manual_slopes = manual_slopes,
- profiles_per_subject = profiles_per_subject,
- slopes_groups = slopes_groups
+ manual_slopes = manual_slopes
)
})
}
diff --git a/inst/shiny/modules/tab_nca/setup/slopes_table.R b/inst/shiny/modules/tab_nca/setup/slopes_table.R
new file mode 100644
index 000000000..caee7c852
--- /dev/null
+++ b/inst/shiny/modules/tab_nca/setup/slopes_table.R
@@ -0,0 +1,216 @@
+
+#' Manual Slopes Table UI for Slope Selection
+#'
+#' UI module for displaying and editing the manual slopes table (inclusion/exclusion rules).
+#' Provides buttons to add/remove rules and a reactable table for editing.
+#'
+#' @param id Shiny module id
+#' @return Shiny UI element (fluidRow)
+slopes_table_ui <- function(id) {
+ ns <- NS(id)
+
+ fluidRow(
+ # Selection and exclusion controls #
+ div(
+ class = "plot-widget-group",
+ actionButton(ns("add_rule"), "+ Exclusion/Selection", class = "btn-success")
+ ),
+ div(
+ class = "plot-widget-group",
+ actionButton(ns("remove_rule"), "- Remove selected rows", class = "btn-warning")
+ ),
+ # Table with selections and exclusions #
+ fluidRow(
+ reactableOutput(ns("manual_slopes"))
+ )
+ )
+}
+
+
+
+#' Manual Slopes Table Server for Slope Selection
+#'
+#' Server module for managing the manual slopes table (inclusion/exclusion rules).
+#' Handles adding/removing/editing rules, table's reactivity, and optional override logic.
+#'
+#' @param id Shiny module id
+#' @param pknca_data Reactive providing the current PKNCA data object
+#' @param manual_slopes_override Optional reactive providing a table to override manual slopes
+#' @return List with:
+#' - manual_slopes: reactiveVal containing the current manual slopes table
+#' - refresh_reactable: reactiveVal for triggering table re-render
+slopes_table_server <- function(
+ id, pknca_data, manual_slopes_override = NULL
+) {
+ moduleServer(id, function(input, output, session) {
+
+ ns <- session$ns
+ # Get group columns for the current PKNCA data (for table structure)
+ slopes_pknca_groups <- reactive({
+ req(pknca_data())
+ pknca_data()$intervals %>%
+ select(any_of(c(group_vars(pknca_data()))))
+ })
+
+ # manual_slopes: stores the current table of user rules (inclusion/exclusion)
+ manual_slopes <- reactiveVal(NULL)
+ # When pknca_data() changes, reset the manual_slopes table to empty with correct columns
+ observeEvent(pknca_data(), {
+ req(is.null(manual_slopes()), slopes_pknca_groups())
+
+ ms_colnames <- c(colnames(slopes_pknca_groups()), c("TYPE", "RANGE", "REASON"))
+ initial_manual_slopes <- data.frame(
+ matrix(
+ character(),
+ ncol = length(ms_colnames),
+ nrow = 0,
+ dimnames = list(character(), ms_colnames)
+ )
+ )
+ manual_slopes(initial_manual_slopes)
+ })
+
+ # create a reactive to update the reactable UI when the table changes
+ refresh_reactable <- reactiveVal(0)
+
+ # Add a new row to the table when the user clicks the add button
+ observeEvent(input$add_rule, {
+ log_trace("{id}: adding manual slopes row")
+ first_group <- slopes_pknca_groups()[1, ]
+ time_col <- pknca_data()$conc$columns$time
+ new_row <- cbind(
+ first_group,
+ data.frame(
+ TYPE = "Exclusion",
+ RANGE = paste0(
+ inner_join(first_group, pknca_data()$conc$data)[[time_col]][2]
+ ),
+ REASON = ""
+ )
+ )
+ updated_data <- as.data.frame(
+ rbind(manual_slopes(), new_row),
+ stringsAsFactors = FALSE
+ )
+ manual_slopes(updated_data)
+ reset_reactable_memory()
+ refresh_reactable(refresh_reactable() + 1)
+ })
+
+ # Remove selected rows from the table when the user clicks the remove button
+ observeEvent(input$remove_rule, {
+ log_trace("{id}: removing manual slopes row")
+ selected <- getReactableState("manual_slopes", "selected")
+ req(selected)
+ edited_slopes <- manual_slopes()[-selected, ]
+ manual_slopes(edited_slopes)
+ reset_reactable_memory()
+ refresh_reactable(refresh_reactable() + 1)
+ })
+
+ # Render the manual slopes table (reactable)
+ output$manual_slopes <- renderReactable({
+ req(manual_slopes())
+ log_trace("{id}: rendering slope edit data table")
+ isolate({
+ data <- manual_slopes()
+ })
+ # Define columns: group columns (dynamic), then TYPE/RANGE/REASON (fixed)
+ fixed_columns <- list(
+ TYPE = colDef(
+ cell = dropdown_extra(
+ id = ns("edit_TYPE"),
+ choices = c("Selection", "Exclusion"),
+ class = "dropdown-extra"
+ ),
+ width = 200
+ ),
+ RANGE = colDef(
+ cell = text_extra(
+ id = ns("edit_RANGE")
+ )
+ ),
+ REASON = colDef(
+ cell = text_extra(
+ id = ns("edit_REASON")
+ ),
+ width = 400
+ )
+ )
+ dynamic_columns <- lapply(colnames(slopes_pknca_groups()), function(col) {
+ colDef(
+ cell = dropdown_extra(
+ id = ns(paste0("edit_", col)),
+ choices = unique(slopes_pknca_groups()[[col]]),
+ class = "dropdown-extra"
+ ),
+ width = 150
+ )
+ })
+ names(dynamic_columns) <- colnames(slopes_pknca_groups())
+ all_columns <- c(dynamic_columns, fixed_columns)
+ reactable(
+ data = data,
+ defaultColDef = colDef(align = "center"),
+ columns = all_columns,
+ selection = "multiple",
+ defaultExpanded = TRUE,
+ borderless = TRUE,
+ theme = reactableTheme(
+ rowSelectedStyle = list(
+ backgroundColor = "#eee",
+ boxShadow = "inset 2px 0 0 0 #ffa62d"
+ )
+ )
+ )
+ }) %>%
+ shiny::bindEvent(refresh_reactable())
+
+ # Dynamically attach observers for each editable column in the table
+ observe({
+ req(manual_slopes())
+ purrr::walk(colnames(manual_slopes()), function(colname) {
+ observeEvent(input[[paste0("edit_", colname)]], {
+ edit <- input[[paste0("edit_", colname)]]
+ edited_slopes <- manual_slopes()
+ edited_slopes[edit$row, edit$column] <- edit$value
+ manual_slopes(edited_slopes)
+ })
+ })
+ })
+
+ # --- Manual slopes override logic (moved from slope_selector_server) ---
+ if (!is.null(manual_slopes_override)) {
+ observeEvent(manual_slopes_override(), {
+ req(manual_slopes_override())
+ if (nrow(manual_slopes_override()) == 0) return(NULL)
+ log_debug_list("Manual slopes override:", manual_slopes_override())
+ override_valid <- apply(manual_slopes_override(), 1, function(r) {
+ dplyr::filter(
+ pknca_data()$conc$data,
+ PCSPEC == r["PCSPEC"],
+ USUBJID == r["USUBJID"],
+ PARAM == r["PARAM"],
+ ATPTREF == r["ATPTREF"],
+ DOSNOA == r["DOSNOA"]
+ ) %>%
+ NROW() != 0
+ }) %>%
+ all()
+ if (!override_valid) {
+ msg <- "Manual slopes not compatible with current data, leaving as default."
+ log_warn(msg)
+ showNotification(msg, type = "warning", duration = 5)
+ return(NULL)
+ }
+ manual_slopes(manual_slopes_override())
+ })
+ }
+
+ # Output: manual_slopes (reactiveVal) and refresh_reactable (for UI updates)
+ list(
+ manual_slopes = manual_slopes,
+ refresh_reactable = refresh_reactable
+ )
+ })
+}
diff --git a/inst/shiny/tests/testthat/test-utils-slope-selector.R b/inst/shiny/tests/testthat/test-utils-slope-selector.R
new file mode 100644
index 000000000..b1c2333a4
--- /dev/null
+++ b/inst/shiny/tests/testthat/test-utils-slope-selector.R
@@ -0,0 +1,264 @@
+EXISTING_FIXTURE <- data.frame(
+ TYPE = "Exclusion",
+ USUBJID = 1,
+ ATPTREF = 1,
+ PARAM = "A",
+ PCSPEC = 1,
+ RANGE = "3:6"
+)
+
+describe("check_slope_rule_overlap", {
+ it("should add new row if no overlap is detected", {
+ # different type #
+ NEW <- data.frame(
+ TYPE = "Selection",
+ USUBJID = 1,
+ ATPTREF = 1,
+ PARAM = "A",
+ PCSPEC = 1,
+ RANGE = "1:3"
+ )
+
+ expect_equal(nrow(check_slope_rule_overlap(EXISTING_FIXTURE, NEW)), 2)
+
+ # different USUBJID #
+ NEW <- data.frame(
+ TYPE = "Exclusion",
+ USUBJID = 2,
+ ATPTREF = 1,
+ PARAM = "A",
+ PCSPEC = 1,
+ RANGE = "1:3"
+ )
+
+ expect_equal(nrow(check_slope_rule_overlap(EXISTING_FIXTURE, NEW)), 2)
+
+ # different ATPTREF #
+ NEW <- data.frame(
+ TYPE = "Exclusion",
+ USUBJID = 1,
+ ATPTREF = 2,
+ PARAM = "A",
+ PCSPEC = 1,
+ RANGE = "1:3"
+ )
+
+ expect_equal(nrow(check_slope_rule_overlap(EXISTING_FIXTURE, NEW)), 2)
+ })
+
+ it("should remove overlapping points if no new points are detected", {
+ NEW <- data.frame(
+ TYPE = "Exclusion",
+ USUBJID = 1,
+ ATPTREF = 1,
+ PARAM = "A",
+ PCSPEC = 1,
+ RANGE = "4:5"
+ )
+
+ expect_equal(check_slope_rule_overlap(EXISTING_FIXTURE, NEW)$RANGE, "3,6")
+
+ NEW <- data.frame(
+ TYPE = "Exclusion",
+ USUBJID = 1,
+ ATPTREF = 1,
+ PARAM = "A",
+ PCSPEC = 1,
+ RANGE = "3:4"
+ )
+
+ expect_equal(check_slope_rule_overlap(EXISTING_FIXTURE, NEW)$RANGE, "5:6")
+ })
+
+ it("should add new points if partial overlap is detected", {
+ NEW <- data.frame(
+ TYPE = "Exclusion",
+ USUBJID = 1,
+ ATPTREF = 1,
+ PARAM = "A",
+ PCSPEC = 1,
+ RANGE = "4:9"
+ )
+
+ expect_equal(check_slope_rule_overlap(EXISTING_FIXTURE, NEW)$RANGE, "3:9")
+ })
+
+ it("should remove full row if full range of rule is removed", {
+ NEW <- data.frame(
+ TYPE = "Exclusion",
+ USUBJID = 1,
+ ATPTREF = 1,
+ PARAM = "A",
+ PCSPEC = 1,
+ RANGE = "3:6"
+ )
+
+ expect_equal(nrow(check_slope_rule_overlap(EXISTING_FIXTURE, NEW)), 0)
+ })
+
+ it("should warn if more than one range for single subject, profile and rule type is detected", {
+ EXISTING <- data.frame(
+ TYPE = "Exclusion",
+ USUBJID = 1,
+ ATPTREF = 1,
+ PARAM = "A",
+ PCSPEC = 1,
+ RANGE = "3:6"
+ )
+
+ DUPLICATE <- EXISTING %>%
+ mutate(
+ RANGE = "4:7"
+ )
+
+ expect_warning(
+ check_slope_rule_overlap(rbind(EXISTING, DUPLICATE), DUPLICATE),
+ "More than one range for single subject, profile and rule type detected."
+ )
+ })
+})
+
+describe("detect_pknca_data_changes", {
+ old_data <- FIXTURE_PKNCA_DATA
+
+ it("detects change in data when there is no previous object", {
+ new_data <- old_data
+ res <- detect_pknca_data_changes(NULL, new_data)
+ expect_true(res$in_data)
+ })
+
+ it("detects no change when old and new are identical", {
+ res <- detect_pknca_data_changes(old_data, old_data)
+ expect_false(res$in_data)
+ expect_false(res$in_hl_adj)
+ expect_false(res$in_selected_intervals)
+ })
+
+ it("detects change in data", {
+ changed_data <- old_data
+ changed_data$conc$data$VAL[1] <- 99
+ res <- detect_pknca_data_changes(old_data, changed_data)
+ expect_true(res$in_data)
+ })
+
+ it("detects change in hl_adj", {
+ changed_hl <- old_data
+ changed_hl$conc$data$exclude_half.life[2] <- TRUE
+ res <- detect_pknca_data_changes(old_data, changed_hl)
+ expect_true(res$in_hl_adj)
+ })
+
+ it("detects change in intervals", {
+ changed_int <- old_data
+ changed_int$intervals <- data.frame(ID = 1:4)
+ res <- detect_pknca_data_changes(old_data, changed_int)
+ expect_true(res$in_selected_intervals)
+ })
+})
+
+describe("handle_hl_adj_change", {
+ it("updates only affected groups in plot_outputs", {
+ # Setup dummy PKNCA data objects and plot_outputs
+ old_data <- FIXTURE_PKNCA_DATA
+ new_data <- old_data
+ new_data$conc$data <- new_data$conc$data %>%
+ mutate(
+ exclude_half.life = ifelse(
+ USUBJID == unique(USUBJID)[3] & AFRLT == 4.5,
+ TRUE,
+ exclude_half.life
+ )
+ )
+
+ # Create plots using the original and updated PKNCA data
+ old_plots <- withCallingHandlers(
+ get_halflife_plots(old_data)$plots,
+ # Because of the NA record there will be an expected warning
+ warning = function(w) {
+ if (grepl("Ignoring 1 observations", conditionMessage(w))) invokeRestart("muffleWarning")
+ }
+ )
+ new_plots <- handle_hl_adj_change(new_data, old_data, old_plots)
+
+ # Check that the plots for other groups remain unchanged
+ ix_unchanged_plots <- setdiff(seq_along(new_plots), 4)
+ expect_equal(new_plots[ix_unchanged_plots], old_plots[ix_unchanged_plots])
+
+ # Define the expected differences in the original and updated plots
+ old_plots_exp_details <- list(
+ color = c("red", "red", "green", "green", "green"),
+ size = 15,
+ symbol = c("circle", "circle", "circle", "circle", "circle"),
+ line = list(color = "rgba(255,127,14,1)")
+ )
+ new_plots_exp_details <- list(
+ color = c("red", "green", "green", "red", "green"),
+ size = 15,
+ symbol = c("circle", "circle", "circle", "x", "circle"),
+ line = list(color = "rgba(255,127,14,1)")
+ )
+ # Check that the affected plot has been updated correctly
+ expect_equal(old_plots[[4]]$x$data[[2]]$marker, old_plots_exp_details, ignore_attr = TRUE)
+ expect_equal(new_plots[[4]]$x$data[[2]]$marker, new_plots_exp_details, ignore_attr = TRUE)
+ })
+})
+
+
+describe("handle_interval_change", {
+ old_data <- FIXTURE_PKNCA_DATA
+ old_data$intervals <- old_data$intervals[1:3, ]
+ old_plots <- get_halflife_plots(old_data)$plots
+
+ it("removes plots when intervals are removed", {
+ new_data <- FIXTURE_PKNCA_DATA
+ new_data$intervals <- new_data$intervals[1, ]
+ new_plots <- handle_interval_change(new_data, old_data, old_plots)
+
+ expect_equal(length(old_plots), 3)
+ expect_equal(length(new_plots), 1)
+ expect_equal(old_plots[names(new_plots)], new_plots)
+ })
+
+ it("adds plots when intervals are added", {
+ new_data <- FIXTURE_PKNCA_DATA
+ new_data$intervals <- new_data$intervals[1:4, ]
+ new_plots <- handle_interval_change(new_data, old_data, old_plots)
+
+ expect_equal(length(old_plots), 3)
+ expect_equal(length(new_plots), 4)
+ expect_equal(new_plots[names(old_plots)], old_plots)
+ })
+})
+
+describe("arrange_plots_by_groups", {
+ it("orders plots by specified group columns", {
+ named_list <- list(
+ "B=2_A=1" = "plot1",
+ "B=1_A=2" = "plot2",
+ "B=1_A=1" = "plot3"
+ )
+ ordered <- arrange_plots_by_groups(named_list, c("B", "A"))
+ expect_equal(names(ordered), c("B=1_A=1", "B=1_A=2", "B=2_A=1"))
+ ordered2 <- arrange_plots_by_groups(named_list, c("A", "B"))
+ expect_equal(names(ordered2), c("B=1_A=1", "B=2_A=1", "B=1_A=2"))
+ })
+})
+
+describe("update_plots_with_pknca", {
+ old_data <- FIXTURE_PKNCA_DATA
+ old_data$intervals <- old_data$intervals[1:2, ]
+ old_plots <- get_halflife_plots(old_data)$plots
+
+ new_data <- old_data
+ new_data$conc$data$exclude_half.life <- TRUE
+
+ it("updates all plots when no intervals are specified", {
+ updated_plots <- update_plots_with_pknca(new_data, old_plots, NULL)
+ expect_equal(updated_plots[[1]]$x$data[[2]]$marker$symbol, rep("x", 5), ignore_attr = TRUE)
+ expect_equal(old_plots[[2]]$x$data[[2]]$marker$symbol, rep("circle", 5), ignore_attr = TRUE)
+ })
+ it("does not update any plot when the specified intervals are an empty dataframe", {
+ updated_plots <- update_plots_with_pknca(new_data, old_plots, data.frame())
+ expect_equal(updated_plots, old_plots)
+ })
+})
diff --git a/man/PKNCA_update_data_object.Rd b/man/PKNCA_update_data_object.Rd
index 04bea5d02..7bd0bb93a 100644
--- a/man/PKNCA_update_data_object.Rd
+++ b/man/PKNCA_update_data_object.Rd
@@ -11,6 +11,7 @@ PKNCA_update_data_object(
selected_profile,
selected_pcspec,
should_impute_c0 = TRUE,
+ hl_adj_rules = NULL,
exclusion_list = NULL,
keep_interval_cols = NULL
)
@@ -28,6 +29,10 @@ PKNCA_update_data_object(
\item{should_impute_c0}{Logical indicating whether to impute start concentration values}
+\item{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).}
+
\item{exclusion_list}{List of exclusion reasons and row indices to apply to the
concentration data. Each item in the list should have:
\itemize{
@@ -57,6 +62,8 @@ Step 4: Apply filtering based on user selections and partial aucs
Step 5: Impute start values if requested
+Step 6: Indicate points excluded / selected manually for half-life
+
Note*: The function assumes that the \code{adnca_data} object has been
created using the \code{PKNCA_create_data_object()} function.
}
diff --git a/man/check_slope_rule_overlap.Rd b/man/check_slope_rule_overlap.Rd
deleted file mode 100644
index c6a2d01d5..000000000
--- a/man/check_slope_rule_overlap.Rd
+++ /dev/null
@@ -1,26 +0,0 @@
-% Generated by roxygen2: do not edit by hand
-% Please edit documentation in R/utils-slope_selector.R
-\name{check_slope_rule_overlap}
-\alias{check_slope_rule_overlap}
-\title{Check overlap between existing and new slope rulesets}
-\usage{
-check_slope_rule_overlap(existing, new, slope_groups, .keep = FALSE)
-}
-\arguments{
-\item{existing}{Data frame with existing selections and exclusions.}
-
-\item{new}{Data frame with new rule to be added or removed.}
-
-\item{slope_groups}{List with column names that define the groups.}
-
-\item{.keep}{Whether to force keep fully overlapping rulesets. If FALSE, it will be assumed
-that the user wants to remove rule if new range already exists in the dataset.
-If TRUE, in that case full range will be kept.}
-}
-\value{
-Data frame with full ruleset, adjusted for new rules.
-}
-\description{
-Takes in tables with existing and incoming selections and exclusions, finds any overlap and
-differences, edits the ruleset table accordingly.
-}
diff --git a/man/check_valid_pknca_data.Rd b/man/check_valid_pknca_data.Rd
new file mode 100644
index 000000000..f685665ad
--- /dev/null
+++ b/man/check_valid_pknca_data.Rd
@@ -0,0 +1,35 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/PKNCA.R
+\name{check_valid_pknca_data}
+\alias{check_valid_pknca_data}
+\title{Checks Before Running NCA}
+\usage{
+check_valid_pknca_data(processed_pknca_data, exclusions_have_reasons = TRUE)
+}
+\arguments{
+\item{processed_pknca_data}{A processed PKNCA data object.}
+
+\item{exclusions_have_reasons}{Logical; Check that all exclusions have a reason (default: TRUE).}
+}
+\value{
+The processed_pknca_data object (input), if checks are successful.
+}
+\description{
+This function checks that:
+\enumerate{
+\item exclusions_have_reasons: all manually excluded half-life points in the concentration data
+have a non-empty reason provided. If any exclusions are missing a reason, it stops with an error
+and prints the affected rows (group columns and time column).
+}
+}
+\details{
+\itemize{
+\item If any excluded half-life points are missing a reason, an error is thrown.
+\item If no exclusions or all have reasons, the function returns the input object.
+\item Used to enforce good practice/documentation before NCA calculation.
+}
+}
+\examples{
+# Suppose processed_pknca_data is a valid PKNCA data object
+# check_valid_pknca_data(processed_pknca_data)
+}
diff --git a/man/dot-apply_slope_rules.Rd b/man/dot-apply_slope_rules.Rd
deleted file mode 100644
index 78d862412..000000000
--- a/man/dot-apply_slope_rules.Rd
+++ /dev/null
@@ -1,25 +0,0 @@
-% Generated by roxygen2: do not edit by hand
-% Please edit documentation in R/utils-slope_selector.R
-\name{.apply_slope_rules}
-\alias{.apply_slope_rules}
-\title{Apply Slope Rules to Update Data}
-\usage{
-.apply_slope_rules(data, slopes, slope_groups)
-}
-\arguments{
-\item{data}{A list containing concentration data (\code{data$conc$data}) with columns that
-need to be updated based on the slope rules.}
-
-\item{slopes}{A data frame containing slope rules, including \code{TYPE}, \code{RANGE},
-and \code{REASON} columns. May also have grouping columns (expected to match slope_groups)}
-
-\item{slope_groups}{A character vector specifying the group columns used for filtering.}
-}
-\value{
-description The modified \code{data} object with updated inclusion/exclusion flags
-and reasons in \code{data$conc$data}.
-}
-\description{
-This function iterates over the given slopes and updates the \code{data$conc$data} object
-by setting inclusion or exclusion flags based on the slope conditions.
-}
diff --git a/man/filter_slopes.Rd b/man/filter_slopes.Rd
deleted file mode 100644
index 5475e0482..000000000
--- a/man/filter_slopes.Rd
+++ /dev/null
@@ -1,29 +0,0 @@
-% Generated by roxygen2: do not edit by hand
-% Please edit documentation in R/utils-slope_selector.R
-\name{filter_slopes}
-\alias{filter_slopes}
-\title{Filter dataset based on slope selections and exclusions}
-\usage{
-filter_slopes(data, slopes, profiles, slope_groups, check_reasons = FALSE)
-}
-\arguments{
-\item{data}{Data to filter. Must be \code{PKNCAdata} list, containing the \code{conc} element with
-\code{PKNCAconc} list and appropriate data frame included under data.}
-
-\item{slopes}{A data frame containing slope rules, including \code{TYPE}, \code{RANGE},
-and \code{REASON} columns. May also have grouping columns (expected to match slope_groups)}
-
-\item{profiles}{List with available profiles for each \code{SUBJECT}.}
-
-\item{slope_groups}{List with column names that define the groups.}
-
-\item{check_reasons}{Whether to check if all selections have REASONS stated. If this is \code{TRUE}
-and not all selections have a reason provided, an error will be thrown.}
-}
-\value{
-Original dataset, with \code{is.included.hl}, \code{is.excluded.hl} and \code{exclude_half.life}
-columns modified in accordance to the provided slope filters.
-}
-\description{
-This function filters main dataset based on provided slope selections an exclusions.
-}
diff --git a/man/get_halflife_plots.Rd b/man/get_halflife_plots.Rd
new file mode 100644
index 000000000..74a18f9c5
--- /dev/null
+++ b/man/get_halflife_plots.Rd
@@ -0,0 +1,19 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/get_halflife_plots.R
+\name{get_halflife_plots}
+\alias{get_halflife_plots}
+\title{Create a Plotly Half-life Plot}
+\usage{
+get_halflife_plots(pknca_data, add_annotations = TRUE)
+}
+\arguments{
+\item{pknca_data}{PKNCA data object}
+
+\item{add_annotations}{Logical, whether to add the subtitle annotation}
+}
+\value{
+A list with plotly objects and data
+}
+\description{
+Generates a plotly plot for NCA half-life visualization, with a fit line and scatter points.
+}
diff --git a/man/lambda_slope_plot.Rd b/man/lambda_slope_plot.Rd
deleted file mode 100644
index be30c7b39..000000000
--- a/man/lambda_slope_plot.Rd
+++ /dev/null
@@ -1,98 +0,0 @@
-% Generated by roxygen2: do not edit by hand
-% Please edit documentation in R/lambda_slope_plot.R
-\name{lambda_slope_plot}
-\alias{lambda_slope_plot}
-\title{Generate a Lambda Slope Plot}
-\usage{
-lambda_slope_plot(
- conc_pknca_df,
- row_values,
- myres = myres,
- r2adj_threshold = 0.7,
- time_column = "AFRLT"
-)
-}
-\arguments{
-\item{conc_pknca_df}{Data frame containing the concentration data
-(default is \code{mydata$conc$data}).}
-
-\item{row_values}{A list containing the values for the column_names used for filtering.}
-
-\item{myres}{A PKNCAresults object containing the results of the NCA analysis}
-
-\item{r2adj_threshold}{Numeric value representing the R-squared adjusted threshold for
-determining the subtitle color (default is 0.7).}
-
-\item{time_column}{The name of the time column in the concentration data frame.
-(default is "AFRLT").}
-}
-\value{
-A plotly object representing the lambda slope plot.
-}
-\description{
-This function generates a lambda slope plot using pharmacokinetic data. It calculates relevant
-lambda parameters and visualizes the data points used for lambda calculation, along with
-a linear regression line and additional plot annotations.
-}
-\details{
-The function performs the following steps:
-\itemize{
-\item{Creates duplicates of the pre-dose and last doses of concentration data.}
-\item{Filters and arranges the input data to obtain relevant lambda calculation information.}
-\item{Identifies the data points used for lambda calculation.}
-\item{Calculates the fitness, intercept, and time span of the half-life estimate.}
-\item{
-Determines the subtitle color based on the R-squared adjusted value and half-life estimate.
-}
-\item{
-Generates a ggplot object with the relevant data points,
-linear regression line, and annotations.
-}
-\item{Converts the ggplot object to a plotly object for interactive visualization.}
-}
-}
-\examples{
-\donttest{
-if (interactive()) {
- # Load a small packaged example dataset
- adnca <- read.csv(system.file("shiny/data/example-ADNCA.csv", package = "aNCA"))
-
- # Subset to a single subject to keep the example fast
- subj1 <- unique(adnca$USUBJID)[3]
- dose1 <- unique(adnca$DOSNOP)[1]
- adnca_sub <- adnca[adnca$USUBJID == subj1 & adnca$DOSNOP == dose1, ]
-
- # Analysis details (minimal example)
- method <- "lin up/log down"
- params <- c("cmax", "tmax", "auclast", "aucinf.obs")
- analytes <- unique(adnca_sub$PARAM)
- dosnos <- unique(adnca_sub$ATPTREF)
- pcspecs <- unique(adnca_sub$PCSPEC)
- auc_data <- data.frame(start_auc = numeric(), end_auc = numeric())
-
- # Build a minimal PKNCA data object and run NCA (kept in \donttest for CRAN safety)
- pknca_data <- PKNCA_create_data_object(adnca_sub)
- pknca_data <- create_start_impute(pknca_data)
- pknca_data <- PKNCA_update_data_object(
- pknca_data,
- auc_data = auc_data,
- method = method,
- params = params,
- selected_analytes = analytes,
- selected_profile = dosnos,
- selected_pcspec = pcspecs
- )
-
- pknca_res <- PKNCA_calculate_nca(pknca_data)
-
- # Create the lambda slope plot for the example subject
- plot <- lambda_slope_plot(
- conc_pknca_df = pknca_data$conc$data,
- row_values = list(USUBJID = subj1, STUDYID = unique(adnca_sub$STUDYID)[1], DOSNOA = 1),
- myres = pknca_res,
- r2adj_threshold = 0.7
- )
- print(plot)
-}
-}
-}
diff --git a/man/pkcg01.Rd b/man/pkcg01.Rd
index 4116a389f..6295acb00 100644
--- a/man/pkcg01.Rd
+++ b/man/pkcg01.Rd
@@ -93,7 +93,7 @@ adnca <- subset(adnca, adnca$USUBJID \%in\% unique(adnca$USUBJID)[c(1, 2)])
attr(adnca[["AFRLT"]], "label") <- "Actual time from first dose"
attr(adnca[["AVAL"]], "label") <- "Analysis val"
-plots_lin <- pkcg01(adnca = adnca, xmax = 1)
+plots_lin <- pkcg01(adnca = adnca, xmax = 1, scale = "LIN")
}
\author{
diff --git a/man/update_pknca_with_rules.Rd b/man/update_pknca_with_rules.Rd
new file mode 100644
index 000000000..d5641673b
--- /dev/null
+++ b/man/update_pknca_with_rules.Rd
@@ -0,0 +1,19 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/utils-slope_selector.R
+\name{update_pknca_with_rules}
+\alias{update_pknca_with_rules}
+\title{Apply Slope Rules to Update Data}
+\usage{
+update_pknca_with_rules(data, slopes)
+}
+\arguments{
+\item{data}{PKNCA data object}
+
+\item{slopes}{Data frame of slope rules (TYPE, RANGE, REASON, group columns)}
+}
+\value{
+Modified data object with updated flags
+}
+\description{
+Iterates over the given rules and updates the PKNCA object setting inclusion/exclusion flags.
+}
diff --git a/tests/testthat/setup.R b/tests/testthat/setup.R
index 5e0d28425..6ebb17d98 100644
--- a/tests/testthat/setup.R
+++ b/tests/testthat/setup.R
@@ -347,7 +347,9 @@ base::local({
FIXTURE_PKNCA_DATA <<- withCallingHandlers(
PKNCA::PKNCAdata(
data.conc = PKNCA::PKNCAconc(FIXTURE_CONC_DATA, AVAL ~ AFRLT | PCSPEC + USUBJID / PARAM,
- concu = "AVALU", timeu = "RRLTU"),
+ concu = "AVALU", timeu = "RRLTU",
+ exclude_half.life = "exclude_half.life",
+ include_half.life = "include_half.life"),
data.dose = PKNCA::PKNCAdose(FIXTURE_DOSE_DATA, DOSEA ~ AFRLT | USUBJID,
route = "ROUTE", duration = "ADOSEDUR"),
units = units_table
diff --git a/tests/testthat/test-PKNCA.R b/tests/testthat/test-PKNCA.R
index 6b7e109fa..d4dabc6ab 100644
--- a/tests/testthat/test-PKNCA.R
+++ b/tests/testthat/test-PKNCA.R
@@ -380,6 +380,36 @@ describe("select_level_grouping_cols", {
})
})
+describe("check_valid_pknca_data", {
+ pknca_data <- FIXTURE_PKNCA_DATA
+
+ it("returns the input object if no issues are found", {
+ # Without exclusions for half-life
+ result <- check_valid_pknca_data(pknca_data)
+ expect_identical(result, pknca_data)
+ })
+
+ # Make checks for half-life exclusions ----
+ pknca_data_with_excl <- pknca_data
+ excl_hl_col <- pknca_data_with_excl$conc$columns$exclude_half.life
+ pknca_data_with_excl$conc$data[1, excl_hl_col] <- TRUE
+
+ it("does not throw an error if exclusions for half-life include a REASON value", {
+ pknca_data_with_excl$conc$data$REASON <- "Test reason"
+ expect_no_error(
+ check_valid_pknca_data(pknca_data_with_excl, exclusions_have_reasons = TRUE)
+ )
+ })
+
+ it("throws an error if exclusions for half-life do not include a REASON value", {
+ pknca_data_with_excl$conc$data$REASON <- ""
+ expect_error(
+ check_valid_pknca_data(pknca_data_with_excl, exclusions_have_reasons = TRUE),
+ "No reason provided for the following half-life exclusions:"
+ )
+ })
+})
+
# Tests for add_exclusion_reasons
describe("add_exclusion_reasons", {
it("adds a single exclusion reason to specified rows", {
diff --git a/tests/testthat/test-get_halflife_plots.R b/tests/testthat/test-get_halflife_plots.R
new file mode 100644
index 000000000..d81ce49ee
--- /dev/null
+++ b/tests/testthat/test-get_halflife_plots.R
@@ -0,0 +1,130 @@
+# Shared fixture for all tests
+base_pknca <- FIXTURE_PKNCA_DATA
+
+describe("get_halflife_plot", {
+ it("returns a list of plotly objects with valid input", {
+ plots <- withCallingHandlers(
+ get_halflife_plots(base_pknca)[["plots"]],
+ # Ignore the warning associated with the expected missing records
+ warning = function(w) {
+ if (grepl("Ignoring 1 observations", conditionMessage(w))) invokeRestart("muffleWarning")
+ }
+ )
+ expect_type(plots, "list")
+ expect_true(length(plots) >= 1)
+ expect_s3_class(plots[[1]], "plotly")
+ expect_true("layout" %in% names(plots[[1]]$x))
+ })
+
+ it("warns and returns empty list when no groups present", {
+ pknca_no_groups <- base_pknca
+ pknca_no_groups$conc$data <- pknca_no_groups$conc$data[0, ]
+ plots <- get_halflife_plots(pknca_no_groups)[["plots"]]
+ expect_type(plots, "list")
+ expect_length(plots, 0)
+ })
+
+ it("renders markers, colors and shapes with no exclusion/inclusion", {
+ pknca_no_excl_incl <- base_pknca
+ pknca_no_excl_incl$conc$data$exclude_half.life <- FALSE
+ pknca_no_excl_incl$conc$data$include_half.life <- FALSE
+ plots <- withCallingHandlers(
+ get_halflife_plots(pknca_no_excl_incl)[["plots"]],
+ # Ignore the warning associated with the expected missing records
+ warning = function(w) {
+ if (grepl("Ignoring 1 observations", conditionMessage(w))) invokeRestart("muffleWarning")
+ }
+ )
+ expect_true(length(plots) >= 1)
+ plot_data <- plots[[1]]$x$data[[2]]
+ expect_true(all(plot_data$marker$color == "black"))
+ expect_true(all(plot_data$marker$symbol == "circle"))
+ })
+
+ it("renders markers, colors and shapes with exclusion of a lambda.z point", {
+ pknca_excl <- base_pknca
+ pknca_excl$intervals <- pknca_excl$intervals[2, ]
+ pknca_excl_with_excl <- pknca_excl
+ pknca_excl_with_excl$conc$data <- pknca_excl$conc$data %>%
+ mutate(
+ exclude_half.life = ifelse(
+ USUBJID == unique(USUBJID)[2] & AFRLT == 2.5,
+ TRUE,
+ FALSE
+ )
+ )
+ plots <- get_halflife_plots(pknca_excl)[["plots"]]
+ plots_with_excl <- get_halflife_plots(pknca_excl_with_excl)[["plots"]]
+
+ plots_details <- plots[[1]]$x$data[[2]]$marker
+ exp_plots_details <- list(
+ color = c("red", "red", "green", "green", "green"),
+ size = 15,
+ symbol = c("circle", "circle", "circle", "circle", "circle"),
+ line = list(color = "rgba(255,127,14,1)")
+ )
+ plots_with_excl_details <- plots_with_excl[[1]]$x$data[[2]]$marker
+ exp_plots_details_with_excl <- list(
+ color = c("red", "red", "red", "green", "green"),
+ size = 15,
+ symbol = c("circle", "circle", "x", "circle", "circle"),
+ line = list(color = "rgba(255,127,14,1)")
+ )
+
+ expect_equal(plots_details, exp_plots_details, ignore_attr = TRUE)
+ expect_equal(plots_with_excl_details, exp_plots_details_with_excl, ignore_attr = TRUE)
+ })
+
+ it("renders markers, colors and shapes with inclusion of lambda.z points", {
+ pknca_incl <- base_pknca
+ pknca_incl$intervals <- pknca_incl$intervals[3, ]
+ pknca_incl$conc$data$exclude_half.life <- FALSE
+ pknca_incl$conc$data$include_half.life <- NA
+ pknca_incl_with_incl <- pknca_incl
+ pknca_incl_with_incl$conc$data <- pknca_incl$conc$data %>%
+ mutate(
+ include_half.life = ifelse(
+ USUBJID == unique(USUBJID)[3] & AFRLT >= 0.5,
+ TRUE,
+ FALSE
+ )
+ )
+ plots <- get_halflife_plots(pknca_incl)[["plots"]]
+ plots_with_incl <- get_halflife_plots(pknca_incl_with_incl)[["plots"]]
+
+ plots_details <- plots[[1]]$x$data[[2]]$marker
+ exp_plots_details <- list(
+ color = c("red", "red", "green", "green", "green"),
+ size = 15,
+ symbol = c("circle", "circle", "circle", "circle", "circle"),
+ line = list(color = "rgba(255,127,14,1)")
+ )
+ plots_with_incl_details <- plots_with_incl[[1]]$x$data[[2]]$marker
+ exp_plots_details_with_incl <- list(
+ color = c("green", "green", "green", "green", "green"),
+ size = 15,
+ symbol = c("circle", "circle", "circle", "circle", "circle"),
+ line = list(color = "rgba(255,127,14,1)")
+ )
+
+ expect_equal(plots_details, exp_plots_details, ignore_attr = TRUE)
+ expect_equal(plots_with_incl_details, exp_plots_details_with_incl, ignore_attr = TRUE)
+ })
+
+ it("renders markers, colors and shapes with exclusion column missing still works", {
+ pknca_no_excl_col <- base_pknca
+ pknca_no_excl_col$intervals <- pknca_no_excl_col$intervals[2, ]
+ pknca_no_excl_col$conc$data$exclude_half.life <- NULL
+ pknca_no_excl_col$conc$columns$exclude_half.life <- NULL
+ plots <- get_halflife_plots(pknca_no_excl_col)[["plots"]]
+
+ plots_details <- plots[[1]]$x$data[[2]]$marker
+ exp_plots_details <- list(
+ color = c("red", "red", "green", "green", "green"),
+ size = 15,
+ symbol = c("circle", "circle", "circle", "circle", "circle"),
+ line = list(color = "rgba(255,127,14,1)")
+ )
+ expect_equal(plots_details, exp_plots_details, ignore_attr = TRUE)
+ })
+})
diff --git a/tests/testthat/test-lambda_slope_plot.R b/tests/testthat/test-lambda_slope_plot.R
deleted file mode 100644
index a3b8a63a6..000000000
--- a/tests/testthat/test-lambda_slope_plot.R
+++ /dev/null
@@ -1,144 +0,0 @@
-describe("lambda_slope_plot", {
-
- conc_pknca_df <- FIXTURE_PKNCA_DATA$conc$data %>%
- # ToDo: The currerent lambda_slope_plot
- # has additional non-neccesary assumptions
- mutate(TIME = AFRLT,
- PCSTRESU = AVALU)
-
- myres <- FIXTURE_PKNCA_RES
- myres$result <- myres$result %>%
- mutate(PPTESTCD = translate_terms(
- PPTESTCD, "PPTESTCD", "PKNCA"
- ))
-
- row_values <- myres$data$intervals %>%
- filter(half.life) %>%
- select(any_of(c(
- unname(unlist(myres$data$conc$columns$groups)),
- "ATPTREF", "DOSNOA"
- ))) %>%
- filter(USUBJID == 5)
-
- it("returns a plotly object with valid input", {
- plotly_output <- lambda_slope_plot(
- conc_pknca_df = conc_pknca_df,
- row_values = row_values,
- myres = myres,
- r2adj_threshold = 0.7
- )
-
- expect_s3_class(plotly_output, "plotly")
- expect_true("layout" %in% names(plotly_output$x))
- })
-
- it("handles NA in lambda.z.n.points gracefully", {
- myres_mod <- myres
-
- # Modify lambda.z.n.points to NA for the target row
- myres_mod$result <- myres_mod$result %>%
- mutate(
- PPSTRES = ifelse(
- PPTESTCD == "lambda.z.n.points" &
- USUBJID == row_values$USUBJID,
- NA_real_,
- PPSTRES
- )
- )
-
- plotly_output <- lambda_slope_plot(
- conc_pknca_df = conc_pknca_df,
- row_values = row_values,
- myres = myres_mod
- )
-
- expect_s3_class(plotly_output, "plotly")
- })
-
- it("warns and returns empty plot when AVAL <= 0", {
- conc_modified <- conc_pknca_df
- conc_modified$AVAL <- -1
-
- expect_warning({
- empty_plot <- lambda_slope_plot(
- conc_pknca_df = conc_modified,
- row_values = row_values,
- myres = myres
- )
- expect_s3_class(empty_plot, "plotly")
- }, "Not enough data for plotting")
- })
-
- it("returns without error and gives expected warning when plot_data has 0 rows", {
- conc_modified <- conc_pknca_df %>%
- mutate(
- AVAL = ifelse(
- USUBJID == row_values$USUBJID,
- -1,
- AVAL
- )
- )
-
- expect_warning(
- lambda_slope_plot(
- conc_pknca_df = conc_modified,
- row_values = row_values,
- myres = myres
- ),
- "Not enough data for plotting"
- )
- })
-
- it("shows warning when Cmax is included in lambda estimation", {
- # Copy inputs
- conc_modified <- conc_pknca_df
- myres_modified <- myres
-
- # Use the same subject for consistency
- test_id <- myres$data$intervals %>%
- filter(half.life) %>%
- select(any_of(c(
- unname(unlist(myres$data$conc$columns$groups)),
- "ATPTREF", "DOSNOA"
- ))) %>%
- filter(USUBJID == 5)
-
- row_values <- test_id %>% as.list()
-
- # Get the corresponding Tmax value
- tmax_value <- myres_modified$result %>%
- filter(PPTESTCD == "tmax") %>%
- filter(
- USUBJID == row_values$USUBJID
- ) %>%
- pull(PPSTRES)
-
- # Force lambda.z.time.first to be *equal* to tmax, triggering Cmax inclusion
- myres_modified$result <- myres_modified$result %>%
- mutate(
- PPSTRES = ifelse(
- PPTESTCD == "lambda.z.time.first" &
- USUBJID == row_values$USUBJID,
- tmax_value,
- PPSTRES
- )
- )
-
- # Run plot function
- plotly_output <- lambda_slope_plot(
- conc_pknca_df = conc_modified,
- row_values = row_values,
- myres = myres_modified
- )
-
- # Check for Cmax warning text
- annotations <- plotly_output$x$layout$annotations
- cmax_warn <- any(sapply(annotations, function(a) {
- is.list(a) && !is.null(a$text) &&
- grepl("Cmax should not be included in lambda calculation", a$text)
- }))
-
- expect_true(cmax_warn)
- })
-
-})
diff --git a/tests/testthat/test-utils-slope_selector.R b/tests/testthat/test-utils-slope_selector.R
index daae6610b..1a54c7a78 100644
--- a/tests/testthat/test-utils-slope_selector.R
+++ b/tests/testthat/test-utils-slope_selector.R
@@ -1,101 +1,3 @@
-DATA_FIXTURE <- list(
- conc = list(
- data = data.frame(
- STUDYID = 1,
- PCSPEC = 1,
- USUBJID = rep(1:4, each = 4),
- ATPTREF = 1,
- IX = rep(1:4, times = 4),
- PARAM = rep("A", 16),
- is.included.hl = FALSE,
- is.excluded.hl = FALSE,
- exclude_half.life = FALSE,
- REASON = ""
- )
- )
-)
-
-DOSNOS_FIXTURE <- data.frame(
- USUBJID = rep(1:4, each = 1),
- PARAM = rep("A", 4),
- PCSPEC = rep(1, 4),
- ATPTREF = rep(1, 4)
-)
-
-slope_groups <- c("USUBJID", "PARAM", "PCSPEC", "ATPTREF")
-
-describe(".filter_slopes", {
- it("should handle slope selection", {
- selection <- data.frame(
- TYPE = rep("Selection", 2),
- USUBJID = c(1, 3),
- ATPTREF = c(1, 1),
- PARAM = c("A", "A"),
- PCSPEC = c(1, 1),
- RANGE = c("1:3", "2:4"),
- REASON = "Test selection"
- )
-
- res <- filter_slopes(DATA_FIXTURE, selection, DOSNOS_FIXTURE, slope_groups)
-
- expect_true(all(res$is.included.hl[c(1:3, 6:8)]))
- expect_true(all(res$REASON[c(1:3, 6:8)] == "Test selection"))
- })
-
- it("should handle slope exclusion", {
- exclusion <- data.frame(
- TYPE = rep("Exclusion", 2),
- USUBJID = c(2, 4),
- ATPTREF = c(1, 1),
- PARAM = c("A", "A"),
- PCSPEC = c(1, 1),
- RANGE = c("1:2", "2:3"),
- REASON = "Test exclusion"
- )
-
- res <- filter_slopes(DATA_FIXTURE, exclusion, DOSNOS_FIXTURE, slope_groups)
-
- expect_true(all(res$is.excluded.hl[c(5, 6, 14, 15)]))
- expect_true(all(res$REASON[c(5, 6, 14, 15)] == "Test exclusion"))
- })
-
- it("should throw an error for invalid data", {
-
- expect_error(filter_slopes(NULL, NULL, DOSNOS_FIXTURE), "Please provide valid data.")
- expect_error(filter_slopes(list(), NULL, DOSNOS_FIXTURE), "Please provide valid data.")
- expect_error(
- filter_slopes(list(conc = list()), NULL, DOSNOS_FIXTURE), "Please provide valid data."
- )
- expect_error(
- filter_slopes(list(conc = list()), NULL, DOSNOS_FIXTURE), "Please provide valid data."
- )
- })
-
- it("should throw an error if reasons are missing", {
- selection <- data.frame(
- TYPE = rep("Exclusion", 2),
- USUBJID = c(1, 3),
- ATPTREF = c(1, 1),
- PARAM = c("A", "A"),
- PCSPEC = c(1, 1),
- RANGE = c("1:3", "2:4"),
- REASON = ""
- )
-
- expect_error(
- filter_slopes(DATA_FIXTURE, selection, DOSNOS_FIXTURE, slope_groups, TRUE),
- "^No reason provided for the following exclusions*"
- )
- })
-
- it("should return data unchanged if no slopes are provided", {
- res_null <- filter_slopes(DATA_FIXTURE, NULL, DOSNOS_FIXTURE, slope_groups)
- res_empty <- filter_slopes(DATA_FIXTURE, data.frame(), DOSNOS_FIXTURE, slope_groups)
- expect_equal(res_null, DATA_FIXTURE)
- expect_equal(res_empty, DATA_FIXTURE)
- })
-})
-
EXISTING_FIXTURE <- data.frame(
TYPE = "Exclusion",
USUBJID = 1,
@@ -105,117 +7,49 @@ EXISTING_FIXTURE <- data.frame(
RANGE = "3:6"
)
-describe("check_slope_rule_overlap", {
- it("should add new row if no overlap is detected", {
- # different type #
- NEW <- data.frame(
- TYPE = "Selection",
- USUBJID = 1,
- ATPTREF = 1,
- PARAM = "A",
- PCSPEC = 1,
- RANGE = "1:3"
- )
-
- expect_equal(nrow(check_slope_rule_overlap(EXISTING_FIXTURE, NEW, slope_groups)), 2)
-
- # different USUBJID #
- NEW <- data.frame(
- TYPE = "Exclusion",
- USUBJID = 2,
- ATPTREF = 1,
- PARAM = "A",
- PCSPEC = 1,
- RANGE = "1:3"
- )
-
- expect_equal(nrow(check_slope_rule_overlap(EXISTING_FIXTURE, NEW, slope_groups)), 2)
-
- # different ATPTREF #
- NEW <- data.frame(
- TYPE = "Exclusion",
- USUBJID = 1,
- ATPTREF = 2,
- PARAM = "A",
- PCSPEC = 1,
- RANGE = "1:3"
- )
-
- expect_equal(nrow(check_slope_rule_overlap(EXISTING_FIXTURE, NEW, slope_groups)), 2)
- })
+describe("update_pknca_with_rules", {
+ old_data <- FIXTURE_PKNCA_DATA
+ group1 <- old_data$intervals %>%
+ select(any_of(c(group_vars(old_data), "start", "end"))) %>%
+ .[1, ]
- it("should remove overlapping points if no new points are detected", {
- NEW <- data.frame(
- TYPE = "Exclusion",
- USUBJID = 1,
- ATPTREF = 1,
- PARAM = "A",
- PCSPEC = 1,
- RANGE = "4:5"
+ it("applies selection and exclusion rules to data", {
+ slopes_incl <- cbind(
+ data.frame(TYPE = "Selection", ID = 1, RANGE = "2:4", REASON = "because I want to"),
+ group1
)
-
- expect_equal(check_slope_rule_overlap(EXISTING_FIXTURE, NEW, slope_groups)$RANGE, "3,6")
-
- NEW <- data.frame(
- TYPE = "Exclusion",
- USUBJID = 1,
- ATPTREF = 1,
- PARAM = "A",
- PCSPEC = 1,
- RANGE = "3:4"
+ slopes_excl <- cbind(
+ data.frame(TYPE = "Exclusion", ID = 1, RANGE = "2:4", REASON = "always good reasons"),
+ group1
)
- expect_equal(check_slope_rule_overlap(EXISTING_FIXTURE, NEW, slope_groups)$RANGE, "5:6")
+ new_with_incl <- update_pknca_with_rules(old_data, slopes_incl)
+ new_with_excl <- update_pknca_with_rules(old_data, slopes_excl)
- })
-
- it("should add new points of partial overlap is detected", {
- NEW <- data.frame(
- TYPE = "Exclusion",
- USUBJID = 1,
- ATPTREF = 1,
- PARAM = "A",
- PCSPEC = 1,
- RANGE = "4:9"
+ old_have_points_na <- all(is.na(old_data$conc$data %>%
+ filter(USUBJID == group1$USUBJID, AFRLT >= 2, AFRLT <= 4) %>%
+ pull(include_half.life))
)
+ new_have_points_incl <- all(new_with_incl$conc$data %>%
+ filter(USUBJID == group1$USUBJID, AFRLT >= 2, AFRLT <= 4) %>%
+ pull(include_half.life))
- expect_equal(check_slope_rule_overlap(EXISTING_FIXTURE, NEW, slope_groups)$RANGE, "3:9")
+ new_have_points_excl <- all(new_with_excl$conc$data %>%
+ filter(USUBJID == group1$USUBJID, AFRLT >= 2, AFRLT <= 4) %>%
+ pull(exclude_half.life))
+ expect_true(all(old_have_points_na, new_have_points_incl, new_have_points_excl))
})
- it("should remove full row if full range of rule is removed", {
- NEW <- data.frame(
- TYPE = "Exclusion",
- USUBJID = 1,
- ATPTREF = 1,
- PARAM = "A",
- PCSPEC = 1,
- RANGE = "3:6"
+ it("returns an error for invalid rule types", {
+ slopes_invalid <- cbind(
+ data.frame(TYPE = "Invalid", ID = 1, RANGE = "2:4", REASON = "invalid type"),
+ group1
)
-
- expect_equal(nrow(check_slope_rule_overlap(EXISTING_FIXTURE, NEW, slope_groups)), 0)
-
- })
-
- it("should warn if more than one range for single subject, profile and rule type is detected", {
- EXISTING <- data.frame(
- TYPE = "Exclusion",
- USUBJID = 1,
- ATPTREF = 1,
- PARAM = "A",
- PCSPEC = 1,
- RANGE = "3:6"
- )
-
- DUPLICATE <- EXISTING %>%
- mutate(
- RANGE = "4:7"
- )
-
- expect_warning(
- check_slope_rule_overlap(rbind(EXISTING, DUPLICATE), DUPLICATE, slope_groups),
- "More than one range for single subject, profile and rule type detected."
+ expect_error(
+ update_pknca_with_rules(old_data, slopes_invalid),
+ regexp = "Unknown TYPE in slopes: Invalid"
)
})
})