Merge branch '1187_decorate_output@main' into tm_scatterplot@1187_dec…

…orate_output@main

R/tm_a_pca.R

@@ -18,11 +18,21 @@
 #'
 #' @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`)
+#'
+#' 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 +68,7 @@
 #' interactive <- function() TRUE
 #' {{ next_example }}
 #' @examples
+#'
 #' # CDISC data example
 #' data <- teal_data()
 #' data <- within(data, {
@@ -102,7 +113,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 +164,8 @@ 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)
   # End of assertions
 
   # Make UI args
@@ -169,7 +183,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,7 +239,8 @@ ui_a_pca <- function(id, ...) {
               label = "Plot type",
               choices = args$plot_choices,
               selected = args$plot_choices[1]
-            )
+            ),
+            ui_transform_teal_data(ns("decorate"), transformators = args$decorators)
           ),
           teal.widgets::panel_item(
             title = "Pre-processing",
@@ -289,7 +305,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 +565,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")) +
+            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 +585,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 +642,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) +
+            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 +654,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 +874,7 @@ srv_a_pca <- function(id, data, reporter, filter_panel_api, dat, plot_height, pl
         qenv,
         substitute(
           expr = {
-            g <- plot_call
-            print(g)
+            plot <- plot_call
           },
           env = list(
             plot_call = Reduce(function(x, y) call("+", x, y), pca_plot_biplot_expr)
@@ -938,10 +950,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)
+            plot <- plot_call
           },
           env = list(
             pc = pc,
@@ -966,8 +975,12 @@ srv_a_pca <- function(id, data, reporter, filter_panel_api, dat, plot_height, pl
       )
     })
 
+    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({
-      output_q()[["g"]]
+      req(output_q())
+      decorated_output_q()[["plot"]]
     })
 
     pws <- teal.widgets::plot_with_settings_srv(
@@ -1034,7 +1047,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 +1070,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)

R/tm_a_regression.R

@@ -292,37 +292,37 @@ ui_a_regression <- function(id, ...) {
         conditionalPanel(
           condition = "input.plot_type == 'Response vs Regressor'",
           ns = ns,
-          ui_teal_transform_data(ns("d_0"), transformators = args$decorators[[1]])
+          ui_transform_teal_data(ns("d_0"), transformators = args$decorators)
         ),
         conditionalPanel(
           condition = "input.plot_type == 'Residuals vs Fitted'",
           ns = ns,
-          ui_teal_transform_data(ns("d_1"), transformators = args$decorators[[1]])
+          ui_transform_teal_data(ns("d_1"), transformators = args$decorators)
         ),
         conditionalPanel(
           condition = "input.plot_type == 'Normal Q-Q'",
           ns = ns,
-          ui_teal_transform_data(ns("d_2"), transformators = args$decorators[[1]])
+          ui_transform_teal_data(ns("d_2"), transformators = args$decorators)
         ),
         conditionalPanel(
           condition = "input.plot_type == 'Scale-Location'",
           ns = ns,
-          ui_teal_transform_data(ns("d_3"), transformators = args$decorators[[1]])
+          ui_transform_teal_data(ns("d_3"), transformators = args$decorators)
         ),
         conditionalPanel(
           condition = "input.plot_type == 'Cook\\'s distance'",
           ns = ns,
-          ui_teal_transform_data(ns("d_4"), transformators = args$decorators[[1]])
+          ui_transform_teal_data(ns("d_4"), transformators = args$decorators)
         ),
         conditionalPanel(
           condition = "input.plot_type == 'Residuals vs Leverage'",
           ns = ns,
-          ui_teal_transform_data(ns("d_5"), transformators = args$decorators[[1]])
+          ui_transform_teal_data(ns("d_5"), transformators = args$decorators)
         ),
         conditionalPanel(
           condition = "input.plot_type == 'Cook\\'s dist vs Leverage'",
           ns = ns,
-          ui_teal_transform_data(ns("d_6"), transformators = args$decorators[[1]])
+          ui_transform_teal_data(ns("d_6"), transformators = args$decorators)
         ),
       ),
       checkboxInput(ns("show_outlier"), label = "Display outlier labels", value = TRUE),
@@ -1000,13 +1000,13 @@ srv_a_regression <- function(id,
       )
     })
 
