Feat: options to customise outputs in ppt power point (#972, compatible with #1033 changes) and output/zip file validation in modal

DESCRIPTION

@@ -31,7 +31,6 @@ Imports:
     ggplot2,
     glue,
     magrittr,
-    methods,
     PKNCA (>= 0.12.1),
     plotly (>= 4.11.0),
     purrr,

NAMESPACE

@@ -113,9 +113,8 @@ 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(glue,glue)
 importFrom(ggplot2,aes)
 importFrom(ggplot2,facet_wrap)
 importFrom(ggplot2,geom_point)
@@ -129,9 +128,9 @@ importFrom(ggplot2,scale_colour_manual)
 importFrom(ggplot2,scale_shape_manual)
 importFrom(ggplot2,scale_x_continuous)
 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)

NEWS.md

@@ -41,10 +41,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
 * ZIP folder with results will now include the exploration tab outputs: individual plots, mean plots (#794)

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)