Merge branch 'main' into generalize-the-TealAppDriver@main

Author: m7pr

DESCRIPTION

@@ -1,8 +1,8 @@
 Type: Package
 Package: teal
 Title: Exploratory Web Apps for Analyzing Clinical Trials Data
-Version: 1.0.0.9015
-Date: 2025-10-15
+Version: 1.0.0.9020
+Date: 2025-10-28
 Authors@R: c(
     person("Dawid", "Kaledkowski", , "dawid.kaledkowski@roche.com", role = c("aut", "cre"),
            comment = c(ORCID = "0000-0001-9533-457X")),

NAMESPACE

@@ -6,6 +6,9 @@ S3method(.srv_teal_module,teal_modules)
 S3method(.ui_teal_module,default)
 S3method(.ui_teal_module,teal_module)
 S3method(.ui_teal_module,teal_modules)
+S3method(after,default)
+S3method(after,teal_module)
+S3method(after,teal_modules)
 S3method(c,teal_slices)
 S3method(format,teal_module)
 S3method(format,teal_modules)

NEWS.md

@@ -1,4 +1,4 @@
-# teal 1.0.0.9015
+# teal 1.0.0.9020
 
 ### New features
 

R/after.R

@@ -1,90 +1,123 @@
 #' Executes modifications to the result of a module
 #'
-#' Primarily used to modify the output object of module to change the containing
-#' report.
-#' @param x (`teal_module`).
-#' @param ui (`function(id, elem, ...)`) function to receive output (`shiny.tag`) from `x$ui`
-#' @param server (`function(input, output, session, data, ...)`) function to receive output data from `x$server`
-#' @param ... additional argument passed to `ui` and `server` by matching their formals names.
-#' @return A `teal_report` object with the result of the server function.
+#' @description
+#' `r lifecycle::badge("experimental")`
+#'
+#' Exported to be able to use methods not to be used directly by module-developers or app-users.
+#' Primarily used to modify the output object of module.
+#' @seealso [disable_src()], [disable_report()]
+#' @param x (`teal_module` or `teal_modules`).
+#' @param server (`function(input, output, session, data, ...)`) function to receive output data from `tm$server`.
+#'  Must return data
+#' @param ... Additional arguments passed to the server wrapper function by matching their formal names.
+#' @return A `teal_module` or `teal_modules` object with a wrapped server.
 #' @export
+#' @keywords internal
+#' @examples
+#' library("teal.reporter")
+#' hide_code <- function(input, output, session, data) {
+#'   teal_card(data) <- Filter(function(x) !inherits(x, "code_chunk"), teal_card(data))
+#'   data
+#' }
+#' app <- init(
+#'   data = teal_data(IRIS = iris, MTCARS = mtcars),
+#'   modules = example_module() |>
+#'     after(server = hide_code)
+#' )
+#'
+#' if (interactive()) {
+#'   runApp(app)
+#' }
 after <- function(x,
-                  ui = function(id, elem) elem,
                   server = function(input, output, session, data) data,
                   ...) {
+  UseMethod("after")
+}
+
+
+#' @export
+after.default <- function(x,
+                          server = function(input, output, session, data) data,
+                          ...) {
+  stop("`after` is only implemented for `teal_module` and `teal_modules` objects.")
+}
+
+#' @export
+after.teal_modules <- function(x,
+                               server = function(input, output, session, data) data,
+                               ...) {
+  x$children <- lapply(x$children, after,
+    server = server, ...
+  )
+  x
+}
+
+#' @export
+after.teal_module <- function(x,
+                              server = function(input, output, session, data) data,
+                              ...) {
   checkmate::assert_multi_class(x, "teal_module")
-  if (!is.function(ui) || !all(names(formals(ui)) %in% c("id", "elem"))) {
-    stop("ui should be a function of id and elem")
-  }
-  if (!is.function(server) || !all(names(formals(server)) %in% c("input", "output", "session", "data"))) {
-    stop("server should be a function of `input` and `output`, `session`, `data`")
+
+  names_srv <- names(formals(server))
+  args_callModule <- c("input", "output", "session", "data") # nolint object_name_linter.
+  if (!is.function(server) || !(!all(identical(names_srv, c("id", "data"))) || !all(names_srv %in% args_callModule))) {
+    stop("`server` must be a function whose arguments are a subset of c('input', 'output', 'session', 'data'), or exactly 'id' AND 'data'.") # nolint line_length_lint
   }
 
   additional_args <- list(...)
-  new_x <- x # because overwriting x$ui/server will cause infinite recursion
-  new_x$ui <- .after_ui(x$ui, ui, additional_args)
-  new_x$server <- .after_server(x$server, server, additional_args)
-  new_x
+  x$ui <- after_ui(x$ui, function(id, elem) {
+    elem
+  }, additional_args)
+  x$server <- after_srv(x$server, server, additional_args)
+  x
 }
 
-.after_ui <- function(x, y, additional_args) {
-  # add `_`-prefix to make sure objects are not masked in the wrapper functions
-  `_x` <- x # nolint: object_name.
-  `_y` <- y # nolint: object_name.
-  new_x <- function(id, ...) {
+after_ui <- function(old, new, additional_args) {
+  new_ui <- function(id, ...) {
     original_args <- as.list(environment())
-    if ("..." %in% names(formals(`_x`))) {
+    if ("..." %in% names(formals(old))) {
       original_args <- c(original_args, list(...))
     }
     ns <- NS(id)
     original_args$id <- ns("wrapped")
-    original_out <- do.call(`_x`, original_args, quote = TRUE)
+    original_out <- do.call(old, original_args, quote = TRUE)
 
     wrapper_args <- c(
       additional_args,
       list(id = ns("wrapper"), elem = original_out)
     )
-    do.call(`_y`, args = wrapper_args[names(formals(`_y`))])
+    do.call(new, args = wrapper_args[names(formals(new))])
   }
-  formals(new_x) <- formals(x)
-  new_x
+  formals(new_ui) <- formals(old)
+  new_ui
 }
 
-.after_server <- function(x, y, additional_args) {
-  # add `_`-prefix to make sure objects are not masked in the wrapper functions
-  `_x` <- x # nolint: object_name.
-  `_y` <- y # nolint: object_name.
-  new_x <- function(id, ...) {
+after_srv <- function(old, new, additional_args) {
+  new_srv <- function(id, ...) {
     original_args <- as.list(environment())
     original_args$id <- "wrapped"
-    if ("..." %in% names(formals(`_x`))) {
+    if ("..." %in% names(formals(old))) {
       original_args <- c(original_args, list(...))
     }
     moduleServer(id, function(input, output, session) {
-      original_out <- if (all(c("input", "output", "session") %in% names(formals(`_x`)))) {
-        original_args$module <- `_x`
+      original_out <- if (all(c("input", "output", "session") %in% names(formals(old)))) {
+        original_args$module <- old
         do.call(shiny::callModule, args = original_args)
       } else {
-        do.call(`_x`, original_args)
+        do.call(old, original_args)
       }
-      original_out_r <- reactive(
-        if (is.reactive(original_out)) {
-          original_out()
-        } else {
-          original_out
-        }
-      )
+
       wrapper_args <- utils::modifyList(
         additional_args,
         list(id = "wrapper", input = input, output = output, session = session)
       )
       reactive({
-        req(original_out_r())
+        req(original_out())
         wrapper_args$data <- original_out()
-        do.call(`_y`, wrapper_args[names(formals(`_y`))], quote = TRUE)
+        do.call(new, wrapper_args[names(formals(new))], quote = TRUE)
       })
     })
   }
-  formals(new_x) <- formals(x)
-  new_x
+  formals(new_srv) <- formals(old)
+  new_srv
 }

R/module_nested_tabs.R

@@ -502,7 +502,7 @@ srv_teal_module <- function(id,
         ignoreNULL = TRUE,
         handlerExpr = {
           out <- .call_teal_module(modules, datasets, module_teal_data, reporter)
-          srv_add_reporter("add_reporter_wrapper", module_out = out, reporter = reporter)
+          srv_add_reporter("add_reporter_wrapper", module_out = out, reporter = reporter, module_label = modules$label)
           srv_source_code("source_code_wrapper", out)
           module_out(out)
         }

R/module_source_code.R

@@ -54,7 +54,7 @@ srv_source_code <- function(id, module_out) {
         "The source code functionality is disabled for this module."
       } else if (inherits(mod_out_r(), "error")) {
         "The module returned an error, check it for errors."
-      } else if (is.null(code_out())) {
+      } else if (!nzchar(code_out())) {
         "The module does not support source code functionality."
       }
     })
@@ -65,7 +65,7 @@ srv_source_code <- function(id, module_out) {
         if (length(reason)) {
           icon <- if (grepl("error", reason)) "exclamation-triangle-fill" else "info-circle-fill"
           shiny::div(
-            class = if (grepl("error", reason)) "text-danger" else "text-info",
+            class = if (grepl("error", reason)) "text-warning" else "text-info",
             style = "padding-top: 0.5em;",
             bsicons::bs_icon(name = icon),
             reason
@@ -92,7 +92,13 @@ srv_source_code <- function(id, module_out) {
 #' @param x (`teal_module`) a `teal_module` object.
 #' @return modified data object that indicates that it should not show the "Show R Code"
 #' button in the UI.
+#' @seealso [disable_report()]
+#' @examplesShinylive
+#' library(teal)
+#' interactive <- function() TRUE
+#' {{ next_example }}
 #' @examples
+#' # Disabling source on a single module
 #' app <- init(
 #'   data = within(teal_data(), iris <- iris),
 #'   modules = modules(
@@ -102,6 +108,23 @@ srv_source_code <- function(id, module_out) {
 #' if (interactive()) {
 #'   shinyApp(app$ui, app$server)
 #' }
+#' @examplesShinylive
+#' library(teal)
+#' interactive <- function() TRUE
+#' {{ next_example }}
+#' @examples
+#' # Multiple modules
+#' app <- init(
+#'   data = within(teal_data(), iris <- iris),
+#'   modules = modules(
+#'     example_module(label = "example 1"),
+#'     example_module(label = "example 2")
+#'   ) |> disable_src()
+#' )
+#'
+#' if (interactive()) {
+#'   shinyApp(app$ui, app$server)
+#' }
 #' @export
 disable_src <- function(x) {
   checkmate::assert_multi_class(x, c("teal_module", "teal_modules"))

R/module_teal_reporter.R

@@ -120,9 +120,10 @@ ui_add_reporter <- function(id) {
 }
 
 #' @noRd
-srv_add_reporter <- function(id, module_out, reporter) {
+srv_add_reporter <- function(id, module_out, reporter, module_label = "") {
   checkmate::assert_string(id)
   checkmate::assert_class(reporter, "Reporter", null.ok = TRUE)
+  checkmate::assert_string(module_label)
   if (is.null(reporter)) {
     return(FALSE)
   } # early exit
@@ -178,7 +179,12 @@ srv_add_reporter <- function(id, module_out, reporter) {
         shinyjs::toggleState("report_add_wrapper", condition = is.null(reason_r()))
       })
 
-      teal.reporter::add_card_button_srv("reporter_add", reporter = reporter, card_fun = doc_out)
+      teal.reporter::add_card_button_srv(
+        "reporter_add",
+        reporter = reporter,
+        card_fun = doc_out,
+        card_title = module_label
+      )
     }
   })
 }
@@ -189,8 +195,14 @@ srv_add_reporter <- function(id, module_out, reporter) {
 #' to the report previewer.
 #' @param x (`teal_module`) a `teal_module` object.
 #' @return modified data object that indicates that it should disable the reporter functionality.
+#' @seealso [disable_src()]
 #' @export
+#' @examplesShinylive
+#' library(teal)
+#' interactive <- function() TRUE
+#' {{ next_example }}
 #' @examples
+#' # Disabling report on a single module
 #' app <- init(
 #'   data = within(teal_data(), iris <- iris),
 #'   modules = modules(
@@ -200,6 +212,39 @@ srv_add_reporter <- function(id, module_out, reporter) {
 #' if (interactive()) {
 #'   shinyApp(app$ui, app$server)
 #' }
+#'
+#' @examplesShinylive
+#' library(teal)
+#' interactive <- function() TRUE
+#' {{ next_example }}
+#' @examples
+#' # Disabling report on multiple modules
+#' app <- init(
+#'   data = within(teal_data(), iris <- iris),
+#'   modules = modules(
+#'     example_module(label = "example 1"),
+#'     example_module(label = "example 2")
+#'   ) |> disable_report()
+#' )
+#' if (interactive()) {
+#'   shinyApp(app$ui, app$server)
+#' }
+#' @examplesShinylive
+#' library(teal)
+#' interactive <- function() TRUE
+#' {{ next_example }}
+#' @examples
+#' # Disabling reporting for the app
+#' app <- init(
+#'   data = within(teal_data(), iris <- iris),
+#'   modules = modules(
+#'     example_module(label = "example teal module")
+#'   ),
+#'   reporter = NULL
+#' )
+#' if (interactive()) {
+#'   shinyApp(app$ui, app$server)
+#' }
 disable_report <- function(x) {
   checkmate::assert_multi_class(x, c("teal_module", "teal_modules"))
   after(x, server = function(data) {

_pkgdown.yml

@@ -133,7 +133,6 @@ reference:
       - disable_report
   - title: Modifying output of modules
     contents:
-      - after
       - disable_src
       - disable_report
   - title: Landing popup