🗃️ decorators feature branch

DESCRIPTION

@@ -35,6 +35,7 @@ Imports:
     DT (>= 0.13),
     forcats (>= 1.0.0),
     grid,
+    lifecycle (>= 0.2.0),
     scales,
     shinyjs,
     shinyTree (>= 0.2.8),
@@ -84,7 +85,7 @@ VignetteBuilder:
 Config/Needs/verdepcheck: haleyjeppson/ggmosaic, tidyverse/ggplot2,
     rstudio/shiny, insightsengineering/teal,
     insightsengineering/teal.transform, mllg/checkmate, tidyverse/dplyr,
-    rstudio/DT, tidyverse/forcats, r-lib/scales, daattali/shinyjs,
+    rstudio/DT, tidyverse/forcats, r-lib/lifecycle, r-lib/scales, daattali/shinyjs,
     shinyTree/shinyTree, rstudio/shinyvalidate, dreamRs/shinyWidgets,
     tidyverse/stringr, insightsengineering/teal.code,
     insightsengineering/teal.data, insightsengineering/teal.logger,

R/roxygen2_templates.R

@@ -0,0 +1,30 @@
+# nocov start
+roxygen_decorators_param <- function(module_name) {
+  paste(
+    sep = " ",
+    lifecycle::badge("experimental"),
+    " (`list` of `teal_transform_module`, named `list` of `teal_transform_module` or",
+    "`NULL`) optional, if not `NULL`, decorator for tables or plots included in the module.",
+    "When a named list of `teal_transform_module`, the decorators are applied to the",
+    "respective output objects.\n\n",
+    "Otherwise, the decorators are applied to all objects, which is equivalent as using the name `default`.\n\n",
+    sprintf("See section \"Decorating `%s`\"", module_name),
+    "below for more details."
+  )
+}
+
+roxygen_ggplot2_args_param <- function(...) {
+  paste(
+    sep = " ",
+    "(`ggplot2_args`) optional, object created by [`teal.widgets::ggplot2_args()`]",
+    "with settings for all the plots or named list of `ggplot2_args` objects for plot-specific settings.",
+    "The argument is merged with options variable `teal.ggplot2_args` and default module setup.\n\n",
+    sprintf(
+      "List names should match the following: `c(\"default\", %s)`.\n\n",
+      paste("\"", unlist(rlang::list2(...)), "\"", collapse = ", ", sep = "")
+    ),
+    "For more details see the vignette: `vignette(\"custom-ggplot2-arguments\", package = \"teal.widgets\")`."
+  )
+}
+
+# nocov end

R/tm_a_pca.R

@@ -13,16 +13,46 @@
 #' It controls the font size for plot titles, axis labels, and legends.
 #' - If vector of `length == 1` then the font sizes will have a fixed size.
 #' - while vector of `value`, `min`, and `max` allows dynamic adjustment.
-#' @templateVar ggnames "Elbow plot", "Circle plot", "Biplot", "Eigenvector plot"
-#' @template ggplot2_args_multi
+#' @param ggplot2_args `r roxygen_ggplot2_args_param("Elbow plot", "Circle plot", "Biplot", "Eigenvector plot")`
+#' @param decorators `r roxygen_decorators_param("tm_a_pca")`
 #'
 #' @inherit shared_params return
 #'
+#' @section Decorating `tm_a_pca`:
+#'
+#' This module generates the following objects, which can be modified in place using decorators:
+#' - `elbow_plot` (`ggplot2`)
+#' - `circle_plot` (`ggplot2`)
+#' - `biplot` (`ggplot2`)
+#' - `eigenvector_plot` (`ggplot2`)
+#'
+#' Decorators can be applied to all outputs or only to specific objects using a
+#' named list of `teal_transform_module` objects.
+#' The `"default"` name is reserved for decorators that are applied to all outputs.
+#' See code snippet below:
+#'
+#' ```
+#' tm_a_pca(
+#'    ..., # arguments for module
+#'    decorators = list(
+#'      default = list(teal_transform_module(...)), # applied to all outputs
+#'      elbow_plot = list(teal_transform_module(...)), # applied only to `elbow_plot` output
+#'      circle_plot = list(teal_transform_module(...)) # applied only to `circle_plot` output
+#'      biplot = list(teal_transform_module(...)) # applied only to `biplot` output
+#'      eigenvector_plot = list(teal_transform_module(...)) # applied only to `eigenvector_plot` output
+#'    )
+#' )
+#' ```
+#'
+#' For additional details and examples of decorators, refer to the vignette
+#' `vignette("decorate-modules-output", package = "teal")` or the [`teal_transform_module()`] documentation.
+#'
 #' @examplesShinylive
 #' library(teal.modules.general)
 #' interactive <- function() TRUE
 #' {{ next_example }}
 #' @examples
