Adds decorate functionality to module output (#1357)

closes #1383 #1384 Companion PRs: - insightsengineering/teal.modules.general#795 <details> <summary>example tmg app</summary> ```r pkgload::load_all("teal") pkgload::load_all("teal.modules.general") library(teal.widgets) data <- teal_data() data <- within(data, { require(nestcolor) ADSL <- rADSL }) join_keys(data) <- default_cdisc_join_keys[c("ADSL")] footnote_regression <- teal_transform_module( server = make_teal_transform_server(expression( plot <- plot + labs(caption = deparse(summary(fit)[[1]])) )) ) fact_vars_adsl <- names(Filter(isTRUE, sapply(data[["ADSL"]], is.factor))) vars <- choices_selected(variable_choices(data[["ADSL"]], fact_vars_adsl)) app <- init( data = data, modules = modules( tm_a_regression( label = "Regression", response = data_extract_spec( dataname = "ADSL", select = select_spec( label = "Select variable:", choices = "BMRKR1", selected = "BMRKR1", multiple = FALSE, fixed = TRUE ) ), regressor = data_extract_spec( dataname = "ADSL", select = select_spec( label = "Select variables:", choices = variable_choices(data[["ADSL"]], c("AGE", "SEX", "RACE")), selected = "AGE", multiple = TRUE, fixed = FALSE ) ), ggplot2_args = ggplot2_args( labs = list(subtitle = "Plot generated by Regression Module") ), decorators = list(footnote_regression) ) ) ) shinyApp(app$ui, app$server) ``` </details> --------- Signed-off-by: Marcin <[email protected]> Signed-off-by: André Veríssimo <[email protected]> Co-authored-by: 27856297+dependabot-preview[bot]@users.noreply.github.com <27856297+dependabot-preview[bot]@users.noreply.github.com> Co-authored-by: github-actions <41898282+github-actions[bot]@users.noreply.github.com> Co-authored-by: Marcin <[email protected]> Co-authored-by: Konrad Pagacz <[email protected]> Co-authored-by: m7pr <[email protected]> Co-authored-by: Pawel Rucki <[email protected]> Co-authored-by: André Veríssimo <[email protected]> Co-authored-by: Lluís Revilla <[email protected]>
insightsengineering · Nov 29, 2024 · d47b698 · d47b698
1 parent f40214d
commit d47b698
Show file tree

Hide file tree

Showing 38 changed files with 1,820 additions and 421 deletions.
diff --git a/.github/workflows/check.yaml b/.github/workflows/check.yaml
@@ -51,6 +51,7 @@ jobs:
         insightsengineering/teal.reporter
         insightsengineering/teal.widgets
         insightsengineering/rtables
+        insightsengineering/formatters
         insightsengineering/rtables.officer
 
   r-cmd-non-cran:
@@ -84,6 +85,7 @@ jobs:
         insightsengineering/teal.widgets
         insightsengineering/rtables
         insightsengineering/rtables.officer
+        insightsengineering/formatters
 
   coverage:
     name: Coverage 📔
@@ -103,6 +105,7 @@ jobs:
         insightsengineering/teal.widgets
         insightsengineering/rtables
         insightsengineering/rtables.officer
+        insightsengineering/formatters
   linter:
     if: github.event_name != 'push'
     name: SuperLinter 🦸‍♀️
@@ -124,6 +127,7 @@ jobs:
         insightsengineering/teal.widgets
         insightsengineering/rtables
         insightsengineering/rtables.officer
+        insightsengineering/formatters
   gitleaks:
     name: gitleaks 💧
     uses: insightsengineering/r.pkg.template/.github/workflows/gitleaks.yaml@main

diff --git a/.github/workflows/docs.yaml b/.github/workflows/docs.yaml
@@ -52,3 +52,4 @@ jobs:
         insightsengineering/teal.widgets
         insightsengineering/rtables
         insightsengineering/rtables.officer
+        insightsengineering/formatters
diff --git a/.github/workflows/release.yaml b/.github/workflows/release.yaml
@@ -26,6 +26,7 @@ jobs:
         insightsengineering/teal.widgets
         insightsengineering/rtables
         insightsengineering/rtables.officer
+        insightsengineering/formatters
   validation:
     name: R Package Validation report 📃
     needs: release
@@ -43,6 +44,7 @@ jobs:
         insightsengineering/teal.widgets
         insightsengineering/rtables
         insightsengineering/rtables.officer
+        insightsengineering/formatters
   release:
     name: Create release 🎉
     uses: insightsengineering/r.pkg.template/.github/workflows/release.yaml@main
@@ -77,6 +79,7 @@ jobs:
         insightsengineering/teal.widgets
         insightsengineering/rtables
         insightsengineering/rtables.officer
+        insightsengineering/formatters
   coverage:
     name: Coverage 📔
     needs: [release, docs]
@@ -96,6 +99,7 @@ jobs:
         insightsengineering/teal.widgets
         insightsengineering/rtables
         insightsengineering/rtables.officer
+        insightsengineering/formatters
   wasm:
     name: Build WASM packages 🧑‍🏭
     needs: release

diff --git a/.github/workflows/scheduled.yaml b/.github/workflows/scheduled.yaml
@@ -66,6 +66,7 @@ jobs:
         insightsengineering/teal.widgets
         insightsengineering/rtables
         insightsengineering/rtables.officer
+        insightsengineering/formatters
   rhub:
     if: >
       github.event_name == 'schedule' || (
@@ -84,3 +85,4 @@ jobs:
         insightsengineering/teal.widgets
         insightsengineering/rtables
         insightsengineering/rtables.officer
+        insightsengineering/formatters
diff --git a/DESCRIPTION b/DESCRIPTION
@@ -57,6 +57,7 @@ Imports:
     utils
 Suggests:
     bslib,
+    ggplot2 (>= 3.4.0),
     knitr (>= 1.42),
     mirai (>= 1.1.1),
     MultiAssayExperiment,
@@ -122,6 +123,7 @@ Collate:
     'teal_reporter.R'
     'teal_slices-store.R'
     'teal_slices.R'
+    'teal_transform_module.R'
     'utils.R'
     'validate_inputs.R'
     'validations.R'

diff --git a/NAMESPACE b/NAMESPACE
@@ -22,6 +22,7 @@ export(get_code_tdata)
 export(get_metadata)
 export(init)
 export(landing_popup_module)
+export(make_teal_transform_server)
 export(module)
 export(modules)
 export(new_tdata)
@@ -31,12 +32,14 @@ export(set_datanames)
 export(show_rcode_modal)
 export(srv_teal)
 export(srv_teal_with_splash)
+export(srv_transform_teal_data)
 export(tdata2env)
 export(teal_data_module)
 export(teal_slices)
 export(teal_transform_module)
 export(ui_teal)
 export(ui_teal_with_splash)
+export(ui_transform_teal_data)
 export(validate_has_data)
 export(validate_has_elements)
 export(validate_has_variable)

diff --git a/NEWS.md b/NEWS.md
@@ -3,7 +3,7 @@
 ### New features
 
 * Possible to call `ui_teal` and `srv_teal` directly in any application by delivering `data` argument as a `reactive` returning `teal_data` object. #669
-* Introduced `teal_transform_module` to provide a way to interactively modify data delivered to `teal_module`'s `server`. #1228
+* Introduced `teal_transform_module` to provide a way to interactively modify data delivered to `teal_module`'s `server` and to decorate module outputs. #1228 #1384
 * Introduced a new argument `once = FALSE` in `teal_data_module` to possibly reload data during a run time.
 * Possibility to download lockfile to restore app session for reproducibility. #479
 * Introduced a function `set_datanames()` to change a `datanames` of the `teal_module`.

diff --git a/R/dummy_functions.R b/R/dummy_functions.R
@@ -2,7 +2,16 @@
 #'
 #' `r lifecycle::badge("experimental")`
 #'
+#' This module creates an object called `object` that can be modified with decorators.
+#' The `object` is determined by what's selected in `Choose a dataset` input in UI.
+#' The object can be anything that can be handled by `renderPrint()`.
+#' See the `vignette("decorate-modules-output", package = "teal")` or [`teal_transform_module`]
+#' to read more about decorators.
+#'
 #' @inheritParams teal_modules
+#' @param decorators `r lifecycle::badge("experimental")` (`list` of `teal_transform_module` or `NULL`) optional,
+#' if not `NULL`, decorator for tables or plots included in the module.
+#'
 #' @return A `teal` module which can be included in the `modules` argument to [init()].
 #' @examples
 #' app <- init(
@@ -13,11 +22,16 @@
 #'   shinyApp(app$ui, app$server)
 #' }
 #' @export
-example_module <- function(label = "example teal module", datanames = "all", transformers = list()) {
+example_module <- function(label = "example teal module",
+                           datanames = "all",
+                           transformators = list(),
+                           decorators = NULL) {
   checkmate::assert_string(label)
+  checkmate::assert_list(decorators, "teal_transform_module", null.ok = TRUE)
+
   ans <- module(
     label,
-    server = function(id, data) {
+    server = function(id, data, decorators) {
       checkmate::assert_class(isolate(data()), "teal_data")
       moduleServer(id, function(input, output, session) {
         datanames_rv <- reactive(names(req(data())))
@@ -36,30 +50,52 @@ example_module <- function(label = "example teal module", datanames = "all", tra
           )
         })
 
-        output$text <- renderPrint({
+        table_data <- reactive({
           req(input$dataname)
-          data()[[input$dataname]]
+          within(data(),
+            {
+              object <- dataname
+            },
+            dataname = as.name(input$dataname)
+          )
+        })
+
+        table_data_decorated_no_print <- srv_transform_teal_data(
+          "decorate",
+          data = table_data,
+          transformators = decorators
+        )
+        table_data_decorated <- reactive(within(req(table_data_decorated_no_print()), expr = object))
+
+        output$text <- renderPrint({
+          req(table_data()) # Ensure original errors from module are displayed
+          table_data_decorated()[["object"]]
         })
 
         teal.widgets::verbatim_popup_srv(
           id = "rcode",
-          verbatim_content = reactive(teal.code::get_code(data())),
+          verbatim_content = reactive(teal.code::get_code(req(table_data_decorated()))),
           title = "Example Code"
         )
+
+        table_data_decorated
       })
     },
-    ui = function(id) {
+    ui = function(id, decorators) {
       ns <- NS(id)
       teal.widgets::standard_layout(
         output = verbatimTextOutput(ns("text")),
         encoding = tags$div(
           selectInput(ns("dataname"), "Choose a dataset", choices = NULL),
+          ui_transform_teal_data(ns("decorate"), transformators = decorators),
           teal.widgets::verbatim_popup_ui(ns("rcode"), "Show R code")
         )
       )
     },
+    ui_args = list(decorators = decorators),
+    server_args = list(decorators = decorators),
     datanames = datanames,
-    transformers = transformers
+    transformators = transformators
   )
   attr(ans, "teal_bookmarkable") <- TRUE
   ans

diff --git a/R/init.R b/R/init.R
@@ -202,7 +202,7 @@ init <- function(data,
     }
 
     is_modules_ok <- check_modules_datanames(modules, names(data))
-    if (!isTRUE(is_modules_ok) && length(unlist(extract_transformers(modules))) == 0) {
+    if (!isTRUE(is_modules_ok) && length(unlist(extract_transformators(modules))) == 0) {
       warning(is_modules_ok, call. = FALSE)
     }
 

diff --git a/R/module_data_summary.R b/R/module_data_summary.R
@@ -148,10 +148,10 @@ get_filter_overview_wrapper <- function(teal_data) {
 
   current_data_objs <- sapply(
     datanames,
-    function(name) teal.code::get_var(teal_data(), name),
+    function(name) teal_data()[[name]],
     simplify = FALSE
   )
-  initial_data_objs <- teal.code::get_var(teal_data(), ".raw_data")
+  initial_data_objs <- teal_data()[[".raw_data"]]
 
   out <- lapply(
     datanames,

diff --git a/R/module_nested_tabs.R b/R/module_nested_tabs.R
@@ -92,22 +92,22 @@ ui_teal_module.teal_module <- function(id, modules, depth = 0L) {
   args <- c(list(id = ns("module")), modules$ui_args)
 
   ui_teal <- tagList(
-    div(
-      id = ns("validate_datanames"),
-      ui_validate_reactive_teal_data(ns("validate_datanames"))
-    ),
     shinyjs::hidden(
       tags$div(
-        id = ns("transformer_failure_info"),
+        id = ns("transform_failure_info"),
         class = "teal_validated",
         div(
           class = "teal-output-warning",
-          "One of transformers failed. Please fix and continue."
+          "One of transformators failed. Please check its inputs."
         )
       )
     ),
     tags$div(
       id = ns("teal_module_ui"),
+      tags$div(
+        class = "teal_validated",
+        ui_check_module_datanames(ns("validate_datanames"))
+      ),
       do.call(modules$ui, args)
     )
   )
@@ -125,18 +125,12 @@ ui_teal_module.teal_module <- function(id, modules, depth = 0L) {
             width = 3,
             ui_data_summary(ns("data_summary")),
             ui_filter_data(ns("filter_panel")),
-            ui_transform_data(ns("data_transform"), transformers = modules$transformers, class = "well"),
+            ui_transform_teal_data(ns("data_transform"), transformators = modules$transformators, class = "well"),
             class = "teal_secondary_col"
           )
         )
       } else {
-        div(
-          div(
-            class = "teal_validated",
-            uiOutput(ns("data_input_error"))
-          ),
-          ui_teal
-        )
+        ui_teal
       }
     )
   )
@@ -266,27 +260,25 @@ srv_teal_module.teal_module <- function(id,
         data_rv = data_rv,
         is_active = is_active
       )
-      is_transformer_failed <- reactiveValues()
-      transformed_teal_data <- srv_transform_data(
+      is_transform_failed <- reactiveValues()
+      transformed_teal_data <- srv_transform_teal_data(
         "data_transform",
         data = filtered_teal_data,
-        transformers = modules$transformers,
+        transformators = modules$transformators,
         modules = modules,
-        is_transformer_failed = is_transformer_failed
+        is_transform_failed = is_transform_failed
       )
-      any_transformer_failed <- reactive({
-        any(unlist(reactiveValuesToList(is_transformer_failed)))
+      any_transform_failed <- reactive({
+        any(unlist(reactiveValuesToList(is_transform_failed)))
       })
 
-      observeEvent(any_transformer_failed(), {
-        if (isTRUE(any_transformer_failed())) {
+      observeEvent(any_transform_failed(), {
+        if (isTRUE(any_transform_failed())) {
           shinyjs::hide("teal_module_ui")
-          shinyjs::hide("validate_datanames")
-          shinyjs::show("transformer_failure_info")
+          shinyjs::show("transform_failure_info")
         } else {
           shinyjs::show("teal_module_ui")
-          shinyjs::show("validate_datanames")
-          shinyjs::hide("transformer_failure_info")
+          shinyjs::hide("transform_failure_info")
         }
       })
 
@@ -297,7 +289,7 @@ srv_teal_module.teal_module <- function(id,
         all_teal_data[c(module_datanames, ".raw_data")]
       })
 
-      srv_validate_reactive_teal_data(
+      srv_check_module_datanames(
         "validate_datanames",
         data = module_teal_data,
         modules = modules

diff --git a/R/module_teal.R b/R/module_teal.R
@@ -187,12 +187,20 @@ srv_teal <- function(id, data, modules, filter = teal_slices()) {
     )
 
     data_pulled <- srv_init_data("data", data = data)
-    data_validated <- srv_validate_reactive_teal_data(
-      "validate",
-      data = data_pulled,
-      modules = modules,
-      validate_shiny_silent_error = FALSE
+
+    validate_ui <- tags$div(
+      id = session$ns("validate_messages"),
+      class = "teal_validated",
+      ui_check_class_teal_data(session$ns("class_teal_data")),
+      ui_validate_error(session$ns("silent_error")),
+      ui_check_module_datanames(session$ns("datanames_warning"))
     )
+    srv_check_class_teal_data("class_teal_data", data_pulled)
+    srv_validate_error("silent_error", data_pulled, validate_shiny_silent_error = FALSE)
+    srv_check_module_datanames("datanames_warning", data_pulled, modules)
+
+    data_validated <- .trigger_on_success(data_pulled)
+
     data_rv <- reactive({
       req(inherits(data_validated(), "teal_data"))
       is_filter_ok <- check_filter_datanames(filter, names(data_validated()))
@@ -225,6 +233,8 @@ srv_teal <- function(id, data, modules, filter = teal_slices()) {
       })
     }
 
+
+
     if (inherits(data, "teal_data_module")) {
       setBookmarkExclude(c("teal_modules-active_tab"))
       shiny::insertTab(
@@ -236,7 +246,7 @@ srv_teal <- function(id, data, modules, filter = teal_slices()) {
           value = "teal_data_module",
           tags$div(
             ui_init_data(session$ns("data")),
-            ui_validate_reactive_teal_data(session$ns("validate"))
+            validate_ui
           )
         )
       )
@@ -253,7 +263,7 @@ srv_teal <- function(id, data, modules, filter = teal_slices()) {
       insertUI(
         selector = sprintf("#%s", session$ns("tabpanel_wrapper")),
         where = "beforeBegin",
-        ui = tags$div(ui_validate_reactive_teal_data(session$ns("validate")), tags$br())
+        ui = tags$div(validate_ui, tags$br())
       )
     }