-    decorated_output_0 <- srv_teal_transform_data(id = "d_0", data = output_plot_0, transformators = decorators[[1]])
-    decorated_output_1 <- srv_teal_transform_data(id = "d_1", data = output_plot_1, transformators = decorators[[1]])
-    decorated_output_2 <- srv_teal_transform_data(id = "d_2", data = output_plot_2, transformators = decorators[[1]])
-    decorated_output_3 <- srv_teal_transform_data(id = "d_3", data = output_plot_3, transformators = decorators[[1]])
-    decorated_output_4 <- srv_teal_transform_data(id = "d_4", data = output_plot_4, transformators = decorators[[1]])
-    decorated_output_5 <- srv_teal_transform_data(id = "d_5", data = output_plot_5, transformators = decorators[[1]])
-    decorated_output_6 <- srv_teal_transform_data(id = "d_6", data = output_plot_6, transformators = decorators[[1]])
+    decorated_output_0 <- srv_transform_teal_data(id = "d_0", data = output_plot_0, transformators = decorators)
+    decorated_output_1 <- srv_transform_teal_data(id = "d_1", data = output_plot_1, transformators = decorators)
+    decorated_output_2 <- srv_transform_teal_data(id = "d_2", data = output_plot_2, transformators = decorators)
+    decorated_output_3 <- srv_transform_teal_data(id = "d_3", data = output_plot_3, transformators = decorators)
+    decorated_output_4 <- srv_transform_teal_data(id = "d_4", data = output_plot_4, transformators = decorators)
+    decorated_output_5 <- srv_transform_teal_data(id = "d_5", data = output_plot_5, transformators = decorators)
+    decorated_output_6 <- srv_transform_teal_data(id = "d_6", data = output_plot_6, transformators = decorators)
 
 
     output_q <- reactive({

R/tm_g_bivariate.R

@@ -350,7 +350,7 @@ ui_g_bivariate <- function(id, ...) {
           justified = TRUE
         )
       ),
-      ui_teal_transform_data(ns("decorate"), transformators = args$decorators),
+      ui_transform_teal_data(ns("decorate"), transformators = args$decorators),
       if (!is.null(args$row_facet) || !is.null(args$col_facet)) {
         tags$div(
           class = "data-extract-box",
@@ -665,7 +665,7 @@ srv_g_bivariate <- function(id,
       teal.code::eval_code(merged$anl_q_r(), substitute(expr = plot <- cl, env = list(cl = cl)))
     })
 
-    decorated_output_q <- srv_teal_transform_data("decorate", data = output_q, transformators = decorators)
+    decorated_output_q <- srv_transform_teal_data("decorate", data = output_q, transformators = decorators)
 
     decorated_output_q_facets <- reactive({
       ANL <- merged$anl_q_r()[["ANL"]]

R/tm_g_distribution.R

@@ -280,7 +280,7 @@ ui_distribution <- function(id, ...) {
               inline = TRUE
             ),
             checkboxInput(ns("add_dens"), label = "Overlay Density", value = TRUE),
-            ui_teal_transform_data(ns("d_dist"), transformators = args$decorators),
+            ui_transform_teal_data(ns("d_dist"), transformators = args$decorators),
             collapsed = FALSE
           )
         ),
@@ -289,7 +289,7 @@ ui_distribution <- function(id, ...) {
           teal.widgets::panel_item(
             "QQ Plot",
             checkboxInput(ns("qq_line"), label = "Add diagonal line(s)", TRUE),
-            ui_teal_transform_data(ns("d_qq"), transformators = args$decorators),
+            ui_transform_teal_data(ns("d_qq"), transformators = args$decorators),
             collapsed = FALSE
           )
         ),
@@ -1242,13 +1242,13 @@ srv_distribution <- function(id,
     output_dist_q <- reactive(c(output_common_q(), req(dist_q())))
     output_qq_q <- reactive(c(output_common_q(), req(qq_q())))
 
-    decorated_output_dist_q <- srv_teal_transform_data(
+    decorated_output_dist_q <- srv_transform_teal_data(
       "d_dist",
       data = output_dist_q,
       transformators = decorators
     )
 
-    decorated_output_qq_q <- srv_teal_transform_data(
+    decorated_output_qq_q <- srv_transform_teal_data(
       "d_qq",
       data = output_qq_q,
       transformators = decorators

R/tm_g_response.R

@@ -285,7 +285,7 @@ ui_g_response <- function(id, ...) {
         selected = ifelse(args$freq, "frequency", "density"),
         justified = TRUE
       ),
-      ui_teal_transform_data(ns("decorator"), transformators = args$decorators),
+      ui_transform_teal_data(ns("decorator"), transformators = args$decorators),
       teal.widgets::panel_group(
         teal.widgets::panel_item(
           title = "Plot settings",
@@ -552,7 +552,7 @@ srv_g_response <- function(id,
       teal.code::eval_code(qenv, plot_call)
     })
 
-    decorated_output_q <- srv_teal_transform_data(id = "decorator", data = output_q, transformators = decorators)
+    decorated_output_q <- srv_transform_teal_data(id = "decorator", data = output_q, transformators = decorators)
 
     decorated_output_plot_q <- reactive(within(decorated_output_q(), print(plot)))
     plot_r <- reactive({