+#'
 #' # general data example
 #' data <- teal_data()
 #' data <- within(data, {
@@ -58,6 +88,7 @@
 #' interactive <- function() TRUE
 #' {{ next_example }}
 #' @examples
+#'
 #' # CDISC data example
 #' data <- teal_data()
 #' data <- within(data, {
@@ -102,7 +133,8 @@ tm_a_pca <- function(label = "Principal Component Analysis",
                      alpha = c(1, 0, 1),
                      size = c(2, 1, 8),
                      pre_output = NULL,
-                     post_output = NULL) {
+                     post_output = NULL,
+                     decorators = NULL) {
   message("Initializing tm_a_pca")
 
   # Normalize the parameters
@@ -152,6 +184,10 @@ tm_a_pca <- function(label = "Principal Component Analysis",
 
   checkmate::assert_multi_class(pre_output, c("shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE)
   checkmate::assert_multi_class(post_output, c("shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE)
+
+  available_decorators <- c("elbow_plot", "circle_plot", "biplot", "eigenvector_plot")
+  decorators <- normalize_decorators(decorators)
+  assert_decorators(decorators, null.ok = TRUE, available_decorators)
   # End of assertions
 
   # Make UI args
@@ -169,7 +205,8 @@ tm_a_pca <- function(label = "Principal Component Analysis",
       list(
         plot_height = plot_height,
         plot_width = plot_width,
-        ggplot2_args = ggplot2_args
+        ggplot2_args = ggplot2_args,
+        decorators = decorators
       )
     ),
     datanames = teal.transform::get_extract_datanames(data_extract_list)
@@ -224,6 +261,34 @@ ui_a_pca <- function(id, ...) {
               label = "Plot type",
               choices = args$plot_choices,
               selected = args$plot_choices[1]
+            ),
+            conditionalPanel(
+              condition = sprintf("input['%s'] == 'Elbow plot'", ns("plot_type")),
+              ui_decorate_teal_data(
+                ns("d_elbow_plot"),
+                decorators = select_decorators(args$decorators, "elbow_plot")
+              )
+            ),
+            conditionalPanel(
+              condition = sprintf("input['%s'] == 'Circle plot'", ns("plot_type")),
+              ui_decorate_teal_data(
+                ns("d_circle_plot"),
+                decorators = select_decorators(args$decorators, "circle_plot")
+              )
+            ),
+            conditionalPanel(
+              condition = sprintf("input['%s'] == 'Biplot'", ns("plot_type")),
+              ui_decorate_teal_data(
+                ns("d_biplot"),
+                decorators = select_decorators(args$decorators, "biplot")
+              )
+            ),
+            conditionalPanel(
+              condition = sprintf("input['%s'] == 'Eigenvector plot'", ns("plot_type")),
+              ui_decorate_teal_data(
+                ns("d_eigenvector_plot"),
+                decorators = select_decorators(args$decorators, "eigenvector_plot")
+              )
             )
           ),
           teal.widgets::panel_item(
@@ -289,7 +354,7 @@ ui_a_pca <- function(id, ...) {
 }
 
 # Server function for the PCA module
-srv_a_pca <- function(id, data, reporter, filter_panel_api, dat, plot_height, plot_width, ggplot2_args) {
+srv_a_pca <- function(id, data, reporter, filter_panel_api, dat, plot_height, plot_width, ggplot2_args, decorators) {
   with_reporter <- !missing(reporter) && inherits(reporter, "Reporter")
   with_filter <- !missing(filter_panel_api) && inherits(filter_panel_api, "FilterPanelAPI")
   checkmate::assert_class(data, "reactive")
@@ -549,7 +614,7 @@ srv_a_pca <- function(id, data, reporter, filter_panel_api, dat, plot_height, pl
               )
 
             cols <- c(getOption("ggplot2.discrete.colour"), c("lightblue", "darkred", "black"))[1:3]
-            g <- ggplot(mapping = aes_string(x = "component", y = "value")) +
+            elbow_plot <- ggplot(mapping = aes_string(x = "component", y = "value")) +
               geom_bar(
                 aes(fill = "Single variance"),
                 data = dplyr::filter(elb_dat, metric == "Proportion of Variance"),
@@ -569,8 +634,6 @@ srv_a_pca <- function(id, data, reporter, filter_panel_api, dat, plot_height, pl
               scale_fill_manual(values = c("Cumulative variance" = cols[2], "Single variance" = cols[1])) +
               ggthemes +
               themes
-
-            print(g)
           },
           env = list(
             ggthemes = parsed_ggplot2_args$ggtheme,
@@ -628,7 +691,7 @@ srv_a_pca <- function(id, data, reporter, filter_panel_api, dat, plot_height, pl
               y = sin(seq(0, 2 * pi, length.out = 100))
             )
 
-            g <- ggplot(pca_rot) +
+            circle_plot <- ggplot(pca_rot) +
               geom_point(aes_string(x = x_axis, y = y_axis)) +
               geom_label(
                 aes_string(x = x_axis, y = y_axis, label = "label"),
@@ -640,7 +703,6 @@ srv_a_pca <- function(id, data, reporter, filter_panel_api, dat, plot_height, pl
               labs +
               ggthemes +
               themes
-            print(g)
           },
           env = list(
             x_axis = x_axis,
@@ -861,8 +923,7 @@ srv_a_pca <- function(id, data, reporter, filter_panel_api, dat, plot_height, pl
         qenv,
         substitute(
           expr = {
-            g <- plot_call
-            print(g)
+            biplot <- plot_call
           },
           env = list(
             plot_call = Reduce(function(x, y) call("+", x, y), pca_plot_biplot_expr)
@@ -871,8 +932,8 @@ srv_a_pca <- function(id, data, reporter, filter_panel_api, dat, plot_height, pl
       )
     }
 
-    # plot pc_var ----
-    plot_pc_var <- function(base_q) {
+    # plot eigenvector_plot ----
+    plot_eigenvector <- function(base_q) {
       pc <- input$pc
       ggtheme <- input$ggtheme
 
@@ -938,10 +999,7 @@ srv_a_pca <- function(id, data, reporter, filter_panel_api, dat, plot_height, pl
           expr = {
             pca_rot <- pca$rotation[, pc, drop = FALSE] %>%
               dplyr::as_tibble(rownames = "Variable")
-
-            g <- plot_call
-
-            print(g)
+            eigenvector_plot <- plot_call
           },
           env = list(
             pc = pc,
@@ -951,23 +1009,54 @@ srv_a_pca <- function(id, data, reporter, filter_panel_api, dat, plot_height, pl
       )
     }
 
-    # plot final ----
-    output_q <- reactive({
-      req(computation())
-      teal::validate_inputs(iv_r())
-      teal::validate_inputs(iv_extra, header = "Plot settings are required")
+    # qenvs ---
+    output_q <- lapply(
+      list(
+        elbow_plot = plot_elbow,
+        circle_plot = plot_circle,
+        biplot = plot_biplot,
+        eigenvector_plot = plot_eigenvector
+      ),
+      function(fun) {
+        reactive({
+          req(computation())
+          teal::validate_inputs(iv_r())
+          teal::validate_inputs(iv_extra, header = "Plot settings are required")
+          fun(computation())
+        })
+      }
+    )
 
-      switch(input$plot_type,
-        "Elbow plot" = plot_elbow(computation()),
-        "Circle plot" = plot_circle(computation()),
-        "Biplot" = plot_biplot(computation()),
-        "Eigenvector plot" = plot_pc_var(computation()),
+    decorated_q <- mapply(
+      function(obj_name, q) {
+        srv_decorate_teal_data(
+          id = sprintf("d_%s", obj_name),
+          data = q,
+          decorators = select_decorators(decorators, obj_name),
+          expr = reactive({
+            substitute(print(.plot), env = list(.plot = as.name(obj_name)))
+          }),
+          expr_is_reactive = TRUE
+        )
+      },
+      names(output_q),
+      output_q
+    )
+
+    # plot final ----
+    decorated_output_q <- reactive({
+      switch(req(input$plot_type),
+        "Elbow plot" = decorated_q$elbow_plot(),
+        "Circle plot" = decorated_q$circle_plot(),
+        "Biplot" = decorated_q$biplot(),
+        "Eigenvector plot" = decorated_q$eigenvector_plot(),
         stop("Unknown plot")
       )
     })
 
     plot_r <- reactive({
-      output_q()[["g"]]
+      plot_name <- gsub(" ", "_", tolower(req(input$plot_type)))
+      req(decorated_output_q())[[plot_name]]
     })
 
     pws <- teal.widgets::plot_with_settings_srv(
@@ -1034,7 +1123,7 @@ srv_a_pca <- function(id, data, reporter, filter_panel_api, dat, plot_height, pl
 
     teal.widgets::verbatim_popup_srv(
       id = "rcode",
-      verbatim_content = reactive(teal.code::get_code(output_q())),
+      verbatim_content = reactive(teal.code::get_code(req(decorated_output_q()))),
       title = "R Code for PCA"
     )
 
@@ -1057,7 +1146,7 @@ srv_a_pca <- function(id, data, reporter, filter_panel_api, dat, plot_height, pl
           card$append_text("Comment", "header3")
           card$append_text(comment)
         }
-        card$append_src(teal.code::get_code(output_q()))
+        card$append_src(teal.code::get_code(req(decorated_output_q())))
         card
       }
       teal.reporter::simple_reporter_srv("simple_reporter", reporter = reporter, card_fun = card_fun)