diff --git a/DESCRIPTION b/DESCRIPTION index 1c4abbb53..415e600fa 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,6 +1,6 @@ Package: aNCA Title: (Pre-)Clinical NCA in a Dynamic Shiny App -Version: 0.1.0.9135 +Version: 0.1.0.9136 Authors@R: c( person("Ercan", "Suekuer", email = "ercan.suekuer@roche.com", role = "aut", comment = c(ORCID = "0009-0001-1626-1526")), @@ -31,7 +31,6 @@ Imports: ggplot2, glue, magrittr, - methods, PKNCA (>= 0.12.1), plotly (>= 4.11.0), purrr, diff --git a/NAMESPACE b/NAMESPACE index 82a5ff680..9ec13ba92 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -121,7 +121,7 @@ importFrom(dplyr,summarise) importFrom(dplyr,sym) importFrom(dplyr,ungroup) importFrom(dplyr,where) -importFrom(formatters,"var_labels<-") +importFrom(formatters,`var_labels<-`) importFrom(formatters,var_labels) importFrom(ggplot2,aes) importFrom(ggplot2,facet_wrap) @@ -139,7 +139,6 @@ importFrom(ggplot2,theme_bw) importFrom(glue,glue) importFrom(grid,convertUnit) importFrom(magrittr,`%>%`) -importFrom(methods,is) importFrom(plotly,add_lines) importFrom(plotly,add_trace) importFrom(plotly,ggplotly) diff --git a/NEWS.md b/NEWS.md index e55bfd791..be06c547c 100644 --- a/NEWS.md +++ b/NEWS.md @@ -44,10 +44,13 @@ * Add x/y axis limits for the exploration plots (#817) and facet titles including subject count (#894) * Settings upload and processing is flexible, so non-data specific template settings can be uploaded (#993) * Mapping will allow custom numeric input values instead of columns for `ADOSEDUR` and `TRTRINT` (#1051) -* Help buttons have been included/updated for most App sections: `Parameter Selection`, `Slope Selector`, `Additional Analysis` and `Partial Interval calculations` (#975) +* Help buttons have been included/updated for most App sections: `Parameter Selection`, + `Slope Selector`, `Additional Analysis` and `Partial Interval calculations` (#975) * Removed `methods`, `scales`, and `stringr` from package dependencies, replacing all usages with base R equivalents (#1108) * SelectInputs updated using a new function to ensure all widgets include variable labels. (#899) - +* Export modal now allows users to select which slide sections (mean plots, statistics, + line plots, box plots, individual plots/parameters, additional analysis) to include in + PPTX and HTML exports; box plot parameters are also configurable (#972) ## Bugs fixed * SASS compilation moved from runtime (`app.R`) to a `data-raw/compile_css.R` script, fixing startup crashes on read-only deployments (#1107) diff --git a/R/officer-utils.R b/R/officer-utils.R index 9e4c4a54e..5d361e31d 100644 --- a/R/officer-utils.R +++ b/R/officer-utils.R @@ -33,9 +33,7 @@ add_pptx_sl_title <- function(pptx, title) { add_pptx_sl_plottable <- function(pptx, df, plot) { officer::add_slide(pptx, layout = "Content with Caption") %>% officer::ph_with(value = plot, location = "Content Placeholder 1") %>% - officer::ph_with( - value = flextable::flextable(df, cwidth = 1), location = "Table Placeholder 1" - ) + officer::ph_with(value = flextable::flextable(df, cwidth = 1), location = "Table Placeholder 1") } #' Add a slide with a table only @@ -75,6 +73,157 @@ add_pptx_sl_plot <- function(pptx, plot) { officer::ph_with(value = plot, location = "Picture Placeholder 2") } +#' Add individual-subject slides for one dose group to a pptx object +#' @param pptx rpptx object +#' @param group_data Single element from res_dose_slides +#' @param group_index Integer index of the dose group +#' @param in_sections Function(id) returning TRUE when id is selected +#' @return List with updated pptx and n_slides count +#' @keywords internal +#' @noRd +.add_pptx_ind_slides <- function(pptx, group_data, group_index, in_sections) { + if (!in_sections("ind_plots") && !in_sections("ind_params")) { + return(list(pptx = pptx, n_slides = 0)) + } + if (length(group_data$ind_params) == 0 && length(group_data$ind_plots) == 0) { + return(list(pptx = pptx, n_slides = 0)) + } + pptx <- add_pptx_sl_table( + pptx, group_data$info, + title = paste0("Group ", group_index, " (individual)"), + subtitle = paste(group_data$group), + footer = "" + ) + pptx <- purrr::reduce( + names(group_data$ind_params), + function(pptx, subj) { + if (in_sections("ind_plots") && in_sections("ind_params")) { + add_pptx_sl_plottable(pptx, + df = group_data$ind_params[[subj]], + plot = group_data$ind_plots[[subj]]) + } else if (in_sections("ind_plots")) { + add_pptx_sl_plot(pptx, plot = group_data$ind_plots[[subj]]) + } else { + add_pptx_sl_table(pptx, df = group_data$ind_params[[subj]], footer = "") + } + }, + .init = pptx + ) + n_slides <- 1 + length(group_data$ind_params) + list(pptx = pptx, n_slides = n_slides) +} + +#' Filter an additional_analysis list to non-empty data frames, +#' optionally restricted to slide_sections +#' @param additional_analysis Named list of data frames +#' @param slide_sections Character vector of selected section IDs, or NULL for all +#' @return Filtered named list +#' @keywords internal +#' @noRd +.filter_additional_analysis <- function(additional_analysis, slide_sections) { + if (is.null(additional_analysis)) return(NULL) + result <- Filter(function(x) is.data.frame(x) && nrow(x) > 0, additional_analysis) + if (!is.null(slide_sections)) { + result <- result[names(result) %in% slide_sections] + } + result +} + +#' Add the main summary slide (meanplot / statistics / both) for a dose group +#' @param pptx An officer pptx object. +#' @param group_data One element of res_dose_slides (a dose group). +#' @param i Integer index of this dose group. +#' @param in_sections Function(id) returning TRUE when the section id is selected. +#' @return Updated pptx object. +#' @keywords internal +#' @noRd +.add_pptx_main_summary_slide <- function(pptx, group_data, i, in_sections) { + if (in_sections("meanplot") && in_sections("statistics")) { + add_pptx_sl_plottable(pptx, df = group_data$statistics, plot = group_data$meanplot) + } else if (in_sections("meanplot")) { + add_pptx_sl_plot(pptx, plot = group_data$meanplot) + } else if (in_sections("statistics")) { + add_pptx_sl_table(pptx, + df = group_data$statistics, + title = paste0("Group ", i, " Summary Statistics"), + footer = "") + } else { + pptx + } +} + +#' Add boxplot slides for a dose group and return updated pptx and slide count +#' @param pptx An officer pptx object. +#' @param group_data One element of res_dose_slides (a dose group). +#' @param in_sections Function(id) returning TRUE when the section id is selected. +#' @return List with elements `pptx`, `n_slides`. +#' @keywords internal +#' @noRd +.add_pptx_boxplot_slides <- function(pptx, group_data, in_sections) { + boxplots_i <- group_data$boxplot + if (!in_sections("boxplot") || !is.list(boxplots_i)) { + return(list(pptx = pptx, n_slides = 0L)) + } + for (bp_plot in boxplots_i) { + if (!is.null(bp_plot)) pptx <- add_pptx_sl_plot(pptx, bp_plot) + } + n_slides <- sum(vapply(boxplots_i, Negate(is.null), logical(1))) + list(pptx = pptx, n_slides = n_slides) +} + +#' Add summary slides for one dose group to a pptx object +#' @param pptx An officer pptx object. +#' @param group_data One element of res_dose_slides (a dose group). +#' @param i Integer index of this dose group. +#' @param in_sections Function(id) returning TRUE when the section id is selected. +#' @param lst_group_slide Integer slide index at the start of this group. +#' @return List with elements `pptx`, `n_summary_slides`. +#' @keywords internal +#' @noRd +.add_pptx_group_summary <- function(pptx, group_data, i, in_sections, lst_group_slide) { + pptx <- add_pptx_sl_table(pptx, group_data$info, paste0("Group ", i, " Summary"), + subtitle = paste(group_data$group)) %>% + officer::ph_slidelink(ph_label = "Footer Placeholder 3", slide_index = (lst_group_slide + 1)) + pptx <- .add_pptx_main_summary_slide(pptx, group_data, i, in_sections) + pptx <- pptx %>% { + if (in_sections("linplot")) add_pptx_sl_plot(., group_data$linplot) else . + } + bp_result <- .add_pptx_boxplot_slides(pptx, group_data, in_sections) + pptx <- bp_result$pptx + n_main_slides <- as.integer(in_sections("meanplot") || in_sections("statistics")) + n_summary_slides <- 1L + n_main_slides + as.integer(in_sections("linplot")) + bp_result$n_slides + list(pptx = pptx, n_summary_slides = n_summary_slides) +} + +#' Process one dose group's slides, returning updated pptx, lst_group_slide, group_slides +#' @param pptx An officer pptx object. +#' @param group_data One element of res_dose_slides (a dose group). +#' @param i Integer index of this dose group. +#' @param in_sections Function(id) returning TRUE when the section id is selected. +#' @param lst_group_slide Current slide index counter. +#' @param group_slides Integer vector of summary slide indices accumulated so far. +#' @return List with elements `pptx`, `lst_group_slide`, `group_slides`. +#' @keywords internal +#' @noRd +.process_pptx_group_slides <- function(pptx, group_data, i, in_sections, + lst_group_slide, group_slides) { + ind_result <- .add_pptx_ind_slides(pptx, group_data, i, in_sections) + pptx <- ind_result$pptx + n_ind_slides <- ind_result$n_slides + has_summary <- in_sections("meanplot") || in_sections("statistics") || + in_sections("linplot") || in_sections("boxplot") + if (has_summary) { + summary_result <- .add_pptx_group_summary(pptx, group_data, i, in_sections, lst_group_slide) + pptx <- summary_result$pptx + n_summary_slides <- summary_result$n_summary_slides + lst_group_slide <- lst_group_slide + n_ind_slides + n_summary_slides + group_slides <- c(group_slides, (lst_group_slide - n_summary_slides + 1):(lst_group_slide)) + } else { + lst_group_slide <- lst_group_slide + n_ind_slides + } + list(pptx = pptx, lst_group_slide = lst_group_slide, group_slides = group_slides) +} + #' Create a PowerPoint presentation with dose escalation results, including main and extra figures #' Adds slides for summary tables, mean plots, line plots, and individual subject results #' @param res_dose_slides List of results for each dose group @@ -92,58 +241,43 @@ create_pptx_dose_slides <- function(res_dose_slides, path, title, template) { } } + slide_sections <- attr(res_dose_slides, "slide_sections") + additional_analysis <- attr(res_dose_slides, "additional_analysis") + + in_sections <- function(id) is.null(slide_sections) || id %in% slide_sections + pptx <- create_pptx_doc(path, title, template) lst_group_slide <- 1 group_slides <- numeric() for (i in seq_along(res_dose_slides)) { + result <- .process_pptx_group_slides(pptx, res_dose_slides[[i]], i, in_sections, + lst_group_slide, group_slides) + pptx <- result$pptx + lst_group_slide <- result$lst_group_slide + group_slides <- result$group_slides + } - # Generate the individual figures - pptx <- add_pptx_sl_table( - pptx, res_dose_slides[[i]]$info, - title = paste0("Group ", i, " (individual)"), - subtitle = paste(res_dose_slides[[i]]$group), - footer = "" - ) + if (length(group_slides) > 0) { + group_slides_rev <- rev(group_slides) + (seq_along(group_slides) - 1) pptx <- purrr::reduce( - names(res_dose_slides[[i]]$ind_params), - function(pptx, subj) { - add_pptx_sl_plottable( - pptx, - df = res_dose_slides[[i]]$ind_params[[subj]], - plot = res_dose_slides[[i]]$ind_plots[[subj]] - ) - }, + group_slides_rev, + function(pptx, slide_index) officer::move_slide(pptx, index = slide_index, to = 2), .init = pptx ) - - # Generate summary figures and tables - pptx <- add_pptx_sl_table(pptx, res_dose_slides[[i]]$info, paste0("Group ", i, " Summary"), - subtitle = paste(res_dose_slides[[i]]$group)) %>% - officer::ph_slidelink(ph_label = "Footer Placeholder 3", - slide_index = (lst_group_slide + 1)) %>% - add_pptx_sl_plottable( - df = res_dose_slides[[i]]$statistics, - plot = res_dose_slides[[i]]$meanplot - ) %>% - add_pptx_sl_plot(res_dose_slides[[i]]$linplot) %>% - add_pptx_sl_plot(res_dose_slides[[i]]$boxplot) - - n_ind <- length(res_dose_slides[[i]]$ind_params) - lst_group_slide <- lst_group_slide + 1 + n_ind + 4 - group_slides <- c(group_slides, (lst_group_slide - 3):(lst_group_slide)) } - - group_slides_rev <- rev(group_slides) + (seq_along(group_slides) - 1) - pptx <- purrr::reduce( - group_slides_rev, - function(pptx, slide_index) officer::move_slide(pptx, index = slide_index, to = 2), - .init = pptx - ) pptx <- add_pptx_sl_title(pptx, "Extra Figures") - pptx <- officer::move_slide( - x = pptx, index = length(pptx), to = (length(group_slides) + 2) - ) + pptx <- officer::move_slide(x = pptx, index = length(pptx), to = (length(group_slides) + 2)) + + # Add additional analysis slides generically + non_empty <- .filter_additional_analysis(additional_analysis, slide_sections) + if (length(non_empty) > 0) { + pptx <- add_pptx_sl_title(pptx, "Additional Analysis Figures") + for (name in names(non_empty)) { + label <- tools::toTitleCase(gsub("_", " ", name)) + pptx <- add_pptx_sl_table(pptx, non_empty[[name]], title = label) + } + } print(pptx, target = path) invisible(TRUE) diff --git a/R/quarto-utils.R b/R/quarto-utils.R index 2e5c34e40..3ccd19238 100644 --- a/R/quarto-utils.R +++ b/R/quarto-utils.R @@ -21,9 +21,14 @@ create_qmd_doc <- function( ) { yaml_header <- c( "---", - paste0("title: \"", title, "\""), - "format: revealjs", - if (!is.null(template)) paste0("reference-doc: ", template) else NULL, + paste0("title: \"", gsub("[\r\n]+", " ", title), "\""), + "format:", + " revealjs:", + " toc: true", + " toc-depth: 1", + " theme: default", + " scrollable: true", + " smaller: true", "execute:", " echo: false", " warning: false", @@ -54,21 +59,18 @@ create_qmd_doc <- function( #' @param use_plotly Logical, whether to convert plot to plotly. #' @returns Invisibly returns TRUE if the slide was added. add_qmd_sl_plottabletable <- function(quarto_path, df1, df2, plot, use_plotly = FALSE) { + has_tables <- !is.null(df1) || !is.null(df2) slide_content <- c( "\n---", - add_qmd_plot(plot, use_plotly), - "::: columns", - "", - "::: column", - add_qmd_table(df1), - ":::", - "", - "::: column", - add_qmd_table(df2), - ":::", - "", - ":::", - "" + if (!is.null(plot)) add_qmd_plot(plot, use_plotly), + if (has_tables) c( + "::: columns", + "", + if (!is.null(df1)) c("::: column", add_qmd_table(df1), ":::", ""), + if (!is.null(df2)) c("::: column", add_qmd_table(df2), ":::", ""), + ":::", + "" + ) ) write(slide_content, file = quarto_path, append = TRUE) invisible(TRUE) @@ -93,6 +95,145 @@ add_qmd_sl_plot <- function(quarto_path, plot, use_plotly = FALSE) { invisible(TRUE) } +#' Write a section header slide with the group info table to a qmd file +#' @param quarto_path Path to the Quarto (.qmd) file to append to. +#' @param res_dose_slides List of results for each dose group. +#' @param i Integer index of the dose group. +#' @param label Character string used as the # heading text. +#' @keywords internal +#' @noRd +.add_qmd_group_section_header <- function(quarto_path, res_dose_slides, i, label) { + write( + c( + paste0("\n# ", label), + "", + add_qmd_table(paste0("res_dose_slides[[", i, "]]$info")), + "" + ), + file = quarto_path, append = TRUE + ) +} + +#' Append boxplot slides for one dose group to a qmd file +#' @param quarto_path Path to the Quarto (.qmd) file to append to. +#' @param boxplots_i Named list of boxplot objects for group i. +#' @param i Integer index of the dose group. +#' @param use_plotly Logical, whether to convert plots to plotly. +#' @keywords internal +#' @noRd +.add_qmd_boxplot_slides <- function(quarto_path, boxplots_i, i, use_plotly) { + for (bp_name in names(boxplots_i)) { + if (!is.null(boxplots_i[[bp_name]])) { + add_qmd_sl_plot( + quarto_path, + paste0("res_dose_slides[[", i, "]]$boxplot$", bp_name), + use_plotly + ) + } + } +} + +#' Append meanplot/statistics/linplot/boxplot slides for all dose groups to a qmd file +#' @param quarto_path Path to the Quarto (.qmd) file to append to. +#' @param res_dose_slides List of results for each dose group. +#' @param in_sections Function(id) returning TRUE when the section id is selected. +#' @param use_plotly Logical, whether to convert plots to plotly. +#' @keywords internal +#' @noRd +.add_qmd_summary_slides <- function(quarto_path, res_dose_slides, in_sections, use_plotly) { + for (i in seq_along(res_dose_slides)) { + .add_qmd_group_section_header(quarto_path, res_dose_slides, i, paste0("Group ", i)) + if (in_sections("meanplot") || in_sections("statistics")) { + add_qmd_sl_plottabletable( + quarto_path = quarto_path, + df1 = if (in_sections("statistics")) { + paste0("res_dose_slides[[", i, "]]$statistics") + } else { + NULL + }, + df2 = NULL, + plot = if (in_sections("meanplot")) { + paste0("res_dose_slides[[", i, "]]$meanplot") + } else { + NULL + }, + use_plotly = use_plotly + ) + } + if (in_sections("linplot")) { + add_qmd_sl_plot(quarto_path = quarto_path, + plot = paste0("res_dose_slides[[", i, "]]$linplot"), + use_plotly = use_plotly) + } + boxplots_i <- res_dose_slides[[i]]$boxplot + if (in_sections("boxplot") && is.list(boxplots_i)) { + .add_qmd_boxplot_slides(quarto_path, boxplots_i, i, use_plotly) + } + } +} + +#' Append individual-subject slides for all dose groups to a qmd file +#' @param quarto_path Path to the Quarto (.qmd) file to append to. +#' @param res_dose_slides List of results for each dose group. +#' @param in_sections Function(id) returning TRUE when the section id is selected. +#' @param use_plotly Logical, whether to convert plots to plotly. +#' @keywords internal +#' @noRd +.add_qmd_ind_slides <- function(quarto_path, res_dose_slides, in_sections, use_plotly) { + for (i in seq_along(res_dose_slides)) { + if (length(res_dose_slides[[i]]$ind_params) == 0 && + length(res_dose_slides[[i]]$ind_plots) == 0) { + next + } + .add_qmd_group_section_header( + quarto_path, res_dose_slides, i, paste0("Group ", i, " (Individual)") + ) + for (subj in names(res_dose_slides[[i]]$ind_params)) { + add_qmd_sl_plottabletable( + quarto_path = quarto_path, + df1 = if (in_sections("ind_params")) { + paste0("res_dose_slides[[", i, "]]$ind_params[['", subj, "']]") + } else { + NULL + }, + df2 = NULL, + plot = if (in_sections("ind_plots")) { + paste0("res_dose_slides[[", i, "]]$ind_plots[['", subj, "']]") + } else { + NULL + }, + use_plotly = use_plotly + ) + } + } +} + +#' Append additional analysis slides to a qmd file +#' @param quarto_path Path to the Quarto (.qmd) file to append to. +#' @param additional_analysis Named list of data frames. +#' @param slide_sections Character vector of selected section IDs, or NULL for all. +#' @keywords internal +#' @noRd +.add_qmd_additional_analysis <- function(quarto_path, additional_analysis, slide_sections) { + if (is.null(additional_analysis)) return(invisible(NULL)) + keep <- vapply(additional_analysis, function(x) is.data.frame(x) && nrow(x) > 0, logical(1)) + analysis_to_show <- additional_analysis[keep] + if (!is.null(slide_sections)) { + analysis_to_show <- analysis_to_show[names(analysis_to_show) %in% slide_sections] + } + if (length(analysis_to_show) == 0) return(invisible(NULL)) + write("\n# Additional Analysis Figures", file = quarto_path, append = TRUE) + for (name in names(analysis_to_show)) { + slide_title <- tools::toTitleCase(gsub("_", " ", name)) + write( + c("\n---", "", paste0("## ", slide_title), + add_qmd_table(paste0("additional_analysis[['", name, "']]")), ""), + file = quarto_path, + append = TRUE + ) + } +} + #' Create all slides for dose escalation results in a Quarto document #' #' Used internally to generate main and individual slides for each dose group. @@ -103,44 +244,31 @@ add_qmd_sl_plot <- function(quarto_path, plot, use_plotly = FALSE) { #' @param use_plotly Logical, whether to convert plots to plotly. #' @returns Invisibly returns TRUE if slides were created. create_qmd_dose_slides <- function(res_dose_slides, quarto_path, title, use_plotly = TRUE) { - # Save an accessible object with all results + # Read optional filtering attributes + slide_sections <- attr(res_dose_slides, "slide_sections") + additional_analysis <- attr(res_dose_slides, "additional_analysis") + + # Helper: TRUE when id is selected (NULL slide_sections means all selected) + in_sections <- function(id) is.null(slide_sections) || id %in% slide_sections + + # Save accessible objects with all results rda_path <- paste0(dirname(quarto_path), "/results_slides_outputs.rda") - save(list = as.character(quote(res_dose_slides)), file = rda_path) + save(list = c("res_dose_slides", "additional_analysis"), file = rda_path) # Generate the main quarto document create_qmd_doc(quarto_path = quarto_path, title = title, rda_path = basename(rda_path)) - for (i in seq_along(res_dose_slides)) { - add_qmd_sl_plottabletable( - quarto_path = quarto_path, - df1 = paste0("res_dose_slides[[", i, "]]$info"), - df2 = paste0("res_dose_slides[[", i, "]]$statistics"), - plot = paste0("res_dose_slides[[", i, "]]$meanplot"), - use_plotly = use_plotly - ) - add_qmd_sl_plot( - quarto_path = quarto_path, - plot = paste0("res_dose_slides[[", i, "]]$linplot"), - use_plotly = use_plotly - ) - add_qmd_sl_plot( - quarto_path = quarto_path, - plot = paste0("res_dose_slides[[", i, "]]$boxplot"), - use_plotly = use_plotly - ) - } - # Add the individual information slides - for (i in seq_along(res_dose_slides)) { - for (subj in names(res_dose_slides[[i]]$ind_params)) { - add_qmd_sl_plottabletable( - quarto_path = quarto_path, - df1 = paste0("res_dose_slides[[", i, "]]$info"), - df2 = paste0("res_dose_slides[[", i, "]]$ind_params[['", subj, "']]"), - plot = paste0("res_dose_slides[[", i, "]]$ind_plots[['", subj, "']]"), - use_plotly = use_plotly - ) - } - } + # Mean plot + statistics block + has_summary <- in_sections("meanplot") || in_sections("statistics") || + in_sections("linplot") || in_sections("boxplot") + has_individual <- in_sections("ind_plots") || in_sections("ind_params") + + if (has_summary) .add_qmd_summary_slides(quarto_path, res_dose_slides, in_sections, use_plotly) + if (has_summary && has_individual) write("\n# Extra Figures", file = quarto_path, append = TRUE) + if (has_individual) .add_qmd_ind_slides(quarto_path, res_dose_slides, in_sections, use_plotly) + + # Additional analysis section + .add_qmd_additional_analysis(quarto_path, additional_analysis, slide_sections) } #' Render dose escalation results to HTML via Quarto diff --git a/inst/WORDLIST b/inst/WORDLIST index 8fb74384b..49fe9caf2 100644 --- a/inst/WORDLIST +++ b/inst/WORDLIST @@ -119,8 +119,9 @@ WTBL WTBLU XPT YAML -aNCA's adnca +aNCA's +amountu analysing analyte analytes @@ -132,6 +133,7 @@ cdisc cmax colour conc +concu customizable customizations dataformat @@ -150,12 +152,15 @@ img intravascular kable knitr +linplot linters lintr logslope +lst mL macroparameters md +meanplot multidose nav nca @@ -171,19 +176,21 @@ pkcg pknca plotly pptest +pptx pre pred px qmd rds renderable -reproducibility reupload +reproducibility roadmap rpptx runnable signif src +subfolder standardizations synthesised th @@ -191,6 +198,7 @@ tibble tidyverse timeframe timepoint +timeu tlg tooltip tooltips diff --git a/inst/shiny/functions/zip-utils.R b/inst/shiny/functions/zip-utils.R index e5facc99e..e6ce38f9a 100644 --- a/inst/shiny/functions/zip-utils.R +++ b/inst/shiny/functions/zip-utils.R @@ -125,7 +125,7 @@ format_to_xpt_compatible <- function(data) { #' @param statistics Character vector of summary statistics to include (default: "Mean"). #' @param facet_vars Character vector of column names to facet plots by (default: "DOSEA"). #' @param stats_parameters Character vector of parameter codes to summarize -#' @param boxplot_parameter Character string of the parameter to use for boxplot. +#' @param boxplot_parameters Character vector of parameters to use for boxplots. #' @param info_vars Character vector of additional info columns to include #' @param labels_df Data frame containing variable labels (default: metadata_nca_variables). #' @@ -135,18 +135,19 @@ get_dose_esc_results <- function( statistics = "Mean", facet_vars = "DOSEA", stats_parameters = c("CMAX", "TMAX", "VSSO", "CLSTP", "LAMZHL", "AUCIFO", "AUCLST", "FABS"), - boxplot_parameter = "AUCIFO", + ind_stats_parameters = stats_parameters, + summary_stats_parameters = stats_parameters, + boxplot_parameters = c("AUCIFO"), info_vars = c("SEX", "STRAIN", "RACE", "DOSFRM"), labels_df = metadata_nca_variables ) { # Define column names - studyid_col <- "STUDYID" subj_col <- o_nca$data$conc$columns$subject analyte_col <- o_nca$data$conc$columns$groups$group_analyte pcspec_col <- "PCSPEC" profile_col <- "ATPTREF" - groups <- unique(o_nca$data$intervals[, c(group_by_vars, profile_col)]) + groups <- unique(o_nca$result[, c(group_by_vars, profile_col)]) output_list <- list() o_nca_i <- o_nca # Loop over each of the groups @@ -191,7 +192,7 @@ get_dose_esc_results <- function( ) %>% select( any_of(c(facet_vars, "Statistic")), - any_of(names(.)[gsub("\\[.*\\]", "", names(.)) %in% stats_parameters]) + any_of(names(.)[gsub("\\[.*\\]", "", names(.)) %in% summary_stats_parameters]) ) %>% unique() @@ -210,19 +211,28 @@ get_dose_esc_results <- function( pull(group) %>% unique() - boxplot_i <- flexible_violinboxplot( - res_nca = o_nca_i, - parameter = boxplot_parameter, - xvars = facet_vars, - colorvars = analyte_col, - varvalstofilter = NULL, - box = TRUE, - tooltip_vars = NULL, - plotly = FALSE + boxplots_i <- setNames( + lapply(boxplot_parameters, function(bp) { + if (bp %in% unique(o_res_i$PPTESTCD)) { + flexible_violinboxplot( + res_nca = o_nca_i, + parameter = bp, + xvars = facet_vars, + colorvars = analyte_col, + varvalstofilter = NULL, + box = TRUE, + tooltip_vars = NULL, + plotly = FALSE + ) + } else { + NULL + } + }), + boxplot_parameters ) ind_params <- merge(o_nca$result, group_i) %>% - filter(PPTESTCD %in% stats_parameters) %>% + filter(PPTESTCD %in% ind_stats_parameters) %>% mutate(parameter_unit = paste0(PPTESTCD, "[", PPSTRESU, "]")) %>% select(any_of( c( @@ -253,7 +263,7 @@ get_dose_esc_results <- function( linplot = linplot_i, meanplot = meanplot_i, statistics = stats_i, - boxplot = boxplot_i, + boxplot = boxplots_i, info = info_i, ind_params = ind_params, ind_plots = ind_plots, @@ -303,6 +313,29 @@ get_tree_leaf_ids <- function(tree) { ids } +#' Convert tree node text values to their corresponding node IDs +#' @param tree A tree list (output of create_tree_from_list_names) +#' @param texts Character vector of node text values to look up +#' @return Character vector of matching node IDs +get_tree_ids_for_texts <- function(tree, texts) { + result <- character(0) + for (node in tree) { + has_children <- !is.null(node$children) && length(node$children) > 0 + if (has_children) { + if (node$text %in% texts) { + # Parent fully selected: add all leaf descendants, never the parent ID + result <- c(result, get_tree_leaf_ids(node$children)) + } else { + # Check children individually + result <- c(result, get_tree_ids_for_texts(node$children, texts)) + } + } else if (node$text %in% texts) { + result <- c(result, node$id) + } + } + result +} + #' Prepare export files #' #' @param target_dir Path to the directory where files will be written. @@ -317,7 +350,8 @@ prepare_export_files <- function(target_dir, grouping_vars, input, session, - progress) { + progress, + slide_config = NULL) { # Save Standard Outputs (Tables/Plots) progress$set(message = "Creating exports...", @@ -352,12 +386,12 @@ prepare_export_files <- function(target_dir, progress$inc(0.2) - # NCA-dependent exports: only run when results are available if (!is.null(res_nca)) { if ("results_slides" %in% input$res_tree) { progress$set(message = "Creating exports...", detail = "Saving slideshow...") - .export_slides(target_dir, res_nca, grouping_vars, input, session) + .export_slides(target_dir, res_nca, grouping_vars, input, session, + slide_config = slide_config) } progress$inc(0.4) @@ -406,16 +440,41 @@ prepare_export_files <- function(target_dir, #' @param session Shiny session object. #' @keywords internal #' @noRd -.export_slides <- function(target_dir, res_nca, grouping_vars, input, session) { +.export_slides <- function(target_dir, res_nca, grouping_vars, input, session, + slide_config = NULL) { + slide_sections <- slide_config$slide_sections + ind_stats_parameters <- rlang::`%||%`( + slide_config$ind_stats_parameters, DEFAULT_STATS_PARAMETERS + ) + summary_stats_parameters <- rlang::`%||%`( + slide_config$summary_stats_parameters, DEFAULT_STATS_PARAMETERS + ) + boxplot_parameters <- slide_config$boxplot_parameters + if (length(boxplot_parameters) == 0) boxplot_parameters <- c("CMAX", "AUCIFO", "LAMZHL") + res_dose_slides <- get_dose_esc_results( o_nca = res_nca, group_by_vars = setdiff(group_vars(res_nca), res_nca$data$conc$columns$subject), facet_vars = "DOSEA", statistics = "Mean", - stats_parameters = c("CMAX", "TMAX", "VSSO", "CLO", "LAMZHL", "AUCIFO", "AUCLST", "FABS_IFO"), + stats_parameters = union(ind_stats_parameters, summary_stats_parameters), + ind_stats_parameters = ind_stats_parameters, + summary_stats_parameters = summary_stats_parameters, + boxplot_parameters = boxplot_parameters, info_vars = grouping_vars ) + # Attach additional_analysis from session results + additional_analysis <- session$userData$results$additional_analysis + if (is.null(additional_analysis)) additional_analysis <- list() + attr(res_dose_slides, "additional_analysis") <- Filter( + function(x) is.data.frame(x) && nrow(x) > 0, + additional_analysis + ) + + # Attach slide section selection (NULL means all sections) + attr(res_dose_slides, "slide_sections") <- slide_sections + path <- file.path(target_dir, "presentations") dir.create(path, showWarnings = FALSE) @@ -588,8 +647,11 @@ prepare_export_files <- function(target_dir, all_files <- list.files(target_dir, recursive = TRUE, full.names = TRUE) exts <- c(input$table_formats, input$plot_formats, input$slide_formats, "yaml", "R") + if ("qmd" %in% input$slide_formats) exts <- c(exts, "rda") exts_patt <- paste0("((", paste0(exts, collapse = ")|("), "))$") fnames <- unique(c(input$res_tree, names(custom_names))) + if ("results_slides" %in% fnames) fnames <- c(fnames, "results_slides_outputs") + fnames <- ifelse(fnames == "r_script", "session_code", fnames) fnames <- ifelse(fnames == "settings_file", "settings", fnames) fnames_patt <- paste0( @@ -600,6 +662,10 @@ prepare_export_files <- function(target_dir, pattern <- paste0("/", fnames_patt, "\\.", exts_patt) files_req <- grep(pattern, all_files, value = TRUE) files_req <- c(files_req, grep("data\\.rds$", all_files, value = TRUE)) + if ("qmd" %in% input$slide_formats) { + files_req <- c(files_req, grep("results_slides_outputs\\.rda$", all_files, value = TRUE)) + } + # Preserve pre-specs only when at least one CDISC dataset is selected if (any(c("pp", "adpp", "adnca") %in% fnames)) { files_req <- c(files_req, grep("CDISC/Pre_Specs\\.xlsx$", all_files, diff --git a/inst/shiny/modules/tab_nca/zip.R b/inst/shiny/modules/tab_nca/zip.R index d433742ea..e70b08f5d 100644 --- a/inst/shiny/modules/tab_nca/zip.R +++ b/inst/shiny/modules/tab_nca/zip.R @@ -33,11 +33,360 @@ zip_ui <- function(id) { ) } +# Build the slide_types list from session additional_analysis +.build_slide_types <- function(additional_analysis) { + if (is.null(additional_analysis)) additional_analysis <- list() + additional_available <- Filter( + function(x) is.data.frame(x) && nrow(x) > 0, + additional_analysis + ) + additional_sections <- lapply(names(additional_available), function(name) { + list(id = name, label = gsub("_", " ", tools::toTitleCase(name))) + }) + slide_types <- list( + list( + id = "individual", + label = "Individual Slides", + sections = list( + list(id = "ind_plots", label = "Individual Plots"), + list(id = "ind_params", label = "PK Parameters") + ) + ), + list( + id = "summary", + label = "Summary Slides", + sections = list( + list(id = "meanplot", label = "Mean Plots"), + list(id = "linplot", label = "Spaghetti / Group Plot"), + list(id = "boxplot", label = "Box Plot"), + list(id = "statistics", label = "Summary Statistics") + ) + ) + ) + if (length(additional_sections) > 0) { + slide_types <- c(slide_types, list( + list( + id = "additional", + label = "Additional Analysis", + sections = additional_sections + ) + )) + } + slide_types +} + +# Build virtualSelectInput grouped choices from available NCA parameters +.make_param_virtual_choices <- function(available_params) { + param_meta <- metadata_nca_parameters[metadata_nca_parameters$PPTESTCD %in% available_params, ] + params_by_type <- split(param_meta, param_meta$TYPE) + lapply(names(params_by_type), function(type_name) { + df <- params_by_type[[type_name]] + options_list <- lapply(seq_len(nrow(df)), function(i) { + list( + label = as.character(df$PPTESTCD[i]), + value = as.character(df$PPTESTCD[i]), + description = as.character(df$PPTEST[i]) + ) + }) + list(label = type_name, options = options_list) + }) +} + +# Show the "Customise Slide Contents" modal dialog +.show_customise_slides_modal <- function(ns, slide_tree, all_leaf_ids, + virtual_choices, available_params, default_selected) { + showModal(modalDialog( + title = "Customise Slide Contents", + p( + class = "modal-intro", + "Select which slide sections to include and which PK parameters to show.", + "Changes apply only to the exported slide deck." + ), + fluidRow( + column( + width = 6, + div( + h4("Slide Sections"), + shinyWidgets::treeInput( + inputId = ns("slide_sections_tree"), + label = NULL, + choices = slide_tree, + selected = all_leaf_ids + ), + style = "text-align: left;" + ) + ), + column( + width = 6, + div( + h4("PK Parameters", style = "margin-bottom: 0.25em;"), + p(style = "color: #777; font-size: 0.85em; margin-top: 0; margin-bottom: 0.75em;", + "Parameters included in the slide tables") + ), + div( + id = ns("ind_params_container"), + shinyWidgets::virtualSelectInput( + inputId = ns("slide_ind_params"), + label = "Individual slide:", + choices = virtual_choices, + selected = default_selected, + multiple = TRUE, + search = TRUE, + showSelectedOptionsFirst = TRUE, + hasOptionDescription = TRUE, + showValueAsTags = TRUE, + width = "100%" + ) + ), + div( + id = ns("summary_params_container"), + shinyWidgets::virtualSelectInput( + inputId = ns("slide_summary_params"), + label = "Summary slide:", + choices = virtual_choices, + selected = default_selected, + multiple = TRUE, + search = TRUE, + showSelectedOptionsFirst = TRUE, + hasOptionDescription = TRUE, + showValueAsTags = TRUE, + width = "100%" + ) + ), + div( + id = ns("boxplot_params_container"), + shinyWidgets::virtualSelectInput( + inputId = ns("slide_boxplot_param"), + label = "Box plot parameter:", + choices = virtual_choices, + selected = intersect(c("AUCIFO", "CMAX", "LAMZHL"), available_params), + multiple = TRUE, + search = TRUE, + showSelectedOptionsFirst = TRUE, + hasOptionDescription = TRUE, + showValueAsTags = TRUE, + width = "100%" + ) + ), + helpText( + icon("circle-info"), + "Only parameters calculated in this NCA run are available for selection.", + "If a parameter you need is missing, return to the NCA tab,", + "include it in the parameter", + "selection, and re-run the analysis before exporting." + ) + ) + ), + div(class = "w-100", uiOutput(ns("slide_validation_ui"))), + footer = tagList( + div( + style = "display: flex; justify-content: space-between; width: 100%;", + actionButton(ns("back_to_export"), "Back", icon = icon("arrow-left")), + div( + modalButton("Cancel"), + downloadButton(ns("download_zip_configured"), "Export", class = "btn btn-primary") + ) + ) + ), + easyClose = FALSE, + size = "l" + )) +} + +# Check that each selected output type has a corresponding format chosen +.check_format_selections <- function(tree, plot_formats, table_formats, slide_formats) { + msgs <- character(0) + if (any(PLOT_NODES %in% tree) && length(plot_formats) == 0) { + msgs <- c(msgs, "Graphics & plots are selected but no graphics format is chosen.") + } + if (any(TABLE_NODES %in% tree) && length(table_formats) == 0) { + msgs <- c(msgs, "Data tables are selected but no table format is chosen.") + } + if (any(SLIDE_NODES %in% tree) && length(slide_formats) == 0) { + msgs <- c(msgs, "Result slides are selected but no slide format is chosen.") + } + msgs +} + +# Validate export form inputs — returns character(0) if valid, else a vector of messages +.validate_export_inputs <- function(modal_shown_val, tree, plot_formats, + table_formats, slide_formats) { + if (!modal_shown_val) return(character(0)) + if (is.null(tree) || length(tree) == 0) { + return("Select at least one result to export.") + } + .check_format_selections(tree, plot_formats, table_formats, slide_formats) +} + +# Validate slide configuration — returns character(0) if valid, else a vector of messages +.validate_slide_config <- function(slide_sections_tree, ind_params, + summary_params, boxplot_params) { + msgs <- character(0) + if (is.null(slide_sections_tree) || length(slide_sections_tree) == 0) { + msgs <- c(msgs, "Select at least one slide section to include.") + } + if ("PK Parameters" %in% slide_sections_tree && length(ind_params) == 0) { + msgs <- c(msgs, "Individual slide parameters cannot be empty.") + } + if ("Summary Statistics" %in% slide_sections_tree && length(summary_params) == 0) { + msgs <- c(msgs, "Summary slide parameters cannot be empty.") + } + if ("Box Plot" %in% slide_sections_tree && length(boxplot_params) == 0) { + msgs <- c(msgs, "Box plot parameters cannot be empty.") + } + msgs +} + +# Render export validation messages as a styled UI element +.render_validation_msgs <- function(msgs) { + if (length(msgs) == 0) return(NULL) + div( + style = paste( + "text-align: center;", + "padding: 6px 0 2px;" + ), + span( + style = paste( + "display: inline-block;", + "background-color: #dc3545;", + "color: #fff;", + "border-radius: 20px;", + "padding: 5px 14px;", + "font-size: 0.85rem;", + "font-weight: 500;", + "line-height: 1.4;" + ), + icon("triangle-exclamation"), + if (length(msgs) == 1) { + span(msgs) + } else { + tags$ul( + style = "margin: 4px 0 0 0; padding-left: 1.2em; text-align: left;", + lapply(msgs, function(m) tags$li(style = "margin-bottom: 2px;", m)) + ) + } + ) + ) +} + +# Generate ZIP filename from session project/study info +.make_zip_filename <- function(session) { + project <- session$userData$project_name() + if (project == "") { + label <- session$userData$study_ids_label() + project <- if (label != "") paste0("NCA_", label) else "NCA" + } + project <- gsub("[^A-Za-z0-9_-]", "_", project) + paste0(project, ".zip") +} + +# Resolve slide configuration from customise modal inputs +.resolve_slide_config <- function(input, slide_types_rv) { + selected_tree <- input$slide_sections_tree + types <- slide_types_rv() + selected_sections <- unlist(lapply(types, function(type) { + lapply(type$sections, function(sec) { + if (sec$label %in% selected_tree) sec$id else NULL + }) + })) + # Ensure fully-deselected means nothing (not everything): NULL is the "include all" sentinel + if (is.null(selected_sections)) selected_sections <- character(0) + list( + slide_sections = selected_sections, + ind_stats_parameters = input$slide_ind_params, + summary_stats_parameters = input$slide_summary_params, + boxplot_parameters = input$slide_boxplot_param + ) +} + +# Show the "Export Results" modal dialog +.show_export_modal <- function(ns, TREE_UI, selected_tree, + plot_formats, slide_formats, table_formats) { + slide_choices <- if ( + requireNamespace("officer", quietly = TRUE) && + requireNamespace("flextable", quietly = TRUE) + ) c("pptx", "qmd") else "qmd" + + showModal( + modalDialog( + title = "Export Results", + tagList( + p( + class = "modal-intro", + "Choose what to include in your export and the file formats to generate.", + "Slide decks can be further customised in the next step." + ), + fluidRow( + column( + width = 6, + div( + h4("Results to Export"), + shinyWidgets::treeInput( + inputId = ns("res_tree"), + label = NULL, + selected = selected_tree, + choices = TREE_UI + ), + style = "text-align: left;" + ) + ), + column( + width = 6, + h4("Export Formats"), + div( + selectizeInput( + ns("plot_formats"), + "Graphics and plots:", + choices = c("png", "html"), + selected = plot_formats, + multiple = TRUE + ), + style = "margin-bottom: 1em;" + ), + div( + selectizeInput( + ns("slide_formats"), + "Slide decks:", + choices = slide_choices, + selected = intersect(slide_formats, slide_choices), + multiple = TRUE + ), + style = "margin-bottom: 1em;" + ), + div( + selectizeInput( + ns("table_formats"), + "Data tables:", + choices = c("rds", "xpt", "csv"), + selected = table_formats, + multiple = TRUE + ), + style = "margin-bottom: 2em;" + ) + ) + ), + div(class = "w-100", uiOutput(ns("export_validation_ui"))) + ), + footer = tagList( + modalButton("Cancel"), + actionButton( + ns("confirm_export"), + label = "Export ZIP with Results", + icon = icon("download"), + class = "btn btn-primary" + ) + ), + easyClose = FALSE, + size = "l" + ) + ) +} + zip_server <- function(id, res_nca, adnca_data, settings, grouping_vars) { moduleServer(id, function(input, output, session) { ns <- session$ns - # Enable Save button after mapping; full content after NCA + # Enable Save button after mapping; full content available after NCA observe({ req(adnca_data()) shinyjs::enable("open_zip_modal") @@ -52,94 +401,34 @@ zip_server <- function(id, res_nca, adnca_data, settings, grouping_vars) { }) }) - # Show ZIP export modal when button is clicked - observeEvent(input$open_zip_modal, { - # Build tree based on what's actually available - tree_items <- .available_tree_items( - nca_available = isTRUE(nca_available()), - exploration_names = names(session$userData$results$exploration) + export_validation <- reactive({ + .validate_export_inputs( + modal_shown_val = modal_shown(), + tree = input$res_tree, + plot_formats = input$plot_formats, + table_formats = input$table_formats, + slide_formats = input$slide_formats ) - TREE_UI <- create_tree_from_list_names(tree_items) - showModal( - modalDialog( - title = NULL, - tagList( - fluidRow( - column( - width = 6, - div( - h4("Results to Export"), - shinyWidgets::treeInput( - inputId = ns("res_tree"), - label = NULL, - selected = get_tree_leaf_ids(TREE_UI), - choices = TREE_UI - ), - style = "text-align: left;" - ) - ), - column( - width = 6, - h4("Export Formats"), - div( - selectizeInput( - ns("plot_formats"), - "Graphics and plots:", - choices = c("png", "html"), - selected = c("png", "html"), - multiple = TRUE - ), - style = "margin-bottom: 1em;" - ), - div( - { - has_pptx <- requireNamespace("officer", quietly = TRUE) && - requireNamespace("flextable", quietly = TRUE) - slide_choices <- if (has_pptx) c("pptx", "qmd") else "qmd" - - selectizeInput( - ns("slide_formats"), - "Slide decks:", - choices = slide_choices, - selected = slide_choices, - multiple = TRUE - ) - }, - style = "margin-bottom: 1em;" - ), - div( - selectizeInput( - ns("table_formats"), - "Data tables:", - choices = c("rds", "xpt", "csv"), - selected = c("rds", "xpt", "csv"), - multiple = TRUE - ), - style = "margin-bottom: 1em;" - ), - shinyjs::hidden( - div( - id = ns("settings_comment_container"), - tags$br(), - h4("Comment ", tags$small("(optional)")), - textInput( - ns("settings_comment"), - label = NULL, - placeholder = "e.g. final NCA, first draft" - ) - ) - ) - ) - ), - div( - downloadButton(ns("download_zip"), "Export ZIP with Results"), - style = "width: 100%; text-align: center; margin-top: 0.5em;" - ) - ), - easyClose = TRUE, - footer = NULL, - size = "l" - ) + }) + + output$export_validation_ui <- renderUI({ + .render_validation_msgs(export_validation()) + }) + + observe({ + if (length(export_validation()) > 0) { + shinyjs::disable("confirm_export") + } else { + shinyjs::enable("confirm_export") + } + }) + + slide_validation <- reactive({ + .validate_slide_config( + slide_sections_tree = input$slide_sections_tree, + ind_params = input$slide_ind_params, + summary_params = input$slide_summary_params, + boxplot_params = input$slide_boxplot_param ) }) @@ -153,69 +442,197 @@ zip_server <- function(id, res_nca, adnca_data, settings, grouping_vars) { } }) - output$download_zip <- downloadHandler( - filename = function() { - project <- session$userData$project_name() - if (project == "") { - label <- session$userData$study_ids_label() - project <- if (label != "") paste0("NCA_", label) else "NCA" + output$slide_validation_ui <- renderUI({ + .render_validation_msgs(slide_validation()) + }) + + observe({ + if (length(slide_validation()) > 0) { + shinyjs::disable("download_zip_configured") + } else { + shinyjs::enable("download_zip_configured") + } + }) + + observe({ + tree <- input$slide_sections_tree + shinyjs::toggle("ind_params_container", condition = "PK Parameters" %in% tree) + shinyjs::toggle("summary_params_container", condition = "Summary Statistics" %in% tree) + shinyjs::toggle("boxplot_params_container", condition = "Box Plot" %in% tree) + }) + + # Show ZIP export modal when button is clicked + observeEvent(input$open_zip_modal, { + modal_shown(TRUE) + tree_items <- .available_tree_items( + nca_available = isTRUE(nca_available()), + exploration_names = names(session$userData$results$exploration), + additional_analysis = session$userData$results$additional_analysis + ) + TREE_UI <- create_tree_from_list_names(tree_items) + .show_export_modal(ns, TREE_UI, get_tree_leaf_ids(TREE_UI), + c("png", "html"), c("pptx", "qmd"), c("rds", "xpt", "csv")) + }) + + slide_types_rv <- reactiveVal(list()) + modal_shown <- reactiveVal(FALSE) + + export_state <- reactiveValues( + res_tree = NULL, + res_tree_texts = NULL, + plot_formats = c("png", "html"), + slide_formats = c("pptx", "qmd"), + table_formats = c("rds", "xpt", "csv") + ) + + observeEvent(input$confirm_export, { + export_state$res_tree_texts <- input$res_tree + tree_items_save <- .available_tree_items( + nca_available = isTRUE(nca_available()), + exploration_names = names(session$userData$results$exploration), + additional_analysis = session$userData$results$additional_analysis + ) + tree_ui_save <- create_tree_from_list_names(tree_items_save) + export_state$res_tree <- get_tree_ids_for_texts(tree_ui_save, input$res_tree) + export_state$plot_formats <- input$plot_formats + export_state$slide_formats <- input$slide_formats + export_state$table_formats <- input$table_formats + + slides_selected <- "results_slides" %in% input$res_tree && + length(input$slide_formats) > 0 + + if (!slides_selected) { + removeModal() + showModal(modalDialog( + title = "Ready to Export", + p(class = "modal-intro", "Your export is ready. Click the button below to download."), + footer = tagList( + div( + style = "display: flex; justify-content: space-between; width: 100%;", + actionButton(ns("back_to_export"), "Back", icon = icon("arrow-left")), + div( + modalButton("Cancel"), + downloadButton(ns("download_zip"), "Export", class = "btn btn-primary") + ) + ) + ), + easyClose = FALSE, + size = "s" + )) + return() + } + + slide_types <- .build_slide_types(session$userData$results$additional_analysis) + slide_types_rv(slide_types) + + slide_tree <- lapply(seq_along(slide_types), function(i) { + type <- slide_types[[i]] + parent_id <- paste0("slides_", i) + children <- lapply(seq_along(type$sections), function(j) { + sec <- type$sections[[j]] + list(text = sec$label, id = paste0(parent_id, "_", j)) + }) + list(text = type$label, id = parent_id, children = children) + }) + all_leaf_ids <- unlist(lapply(slide_tree, function(node) { + vapply(node$children, `[[`, character(1), "id") + })) + + available_params <- sort(unique(res_nca()$result$PPTESTCD)) + virtual_choices <- .make_param_virtual_choices(available_params) + default_selected <- intersect(DEFAULT_STATS_PARAMETERS, available_params) + + removeModal() + .show_customise_slides_modal(ns, slide_tree, all_leaf_ids, + virtual_choices, available_params, default_selected) + }) + + observeEvent(input$back_to_export, { + modal_shown(TRUE) + tree_items <- .available_tree_items( + nca_available = isTRUE(nca_available()), + exploration_names = names(session$userData$results$exploration), + additional_analysis = session$userData$results$additional_analysis + ) + TREE_UI <- create_tree_from_list_names(tree_items) + saved_tree <- if (is.null(export_state$res_tree)) { + get_tree_leaf_ids(TREE_UI) + } else { + export_state$res_tree + } + removeModal() + .show_export_modal(ns, TREE_UI, saved_tree, + export_state$plot_formats, + export_state$slide_formats, + export_state$table_formats) + }) + + .run_export <- function(fname, slide_config = NULL) { + frozen_input <- list( + res_tree = export_state$res_tree_texts, + plot_formats = export_state$plot_formats, + slide_formats = export_state$slide_formats, + table_formats = export_state$table_formats + ) + tryCatch( + { + progress <- shiny::Progress$new(min = 0, max = 1) + progress$set(message = "Creating exports...") + progress$inc(0.1) + + output_tmpdir <- file.path(tempdir(), "output") + unlink(output_tmpdir, recursive = TRUE) + + prepare_export_files( + target_dir = output_tmpdir, + res_nca = res_nca(), + settings = settings, + grouping_vars = grouping_vars(), + input = frozen_input, + session = session, + progress = progress, + slide_config = slide_config + ) + + files <- list.files(output_tmpdir, recursive = TRUE) + wd <- getwd() + on.exit(setwd(wd), add = TRUE) + setwd(output_tmpdir) + + progress$inc(0.9) + progress$set(message = "Creating exports...", detail = "Final touches...") + zip::zipr(zipfile = fname, files = files, mode = "mirror") + + progress$set(message = "Complete!", detail = "") + progress$inc(1) + }, + error = function(e) { + message("Download Error: ", e$message) + stop(e) } - project <- gsub("[^A-Za-z0-9_-]", "_", project) - paste0(project, ".zip") - }, + ) + } + + output$download_zip <- downloadHandler( + filename = function() .make_zip_filename(session), content = function(fname) { - tryCatch( - { - # Store settings comment for versioned export - session$userData$settings_save_comment <- input$settings_comment - - progress <- shiny::Progress$new(min = 0, max = 1) - progress$set(message = "Creating exports...") - progress$inc(0.1) - - output_tmpdir <- file.path(tempdir(), "output") - unlink(output_tmpdir, recursive = TRUE) - - nca_result <- tryCatch(res_nca(), error = function(e) NULL) - - prepare_export_files( - target_dir = output_tmpdir, - res_nca = nca_result, - settings = settings, - grouping_vars = grouping_vars(), - input = input, - session = session, - progress = progress - ) + .run_export(fname, slide_config = NULL) + } + ) - files <- list.files(output_tmpdir, recursive = TRUE) - - wd <- getwd() - on.exit(setwd(wd), add = TRUE) - setwd(output_tmpdir) - - progress$inc(0.9) - progress$set(message = "Creating exports...", - detail = "Final touches...") - zip::zipr(zipfile = fname, files = files, mode = "mirror") - - progress$set(message = "Complete!", - detail = "") - progress$inc(1) - }, - error = function(e) { - message("Download Error:") - message(e$message) - stop(e) - } - ) + output$download_zip_configured <- downloadHandler( + filename = function() .make_zip_filename(session), + content = function(fname) { + removeModal() + slide_config <- .resolve_slide_config(input, slide_types_rv) + .run_export(fname, slide_config = slide_config) } ) }) } # Build the tree of available export items based on current app state. -.available_tree_items <- function(nca_available, exploration_names) { +.available_tree_items <- function(nca_available, exploration_names, additional_analysis = NULL) { items <- list() # Only show exploration plots that have been rendered @@ -228,10 +645,18 @@ zip_server <- function(id, res_nca, adnca_data, settings, grouping_vars) { } if (nca_available) { - items$nca_results <- TREE_LIST$nca_results - items$CDISC <- TREE_LIST$CDISC - items$additional_analysis <- TREE_LIST$additional_analysis - items$extras <- TREE_LIST$extras + items$nca_results <- TREE_LIST$nca_results + items$CDISC <- TREE_LIST$CDISC + avail_additional <- names(Filter( + function(x) is.data.frame(x) && nrow(x) > 0, + additional_analysis + )) + if (length(avail_additional) > 0) { + items$additional_analysis <- TREE_LIST$additional_analysis[ + intersect(avail_additional, names(TREE_LIST$additional_analysis)) + ] + } + items$extras <- TREE_LIST$extras } else { items$extras <- TREE_LIST$extras[c("settings_file", "session_info")] } @@ -239,6 +664,10 @@ zip_server <- function(id, res_nca, adnca_data, settings, grouping_vars) { items } +DEFAULT_STATS_PARAMETERS <- c( + "CMAX", "TMAX", "VSSO", "CLO", "LAMZHL", "AUCIFO", "AUCLST", "FABS_IFO" +) + # Define a list with the possible outputs to export as end objects. # Consider all the zip_server options to create and align accordingly. TREE_LIST <- list( @@ -267,3 +696,8 @@ TREE_LIST <- list( session_info = "" ) ) + +PLOT_NODES <- c("individualplot", "meanplot", "qcplot") +TABLE_NODES <- c("nca_pkparam", "nca_statistics", "pp", "adpp", "adnca", + "matrix_ratios", "excretion_results") +SLIDE_NODES <- "results_slides" diff --git a/inst/shiny/www/main.css b/inst/shiny/www/main.css index 01dd82c60..11108de48 100644 --- a/inst/shiny/www/main.css +++ b/inst/shiny/www/main.css @@ -115,6 +115,11 @@ h5 { text-align: center; } +.modal-footer { + background-color: #f5f5f5; + border-top: 1px solid #e5e5e5; +} + .modal-intro { font-family: "Arial"; /* Elegant font type for intro text */ diff --git a/inst/shiny/www/styles/partials/_base.scss b/inst/shiny/www/styles/partials/_base.scss index 5f93a022b..8a710e5aa 100644 --- a/inst/shiny/www/styles/partials/_base.scss +++ b/inst/shiny/www/styles/partials/_base.scss @@ -117,6 +117,11 @@ h5 { text-align: center; } +.modal-footer { + background-color: #f5f5f5; + border-top: 1px solid #e5e5e5; +} + .modal-intro { font-family: "Arial"; /* Elegant font type for intro text */ diff --git a/tests/testthat/test-officer-utils.R b/tests/testthat/test-officer-utils.R new file mode 100644 index 000000000..9ad743fd5 --- /dev/null +++ b/tests/testthat/test-officer-utils.R @@ -0,0 +1,190 @@ +describe("create_pptx_dose_slides", { + template <- system.file("www/templates/template.pptx", package = "aNCA") + + base_slides <- list( + list( + info = data.frame(group = "A"), + group = "A", + statistics = data.frame(stat = "Mean", value = 1), + meanplot = ggplot2::ggplot(), + linplot = ggplot2::ggplot(), + boxplot = list(AUCIFO = ggplot2::ggplot()), + ind_params = list(SUBJ01 = data.frame(param = "CMAX", value = 1)), + ind_plots = list(SUBJ01 = ggplot2::ggplot()) + ) + ) + + it("produces fewer slides when ind_plots is excluded from slide_sections", { + slides_all <- base_slides + slides_no_ind <- base_slides + attr(slides_no_ind, "slide_sections") <- c("meanplot", "statistics", "ind_params") + + out_all <- tempfile(fileext = ".pptx") + out_no_ind <- tempfile(fileext = ".pptx") + + create_pptx_dose_slides(slides_all, out_all, "NCA", template) + create_pptx_dose_slides(slides_no_ind, out_no_ind, "NCA", template) + + n_all <- length(officer::read_pptx(out_all)) + n_no_ind <- length(officer::read_pptx(out_no_ind)) + + expect_lt(n_no_ind, n_all) + }) + + it("includes all slides when slide_sections is NULL (backwards compat)", { + out <- tempfile(fileext = ".pptx") + create_pptx_dose_slides(base_slides, out, "NCA", template) + pptx <- officer::read_pptx(out) + expect_gte(length(pptx), 8) + }) + + it("adds additional analysis slides generically for any non-empty data frame", { + slides <- base_slides + attr(slides, "additional_analysis") <- list( + matrix_ratios = data.frame(Ratio_Type = "A/B", Ratio = 1.2) + ) + out_base <- tempfile(fileext = ".pptx") + out_extra <- tempfile(fileext = ".pptx") + + create_pptx_dose_slides(base_slides, out_base, "NCA", template) + create_pptx_dose_slides(slides, out_extra, "NCA", template) + + expect_gt(length(officer::read_pptx(out_extra)), length(officer::read_pptx(out_base))) + }) + + it("skips boxplot slide when boxplot data is NULL", { + slides_null_box <- list( + list( + info = data.frame(group = "A"), + group = "A", + statistics = data.frame(stat = "Mean", value = 1), + meanplot = ggplot2::ggplot(), + linplot = ggplot2::ggplot(), + boxplot = list(AUCIFO = NULL), + ind_params = list(SUBJ01 = data.frame(param = "CMAX", value = 1)), + ind_plots = list(SUBJ01 = ggplot2::ggplot()) + ) + ) + out_null <- tempfile(fileext = ".pptx") + out_full <- tempfile(fileext = ".pptx") + + create_pptx_dose_slides(slides_null_box, out_null, "NCA", template) + create_pptx_dose_slides(base_slides, out_full, "NCA", template) + + expect_lt(length(officer::read_pptx(out_null)), length(officer::read_pptx(out_full))) + }) + + it("omits linplot slide when linplot is not in slide_sections", { + slides <- base_slides + attr(slides, "slide_sections") <- c("meanplot", "statistics", "ind_plots", "ind_params") + # linplot deliberately omitted + + out_with <- tempfile(fileext = ".pptx") + out_without <- tempfile(fileext = ".pptx") + + create_pptx_dose_slides(base_slides, out_with, "NCA", template) + create_pptx_dose_slides(slides, out_without, "NCA", template) + + expect_lt(length(officer::read_pptx(out_without)), length(officer::read_pptx(out_with))) + }) + + it("omits boxplot slide when boxplot is not in slide_sections", { + slides <- base_slides + attr(slides, "slide_sections") <- c( + "meanplot", "statistics", "ind_plots", "ind_params", "linplot" + ) + # boxplot deliberately omitted + + out_with <- tempfile(fileext = ".pptx") + out_without <- tempfile(fileext = ".pptx") + + create_pptx_dose_slides(base_slides, out_with, "NCA", template) + create_pptx_dose_slides(slides, out_without, "NCA", template) + + expect_lt(length(officer::read_pptx(out_without)), length(officer::read_pptx(out_with))) + }) + + it("includes boxplot slide when only boxplot is in slide_sections", { + slides <- base_slides + attr(slides, "slide_sections") <- c("boxplot") + out_base <- tempfile(fileext = ".pptx") + out_box <- tempfile(fileext = ".pptx") + create_pptx_dose_slides(base_slides, out_base, "NCA", template) + create_pptx_dose_slides(slides, out_box, "NCA", template) + expect_gt(length(officer::read_pptx(out_box)), 1) # at least one content slide + expect_lt(length(officer::read_pptx(out_box)), + length(officer::read_pptx(out_base))) # fewer than all sections + }) + + it("does not create an orphan header slide when group ind_params and ind_plots are both empty", { + # When the second group has empty ind_params (the bug scenario), the current code still + # adds the group header/covariate table slide via add_pptx_sl_table() before the + # purrr::reduce loop, leaving an orphan header with no per-subject slides following it. + # A correct implementation produces 2 fewer slides for the empty group + # (1 fewer header + 1 fewer subject) vs a group with one subject. + slides_g2_empty <- list( + list( + info = data.frame(group = "A"), group = "Parent", + statistics = data.frame(stat = "Mean", value = 1), + meanplot = ggplot2::ggplot(), linplot = ggplot2::ggplot(), + boxplot = list(), + ind_params = list(SUBJ01 = data.frame(param = "CMAX", value = 1)), + ind_plots = list(SUBJ01 = ggplot2::ggplot()) + ), + list( + info = data.frame(group = "B"), group = "Metabolite", + statistics = data.frame(stat = "Mean", value = 2), + meanplot = ggplot2::ggplot(), linplot = ggplot2::ggplot(), + boxplot = list(), + ind_params = list(), # empty — no subjects for group 2 + ind_plots = list() + ) + ) + slides_g2_with_subj <- slides_g2_empty + slides_g2_with_subj[[2]]$ind_params <- list(SUBJ01 = data.frame(param = "CMAX", value = 2)) + slides_g2_with_subj[[2]]$ind_plots <- list(SUBJ01 = ggplot2::ggplot()) + + attr(slides_g2_empty, "slide_sections") <- c("ind_plots", "ind_params", "meanplot") + attr(slides_g2_with_subj, "slide_sections") <- c("ind_plots", "ind_params", "meanplot") + + out_empty <- tempfile(fileext = ".pptx") + out_subj <- tempfile(fileext = ".pptx") + create_pptx_dose_slides(slides_g2_empty, out_empty, "NCA", template) + create_pptx_dose_slides(slides_g2_with_subj, out_subj, "NCA", template) + + n_empty <- length(officer::read_pptx(out_empty)) + n_subj <- length(officer::read_pptx(out_subj)) + # Group 2 with one subject = 1 header slide + 1 per-subject slide = 2 more slides + # Currently FAILS (difference is 1) because the orphan header is still created + expect_equal(n_subj - n_empty, 2) + }) + + it("omits additional analysis entry when its name is not in slide_sections", { + slides_one <- base_slides + attr(slides_one, "additional_analysis") <- list( + matrix_ratios = data.frame(Ratio_Type = "A/B", Ratio = 1.2), + excretion_summary = data.frame(USUBJID = "01", FE = 45) + ) + attr(slides_one, "slide_sections") <- c( + "ind_plots", "meanplot", "statistics", "ind_params", "matrix_ratios" + # excretion_summary deliberately omitted + ) + + slides_both <- base_slides + attr(slides_both, "additional_analysis") <- list( + matrix_ratios = data.frame(Ratio_Type = "A/B", Ratio = 1.2), + excretion_summary = data.frame(USUBJID = "01", FE = 45) + ) + attr(slides_both, "slide_sections") <- c( + "ind_plots", "meanplot", "statistics", "ind_params", "matrix_ratios", "excretion_summary" + ) + + out_one <- tempfile(fileext = ".pptx") + out_both <- tempfile(fileext = ".pptx") + + create_pptx_dose_slides(slides_one, out_one, "NCA", template) + create_pptx_dose_slides(slides_both, out_both, "NCA", template) + + expect_lt(length(officer::read_pptx(out_one)), length(officer::read_pptx(out_both))) + }) +}) diff --git a/tests/testthat/test-quarto-utils.R b/tests/testthat/test-quarto-utils.R new file mode 100644 index 000000000..2d33f8e55 --- /dev/null +++ b/tests/testthat/test-quarto-utils.R @@ -0,0 +1,325 @@ +describe("create_qmd_dose_slides", { + base_slides <- list( + list( + info = data.frame(group = "A"), + statistics = data.frame(stat = "Mean", value = 1), + meanplot = ggplot2::ggplot(), + linplot = ggplot2::ggplot(), + boxplot = list(AUCIFO = ggplot2::ggplot()), + ind_params = list(SUBJ01 = data.frame(param = "CMAX", value = 1)), + ind_plots = list(SUBJ01 = ggplot2::ggplot()) + ) + ) + + it("omits individual plots when ind_plots is not in slide_sections", { + slides <- base_slides + attr(slides, "slide_sections") <- c("meanplot", "statistics", "ind_params") + out_file <- tempfile(fileext = ".qmd") + + create_qmd_dose_slides(slides, out_file, "NCA Results", use_plotly = FALSE) + content <- paste(readLines(out_file, warn = FALSE), collapse = "\n") + + expect_false(grepl("ind_plots", content, fixed = TRUE)) + }) + + it("includes individual plots when ind_plots is in slide_sections", { + slides <- base_slides + attr(slides, "slide_sections") <- c("ind_plots", "meanplot", "statistics", "ind_params") + out_file <- tempfile(fileext = ".qmd") + + create_qmd_dose_slides(slides, out_file, "NCA Results", use_plotly = FALSE) + content <- paste(readLines(out_file, warn = FALSE), collapse = "\n") + + expect_true(grepl("ind_plots", content, fixed = TRUE)) + }) + + it("includes all sections when slide_sections attribute is NULL (backwards compat)", { + out_file <- tempfile(fileext = ".qmd") + create_qmd_dose_slides(base_slides, out_file, "NCA Results", use_plotly = FALSE) + content <- paste(readLines(out_file, warn = FALSE), collapse = "\n") + + expect_true(grepl("ind_plots", content, fixed = TRUE)) + expect_true(grepl("meanplot", content, fixed = TRUE)) + }) + + it("adds additional analysis section generically for any non-empty data frame in the attribute", { + slides <- base_slides + attr(slides, "additional_analysis") <- list( + matrix_ratios = data.frame(Ratio_Type = "A/B", Ratio = 1.2), + excretion_summary = data.frame(USUBJID = "01", FE = 45) + ) + out_file <- tempfile(fileext = ".qmd") + + create_qmd_dose_slides(slides, out_file, "NCA Results", use_plotly = FALSE) + content <- paste(readLines(out_file, warn = FALSE), collapse = "\n") + + expect_true(grepl("# Additional Analysis Figures", content, fixed = TRUE)) + expect_true(grepl("Matrix Ratios", content, fixed = TRUE)) + expect_true(grepl("Excretion Summary", content, fixed = TRUE)) + }) + + it("skips boxplot expression when boxplot data is NULL", { + slides_null_box <- list( + list( + info = data.frame(group = "A"), + statistics = data.frame(stat = "Mean", value = 1), + meanplot = ggplot2::ggplot(), + linplot = ggplot2::ggplot(), + boxplot = list(), + ind_params = list(SUBJ01 = data.frame(param = "CMAX", value = 1)), + ind_plots = list(SUBJ01 = ggplot2::ggplot()) + ) + ) + out_file <- tempfile(fileext = ".qmd") + + create_qmd_dose_slides(slides_null_box, out_file, "NCA Results", use_plotly = FALSE) + content <- paste(readLines(out_file, warn = FALSE), collapse = "\n") + + expect_false(grepl("boxplot", content, fixed = TRUE)) + }) + + it("omits linplot expression when linplot is not in slide_sections", { + slides <- base_slides + attr(slides, "slide_sections") <- c("meanplot", "statistics", "ind_plots", "ind_params") + out_file <- tempfile(fileext = ".qmd") + + create_qmd_dose_slides(slides, out_file, "NCA Results", use_plotly = FALSE) + content <- paste(readLines(out_file, warn = FALSE), collapse = "\n") + + expect_false(grepl("linplot", content, fixed = TRUE)) + }) + + it("includes linplot expression when linplot is in slide_sections", { + slides <- base_slides + attr(slides, "slide_sections") <- c( + "meanplot", "statistics", "ind_plots", "ind_params", "linplot" + ) + out_file <- tempfile(fileext = ".qmd") + + create_qmd_dose_slides(slides, out_file, "NCA Results", use_plotly = FALSE) + content <- paste(readLines(out_file, warn = FALSE), collapse = "\n") + + expect_true(grepl("linplot", content, fixed = TRUE)) + }) + + it("omits boxplot expression when boxplot is not in slide_sections", { + slides <- base_slides + attr(slides, "slide_sections") <- c( + "meanplot", "statistics", "ind_plots", "ind_params", "linplot" + ) + out_file <- tempfile(fileext = ".qmd") + + create_qmd_dose_slides(slides, out_file, "NCA Results", use_plotly = FALSE) + content <- paste(readLines(out_file, warn = FALSE), collapse = "\n") + + expect_false(grepl("boxplot", content, fixed = TRUE)) + }) + + it("includes boxplot expression when boxplot is in slide_sections", { + slides <- base_slides + attr(slides, "slide_sections") <- c( + "meanplot", "statistics", "ind_plots", "ind_params", "linplot", "boxplot" + ) + out_file <- tempfile(fileext = ".qmd") + + create_qmd_dose_slides(slides, out_file, "NCA Results", use_plotly = FALSE) + content <- paste(readLines(out_file, warn = FALSE), collapse = "\n") + + expect_true(grepl("boxplot", content, fixed = TRUE)) + }) + + it("includes boxplot when only boxplot is in slide_sections", { + slides <- base_slides + attr(slides, "slide_sections") <- c("boxplot") + out_file <- tempfile(fileext = ".qmd") + create_qmd_dose_slides(slides, out_file, "NCA Results", use_plotly = FALSE) + content <- paste(readLines(out_file, warn = FALSE), collapse = "\n") + expect_true(grepl("boxplot", content, fixed = TRUE)) + expect_false(grepl("meanplot", content, fixed = TRUE)) + }) + + it("omits additional analysis entry when its name is not in slide_sections", { + slides <- base_slides + attr(slides, "additional_analysis") <- list( + matrix_ratios = data.frame(Ratio_Type = "A/B", Ratio = 1.2), + excretion_summary = data.frame(USUBJID = "01", FE = 45) + ) + attr(slides, "slide_sections") <- c( + "ind_plots", "meanplot", "statistics", "ind_params", "matrix_ratios" + ) + out_file <- tempfile(fileext = ".qmd") + + create_qmd_dose_slides(slides, out_file, "NCA Results", use_plotly = FALSE) + content <- paste(readLines(out_file, warn = FALSE), collapse = "\n") + + expect_true(grepl("Matrix Ratios", content, fixed = TRUE)) + expect_false(grepl("Excretion Summary", content, fixed = TRUE)) + }) + + it("omits additional analysis section entirely when no entries are selected", { + slides <- base_slides + attr(slides, "additional_analysis") <- list( + matrix_ratios = data.frame(Ratio_Type = "A/B", Ratio = 1.2) + ) + attr(slides, "slide_sections") <- c("ind_plots", "meanplot", "statistics", "ind_params") + out_file <- tempfile(fileext = ".qmd") + + create_qmd_dose_slides(slides, out_file, "NCA Results", use_plotly = FALSE) + content <- paste(readLines(out_file, warn = FALSE), collapse = "\n") + + expect_false(grepl("# Additional Analysis Figures", content, fixed = TRUE)) + }) + + it("silently omits empty data frame entries in additional_analysis", { + slides <- base_slides + attr(slides, "additional_analysis") <- list( + matrix_ratios = data.frame(Ratio_Type = "A/B", Ratio = 1.2), + empty_table = data.frame() + ) + out_file <- tempfile(fileext = ".qmd") + + create_qmd_dose_slides(slides, out_file, "NCA Results", use_plotly = FALSE) + content <- paste(readLines(out_file, warn = FALSE), collapse = "\n") + + expect_true(grepl("Matrix Ratios", content, fixed = TRUE)) + expect_false(grepl("Empty Table", content, fixed = TRUE)) + }) + + it("emits a NULL plot expression when ind_params is selected but ind_plots is not", { + slides <- base_slides + attr(slides, "slide_sections") <- c("meanplot", "statistics", "ind_params") + out_file <- tempfile(fileext = ".qmd") + + create_qmd_dose_slides(slides, out_file, "NCA Results", use_plotly = FALSE) + content <- paste(readLines(out_file, warn = FALSE), collapse = "\n") + + # ind_params table slide is still written + expect_true(grepl("ind_params", content, fixed = TRUE)) + # ind_plots expression is absent + expect_false(grepl("ind_plots", content, fixed = TRUE)) + }) + + it("includes # Group 1 heading when summary sections are selected", { + slides <- base_slides + attr(slides, "slide_sections") <- c("meanplot", "statistics") + out_file <- tempfile(fileext = ".qmd") + + create_qmd_dose_slides(slides, out_file, "NCA Results", use_plotly = FALSE) + content <- paste(readLines(out_file, warn = FALSE), collapse = "\n") + + expect_true(grepl("# Group 1", content, fixed = TRUE)) + }) + + it("includes # Group 1 (Individual) heading when individual sections are selected", { + slides <- base_slides + attr(slides, "slide_sections") <- c("ind_plots", "ind_params") + out_file <- tempfile(fileext = ".qmd") + + create_qmd_dose_slides(slides, out_file, "NCA Results", use_plotly = FALSE) + content <- paste(readLines(out_file, warn = FALSE), collapse = "\n") + + expect_true(grepl("# Group 1 (Individual)", content, fixed = TRUE)) + }) + + it("includes # Extra Figures when both summary and individual sections are selected", { + slides <- base_slides + attr(slides, "slide_sections") <- c("meanplot", "ind_plots") + out_file <- tempfile(fileext = ".qmd") + + create_qmd_dose_slides(slides, out_file, "NCA Results", use_plotly = FALSE) + content <- paste(readLines(out_file, warn = FALSE), collapse = "\n") + + expect_true(grepl("# Extra Figures", content, fixed = TRUE)) + }) + + it("omits # Extra Figures when only individual sections are selected", { + slides <- base_slides + attr(slides, "slide_sections") <- c("ind_plots", "ind_params") + out_file <- tempfile(fileext = ".qmd") + + create_qmd_dose_slides(slides, out_file, "NCA Results", use_plotly = FALSE) + content <- paste(readLines(out_file, warn = FALSE), collapse = "\n") + + expect_false(grepl("# Extra Figures", content, fixed = TRUE)) + }) + + it("omits # Extra Figures when only summary sections are selected", { + slides <- base_slides + attr(slides, "slide_sections") <- c("meanplot", "statistics") + out_file <- tempfile(fileext = ".qmd") + + create_qmd_dose_slides(slides, out_file, "NCA Results", use_plotly = FALSE) + content <- paste(readLines(out_file, warn = FALSE), collapse = "\n") + + expect_false(grepl("# Extra Figures", content, fixed = TRUE)) + }) + + it("includes toc: true in YAML header", { + out_file <- tempfile(fileext = ".qmd") + create_qmd_dose_slides(base_slides, out_file, "NCA Results", use_plotly = FALSE) + content <- paste(readLines(out_file, warn = FALSE), collapse = "\n") + + expect_true(grepl("toc: true", content, fixed = TRUE)) + }) + + it("includes info table on section header, not repeated per subject", { + slides <- list( + list( + info = data.frame(group = "A"), + statistics = data.frame(stat = "Mean", value = 1), + meanplot = ggplot2::ggplot(), + linplot = ggplot2::ggplot(), + boxplot = list(AUCIFO = ggplot2::ggplot()), + ind_params = list( + SUBJ01 = data.frame(param = "CMAX", value = 1), + SUBJ02 = data.frame(param = "CMAX", value = 2) + ), + ind_plots = list( + SUBJ01 = ggplot2::ggplot(), + SUBJ02 = ggplot2::ggplot() + ) + ) + ) + attr(slides, "slide_sections") <- c("meanplot", "ind_plots", "ind_params") + out_file <- tempfile(fileext = ".qmd") + + create_qmd_dose_slides(slides, out_file, "NCA Results", use_plotly = FALSE) + content <- paste(readLines(out_file, warn = FALSE), collapse = "\n") + + # Info table referenced once per section header (summary + individual = 2), + # NOT once per subject (which would be 3: 1 summary + 2 subjects) + n_info <- lengths(regmatches(content, gregexpr("res_dose_slides\\[\\[1\\]\\]\\$info", content))) + expect_equal(n_info, 2L) + }) + + it("does not create an orphan header when group ind_params and ind_plots are both empty", { + slides <- list( + list( + info = data.frame(group = "A"), + statistics = data.frame(stat = "Mean", value = 1), + meanplot = ggplot2::ggplot(), + linplot = ggplot2::ggplot(), + boxplot = list(), + ind_params = list(SUBJ01 = data.frame(param = "CMAX", value = 1)), + ind_plots = list(SUBJ01 = ggplot2::ggplot()) + ), + list( + info = data.frame(group = "B"), + statistics = data.frame(stat = "Mean", value = 2), + meanplot = ggplot2::ggplot(), + linplot = ggplot2::ggplot(), + boxplot = list(), + ind_params = list(), # empty — no subjects for group 2 + ind_plots = list() + ) + ) + attr(slides, "slide_sections") <- c("ind_plots", "ind_params", "meanplot") + out_file <- tempfile(fileext = ".qmd") + + create_qmd_dose_slides(slides, out_file, "NCA Results", use_plotly = FALSE) + content <- paste(readLines(out_file, warn = FALSE), collapse = "\n") + + expect_true(grepl("Group 1 (Individual)", content, fixed = TRUE)) + expect_false(grepl("Group 2 (Individual)", content, fixed = TRUE)) + }) +}) diff --git a/tests/testthat/test-zip-utils.R b/tests/testthat/test-zip-utils.R index 86513325b..0d3f8d2bc 100644 --- a/tests/testthat/test-zip-utils.R +++ b/tests/testthat/test-zip-utils.R @@ -42,3 +42,131 @@ describe(".build_exploration_allowlist", { expect_equal(result, character(0)) }) }) + +describe(".export_slides slide_sections threading", { + it("attaches slide_sections attribute when provided", { + skip(paste0( + "Requires full NCA session setup; ", + "covered by test-quarto-utils.R and test-officer-utils.R unit tests" + )) + }) +}) + +describe("get_dose_esc_results", { + it("stores NULL for boxplot when boxplot_parameters is not in the NCA results", { + res <- get_dose_esc_results( + o_nca = FIXTURE_PKNCA_RES, + group_by_vars = "DOSNOA", + facet_vars = "ATPTREF", + boxplot_parameters = "NONEXISTENT_PARAM" + ) + + boxplots <- lapply(res, `[[`, "boxplot") + expect_true(all(vapply( + boxplots, + function(x) is.list(x) && all(vapply(x, is.null, logical(1))), + logical(1) + ))) + }) + + it("stores a ggplot for boxplot when boxplot_parameters is in the NCA results", { + res <- get_dose_esc_results( + o_nca = FIXTURE_PKNCA_RES, + group_by_vars = "DOSNOA", + facet_vars = "ATPTREF", + boxplot_parameters = "CMAX" + ) + + boxplots <- lapply(res, `[[`, "boxplot") + expect_true(all(vapply( + boxplots, + function(x) is.list(x) && all(vapply(x, function(p) inherits(p, "ggplot"), logical(1))), + logical(1) + ))) + }) + + it("produces no boxplot entries when boxplot_parameters is empty (character(0))", { + res <- get_dose_esc_results( + o_nca = FIXTURE_PKNCA_RES, + group_by_vars = "DOSNOA", + facet_vars = "ATPTREF", + boxplot_parameters = character(0) + ) + boxplots <- lapply(res, `[[`, "boxplot") + expect_true(all(vapply( + boxplots, + function(x) is.list(x) && length(x) == 0, + logical(1) + ))) + }) + + it("produces a boxplot for the explicitly requested parameter", { + res <- get_dose_esc_results( + o_nca = FIXTURE_PKNCA_RES, + group_by_vars = "DOSNOA", + facet_vars = "ATPTREF", + boxplot_parameters = "LAMZHL" + ) + # Every group's boxplot list should contain a ggplot for LAMZHL + boxplots <- lapply(res, `[[`, "boxplot") + expect_true(all(vapply( + boxplots, + function(x) is.list(x) && inherits(x[["LAMZHL"]], "ggplot"), + logical(1) + ))) + # The y-axis label references LAMZHL + expect_true(any(vapply( + boxplots, + function(x) grepl("LAMZHL", x[["LAMZHL"]]$labels$y), + logical(1) + ))) + }) + + it("ind_params is non-empty for every group when group_by_vars includes the analyte column", { + # This mirrors the real app call in prepare_export_files() using the analyte + # grouping column. Previously, groups were derived from intervals (which lacks + # the analyte column), causing empty ind_params for metabolite groups. + group_by_vars <- setdiff( + dplyr::group_vars(FIXTURE_PKNCA_RES), + FIXTURE_PKNCA_RES$data$conc$columns$subject + ) + res <- get_dose_esc_results( + o_nca = FIXTURE_PKNCA_RES, + group_by_vars = group_by_vars, + facet_vars = "ATPTREF", + boxplot_parameters = character(0) + ) + ind_params_lengths <- vapply(res, function(g) length(g$ind_params), integer(1)) + expect_true( + all(ind_params_lengths > 0), + label = paste0( + "Groups with empty ind_params: ", + paste(names(ind_params_lengths)[ind_params_lengths == 0], collapse = ", ") + ) + ) + }) + + it("creates slides only for groups present in o_nca$result, not all conc data groups", { + # Simulates a specimen (URINE) present in conc data but not in NCA intervals. + # When groups are derived from conc$data, a spurious URINE group is created. + # When derived from result, only the 4 analyzed groups appear. + fixture_extra <- FIXTURE_PKNCA_RES + urine_rows <- FIXTURE_PKNCA_RES$data$conc$data[1:5, ] + urine_rows$PCSPEC <- "URINE" + fixture_extra$data$conc$data <- rbind(FIXTURE_PKNCA_RES$data$conc$data, urine_rows) + + group_by_vars <- setdiff( + dplyr::group_vars(FIXTURE_PKNCA_RES), + FIXTURE_PKNCA_RES$data$conc$columns$subject + ) + n_result_groups <- nrow(unique(FIXTURE_PKNCA_RES$result[, c(group_by_vars, "ATPTREF")])) + + res <- get_dose_esc_results( + o_nca = fixture_extra, + group_by_vars = group_by_vars, + facet_vars = "ATPTREF", + boxplot_parameters = character(0) + ) + expect_equal(length(res), n_result_groups) + }) +})