R/teal_transform_module.R

In teal: Exploratory Web Apps for Analyzing Clinical Trials Data

#' Data module for `teal` transformations and output customization
#'
#' @description
#' `r lifecycle::badge("experimental")`
#'
#' `teal_transform_module` provides a `shiny` module that enables data transformations within a `teal` application
#' and allows for customization of outputs generated by modules.
#'
#' # Transforming Module Inputs in `teal`
#'
#' Data transformations occur after data has been filtered in `teal`.
#' The transformed data is then passed to the `server` of [`teal_module()`] and managed by `teal`'s internal processes.
#' The primary advantage of `teal_transform_module` over custom modules is in its error handling, where all warnings and
#' errors are managed by `teal`, allowing developers to focus on transformation logic.
#'
#' For more details, see the vignette: `vignette("transform-input-data", package = "teal")`.
#'
#' # Customizing Module Outputs
#'
#' `teal_transform_module` also allows developers to modify any object created within [`teal.data::teal_data`].
#' This means you can use it to customize not only datasets but also tables, listings, and graphs.
#' Some [`teal_modules`] permit developers to inject custom `shiny` modules to enhance displayed outputs.
#' To manage these `decorators` within your module, use [`ui_transform_teal_data()`] and [`srv_transform_teal_data()`].
#' (For further guidance on managing decorators, refer to `ui_args` and `srv_args` in the vignette documentation.)
#'
#' See the vignette `vignette("transform-module-output", package = "teal")` for additional examples.
#'
#' # `server` as a language
#'
#' The `server` function in `teal_transform_module` must return a reactive [`teal.data::teal_data`] object.
#' For simple transformations without complex reactivity, the `server` function might look like this:s
#'
#' ```
#' function(id, data) {
#'   moduleServer(id, function(input, output, session) {
#'     reactive({
#'       within(
#'         data(),
#'         expr = x <- subset(x, col == level),
#'         level = input$level
#'       )
#'     })
#'   })
#' }
#' ```
#'
#' The example above can be simplified using `make_teal_transform_server`, where `level` is automatically matched to the
#' corresponding `input` parameter:
#'
#' ```
#' make_teal_transform_server(expr = expression(x <- subset(x, col == level)))
#' ```
#' @inheritParams teal_data_module
#' @param server (`function(id, data)` or `expression`)
#' A `shiny` module server function that takes `id` and `data` as arguments, where `id` is the module id and `data`
#' is the reactive `teal_data` input. The `server` function must return a reactive expression containing a `teal_data`
#' object. For simplified syntax, use [`make_teal_transform_server()`].
#' @param datanames (`character`)
#' Specifies the names of datasets relevant to the module. Only filters for the specified `datanames` will be displayed
#' in the filter panel. The keyword `"all"` can be used to display filters for all datasets. `datanames` are
#' automatically appended to the [`modules()`] `datanames`.
#'
#' @examplesShinylive
#' library(teal)
#' interactive <- function() TRUE
#' {{ next_example }}
#' @examples
#' data_transformators <- list(
#'   teal_transform_module(
#'     label = "Static transformator for iris",
#'     datanames = "iris",
#'     server = function(id, data) {
#'       moduleServer(id, function(input, output, session) {
#'         reactive({
#'           within(data(), {
#'             iris <- head(iris, 5)
#'           })
#'         })
#'       })
#'     }
#'   ),
#'   teal_transform_module(
#'     label = "Interactive transformator for iris",
#'     datanames = "iris",
#'     ui = function(id) {
#'       ns <- NS(id)
#'       tags$div(
#'         numericInput(ns("n_cols"), "Show n columns", value = 5, min = 1, max = 5, step = 1)
#'       )
#'     },
#'     server = function(id, data) {
#'       moduleServer(id, function(input, output, session) {
#'         reactive({
#'           within(data(),
#'             {
#'               iris <- iris[, 1:n_cols]
#'             },
#'             n_cols = input$n_cols
#'           )
#'         })
#'       })
#'     }
#'   )
#' )
#'
#' output_decorator <- teal_transform_module(
#'   server = make_teal_transform_server(
#'     expression(
#'       object <- rev(object)
#'     )
#'   )
#' )
#'
#' app <- init(
#'   data = teal_data(iris = iris),
#'   modules = example_module(
#'     transformators = data_transformators,
#'     decorators = list(output_decorator)
#'   )
#' )
#' if (interactive()) {
#'   shinyApp(app$ui, app$server)
#' }
#'
#' @name teal_transform_module
#'
#' @export
teal_transform_module <- function(ui = NULL,
                                  server = function(id, data) data,
                                  label = "transform module",
                                  datanames = "all") {
  structure(
    list(
      ui = ui,
      server = function(id, data) {
        data_out <- server(id, data)

        if (inherits(data_out, "reactive.event")) {
          # This warning message partially detects when `eventReactive` is used in `data_module`.
          warning(
            "teal_transform_module() ",
            "Using eventReactive in teal_transform module server code should be avoided as it ",
            "may lead to unexpected behavior. See the vignettes for more information  ",
            "(`vignette(\"transform-input-data\", package = \"teal\")`).",
            call. = FALSE
          )
        }


        decorate_err_msg(
          assert_reactive(data_out),
          pre = sprintf("From: 'teal_transform_module()':\nA 'teal_transform_module' with \"%s\" label:", label),
          post = "Please make sure that this module returns a 'reactive` object containing 'teal_data' class of object." # nolint: line_length_linter.
        )
      }
    ),
    label = label,
    datanames = datanames,
    class = c("teal_transform_module", "teal_data_module")
  )
}

