Updates "Decorators" to use name-based execution and new wrappers

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,20 +13,40 @@
 #' 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:
-#' - `plot` (`ggplot2`)
+#' - `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
@@ -165,7 +185,9 @@ 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)
 
-  checkmate::assert_list(decorators, "teal_transform_module", null.ok = TRUE)
+  available_decorators <- c("elbow_plot", "circle_plot", "biplot", "eigenvector_plot")
+  decorators <- normalize_decorators(decorators, available_decorators)
+  assert_decorators(decorators, null.ok = TRUE, available_decorators)
   # End of assertions
 
   # Make UI args
@@ -240,7 +262,22 @@ ui_a_pca <- function(id, ...) {
               choices = args$plot_choices,
               selected = args$plot_choices[1]
             ),
-            ui_transform_teal_data(ns("decorate"), transformators = args$decorators)
+            conditionalPanel(
+              condition = sprintf("input['%s'] == 'Elbow plot'", ns("plot_type")),
+              ui_decorate_teal_data(ns("d_elbow_plot"), decorators = subset_decorators("elbow_plot", args$decorators))
+            ),
+            conditionalPanel(
+              condition = sprintf("input['%s'] == 'Circle plot'", ns("plot_type")),
+              ui_decorate_teal_data(ns("d_circle_plot"), decorators = subset_decorators("circle_plot", args$decorators))
+            ),
+            conditionalPanel(
+              condition = sprintf("input['%s'] == 'Biplot'", ns("plot_type")),
+              ui_decorate_teal_data(ns("d_biplot"), decorators = subset_decorators("biplot", args$decorators))
+            ),
+            conditionalPanel(
+              condition = sprintf("input['%s'] == 'Eigenvector plot'", ns("plot_type")),
+              ui_decorate_teal_data(ns("d_eigenvector_plot"), decorators = subset_decorators("eigenvector_plot", args$decorators))
+            )
           ),
           teal.widgets::panel_item(
             title = "Pre-processing",
@@ -565,7 +602,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]
-            plot <- 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"),
@@ -642,7 +679,7 @@ srv_a_pca <- function(id, data, reporter, filter_panel_api, dat, plot_height, pl
               y = sin(seq(0, 2 * pi, length.out = 100))
             )
 
-            plot <- 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"),
@@ -874,7 +911,7 @@ srv_a_pca <- function(id, data, reporter, filter_panel_api, dat, plot_height, pl
         qenv,
         substitute(
           expr = {
-            plot <- plot_call
+            biplot <- plot_call
           },
           env = list(
             plot_call = Reduce(function(x, y) call("+", x, y), pca_plot_biplot_expr)
@@ -883,8 +920,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
 
@@ -950,7 +987,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")
-            plot <- plot_call
+            eigenvector_plot <- plot_call
           },
           env = list(
             pc = pc,
@@ -960,27 +997,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 = subset_decorators(obj_name, decorators),
+          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")
       )
     })
 
-    decorated_output_q_no_print <- srv_transform_teal_data("decorate", data = output_q, transformators = decorators)
-    decorated_output_q <- reactive(within(decorated_output_q_no_print(), expr = print(plot)))
-
     plot_r <- reactive({
-      req(output_q())
-      decorated_output_q()[["plot"]]
+      plot_name <- gsub(" ", "_", tolower(req(input$plot_type)))
+      req(decorated_output_q())[[plot_name]]
     })
 
     pws <- teal.widgets::plot_with_settings_srv(

R/tm_a_regression.R

@@ -37,8 +37,8 @@
 #'     It takes the form of `c(value, min, max)` and it is passed to the `value_min_max`
 #'     argument in `teal.widgets::optionalSliderInputValMinMax`.
 #'
-#' @templateVar ggnames `r regression_names`
-#' @template ggplot2_args_multi
+#' @param ggplot2_args `r roxygen_ggplot2_args_param(regression_names)`
+#' @param decorators `r roxygen_decorators_param("tm_a_regression")`
 #'
 #' @inherit shared_params return
 #'
@@ -1035,7 +1035,10 @@ srv_a_regression <- function(id,
   })
 }
 