#' Make teal_transform_module's server
#'
#' A factory function to simplify creation of a [`teal_transform_module`]'s server. Specified `expr`
#' is wrapped in a shiny module function and output can be passed to the `server` argument in
#' [teal_transform_module()] call. Such a server function can be linked with ui and values from the
#' inputs can be used in the expression. Object names specified in the expression will be substituted
#' with the value of the respective input (matched by the name) - for example in
#' `expression(graph <- graph + ggtitle(title))` object `title` will be replaced with the value of
#' `input$title`.
#' @param expr (`language`)
#'  An R call which will be evaluated within [`teal.data::teal_data`] environment.
#' @return `function(id, data)` returning `shiny` module
#'
#' @examplesShinylive
#' library(teal)
#' interactive <- function() TRUE
#' {{ next_example }}
#' @examples
#'
#' trim_iris <- teal_transform_module(
#'   label = "Simplified interactive transformator for iris",
#'   datanames = "iris",
#'   ui = function(id) {
#'     ns <- NS(id)
#'     numericInput(ns("n_rows"), "Subset n rows", value = 6, min = 1, max = 150, step = 1)
#'   },
#'   server = make_teal_transform_server(expression(iris <- head(iris, n_rows)))
#' )
#'
#' app <- init(
#'   data = teal_data(iris = iris),
#'   modules = example_module(transformators = trim_iris)
#' )
#' if (interactive()) {
#'   shinyApp(app$ui, app$server)
#' }
#'
#' @export
make_teal_transform_server <- function(expr) {
  if (is.call(expr)) {
    expr <- as.expression(expr)
  }
  checkmate::assert_multi_class(expr, c("call", "expression"))

  function(id, data) {
    moduleServer(id, function(input, output, session) {
      list_env <- reactive(
        lapply(rlang::set_names(names(input)), function(x) input[[x]])
      )

      reactive({
        call_with_inputs <- lapply(expr, function(x) {
          do.call(what = substitute, args = list(expr = x, env = list_env()))
        })
        eval_code(object = data(), code = as.expression(call_with_inputs))
      })
    })
  }
}

#' Extract all `transformators` from `modules`.
#'
#' @param modules `teal_modules` or `teal_module`
#' @return A list of `teal_transform_module` nested in the same way as input `modules`.
#' @keywords internal
extract_transformators <- function(modules) {
  if (inherits(modules, "teal_module")) {
    modules$transformators
  } else if (inherits(modules, "teal_modules")) {
    lapply(modules$children, extract_transformators)
  }
}