-regression_names <- paste0(
-  '"Response vs Regressor", "Residuals vs Fitted", ',
-  '"Scale-Location", "Cook\'s distance", "Residuals vs Leverage"", "Cook\'s dist vs Leverage"'
+regression_names <- c(
+  "Response vs Regressor",
+  "Residuals vs Fitted",
+  "Scale-Location", "Cook's distance",
+  "Residuals vs Leverage",
+  "Cook's dist vs Leverage"
 )

R/tm_data_table.R

@@ -131,7 +131,8 @@ tm_data_table <- function(label = "Data Table",
   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)
 
-  checkmate::assert_list(decorators, "teal_transform_module", null.ok = TRUE)
+  decorators <- normalize_decorators(decorators, "table")
+  assert_decorators(decorators, null.ok = TRUE, "table")
   # End of assertions
 
   ans <- module(
@@ -296,7 +297,7 @@ ui_data_table <- function(id,
   tagList(
     teal.widgets::get_dt_rows(ns("data_table"), ns("dt_rows")),
     fluidRow(
-      ui_transform_teal_data(ns("decorate"), transformators = decorators),
+      ui_decorate_teal_data(ns("decorator"), decorators = subset_decorators("table", decorators)),
       teal.widgets::optionalSelectInput(
         ns("variables"),
         "Select variables:",
@@ -365,13 +366,15 @@ srv_data_table <- function(id,
       )
     })
 
-    decorated_data_table_data <-
-      srv_transform_teal_data("decorate", data = data_table_data, transformators = decorators)
+    decorated_data_table_data <- srv_decorate_teal_data(
+      id = "decorator",
+      data = data_table_data,
+      decorators = subset_decorators("table", decorators)
+    )
 
     output$data_table <- DT::renderDataTable(server = server_rendering, {
-      req(data_table_data())
       teal::validate_inputs(iv)
-      decorated_data_table_data()[["table"]]
+      req(decorated_data_table_data())[["table"]]
     })
   })
 }

R/tm_g_association.R

@@ -20,16 +20,15 @@
 #' @param distribution_theme,association_theme (`character`) optional, `ggplot2` themes to be used by default.
 #' Default to `"gray"`.
 #'
-#' @templateVar ggnames "Bivariate1", "Bivariate2"
-#' @template ggplot2_args_multi
+#' @param ggplot2_args `r roxygen_ggplot2_args_param("Bivariate1", "Bivariate2")`
+#' @param decorators `r roxygen_decorators_param("tm_")`
 #'
 #' @inherit shared_params return
 #'
 #' @section Decorating `tm_g_association`:
 #'
 #' This module generates the following objects, which can be modified in place using decorators:
-#' - `plot_top` (`ggplot2`)
-#' - `plot_bottom` (`ggplot2`)
+#' - `plot` (`grob` created with [ggplot2::ggplotGrob()])
 #'
 #' For additional details and examples of decorators, refer to the vignette
 #' `vignette("decorate-modules-output", package = "teal")` or the [`teal_transform_module()`] documentation.
@@ -176,7 +175,10 @@ tm_g_association <- function(label = "Association",
   plot_choices <- c("Bivariate1", "Bivariate2")
   checkmate::assert_list(ggplot2_args, types = "ggplot2_args")
   checkmate::assert_subset(names(ggplot2_args), c("default", plot_choices))
-  checkmate::assert_list(decorators, "teal_transform_module", null.ok = TRUE)
+
+  decorators <- normalize_decorators(decorators, "plot")
+  assert_decorators(decorators, null.ok = TRUE, "plot")
+
   # End of assertions
 
   # Make UI args
@@ -247,7 +249,7 @@ ui_tm_g_association <- function(id, ...) {
         "Log transformed",
         value = FALSE
       ),
-      ui_transform_teal_data(ns("decorate"), transformators = args$decorators),
+      ui_decorate_teal_data(ns("decorator"), decorators = subset_decorators("plot", args$decorators)),
       teal.widgets::panel_group(
         teal.widgets::panel_item(
           title = "Plot settings",
@@ -405,8 +407,6 @@ srv_tm_g_association <- function(id,
       # association
       ref_class_cov <- ifelse(association, ref_class, "NULL")
 
-      print_call <- quote(print(p))
-
       var_calls <- lapply(vars_names, function(var_i) {
         var_class <- class(ANL[[var_i]])[1]
         if (is.numeric(ANL[[var_i]]) && log_transformation) {
@@ -488,6 +488,7 @@ srv_tm_g_association <- function(id,
             expr = {
               plot_top <- plot_calls[[1]]
               plot_bottom <- plot_calls[[1]]
+              plot <- tern::stack_grobs(grobs = lapply(list(plot_top, plot_bottom), ggplotGrob))
             },
             env = list(
               plot_calls = do.call(
@@ -500,23 +501,19 @@ srv_tm_g_association <- function(id,
         )
     })
 
-    decorated_output_q <- srv_transform_teal_data("decorate", data = output_q, transformators = decorators)
-    decorated_output_grob_q <- reactive({
-      within(
-        decorated_output_q(),
-        {
-          plot <- tern::stack_grobs(grobs = lapply(list(plot_top, plot_bottom), ggplotGrob))
-          grid::grid.newpage()
-          grid::grid.draw(plot)
-        }
-      )
-    })
-
+    decorated_output_grob_q <- srv_decorate_teal_data(
+      id = "decorator",
+      data = output_q,
+      decorators = subset_decorators("plot", decorators),
+      expr = {
+        grid::grid.newpage()
+        grid::grid.draw(plot)
+      }
+    )
 
     plot_r <- reactive({
       req(iv_r()$is_valid())
-      req(output_q())
-      decorated_output_grob_q()[["plot"]]
+      req(decorated_output_grob_q())[["plot"]]
     })
 
     pws <- teal.widgets::plot_with_settings_srv(