introduce decorators for tm_missing_data (#809)

Part of insightsengineering/teal#1370

<details><summary>Updated working example</summary>

```r
# tm_missing_data

pkgload::load_all("../teal")
pkgload::load_all(".")

plot_grob_decorator <- function(default_footnote = "I am a good decorator", variable_to_replace = "summary_plot") {
  teal_transform_module(
    label = "Plot",
    ui = function(id) shiny::textInput(shiny::NS(id, "footnote"), "Footnote", value = default_footnote),
    server = function(id, data) {
      moduleServer(id, function(input, output, session) {
        logger::log_info("🟠 plot_grob with default: {default_footnote}!", namespace = "teal.modules.general")
        reactive({
          req(data(), input$footnote)
          logger::log_info("changing the footnote {default_footnote}", namespace = "teal.modules.general")
          teal.code::eval_code(data(), substitute(
            {
            footnote_grob <- grid::textGrob(footnote, x = 0, hjust = 0, gp = grid::gpar(fontsize = 10, fontface = "italic", col = "gray50"))
            
            # Arrange the plot and footnote
            variable_to_replace <- gridExtra::arrangeGrob(
              variable_to_replace,
              footnote_grob,
              ncol = 1,
              heights = grid::unit.c(grid::unit(1, "npc") - grid::unit(1, "lines"), grid::unit(1, "lines"))
            )
          }, 
          env = list(
            footnote = input$footnote,
            variable_to_replace = as.name(variable_to_replace)
          )))
        })
      })
    }
  )
}

caption_decorator <- teal_transform_module(
  ui = function(id) shiny::textInput(shiny::NS(id, "footnote"), "Footnote", value = "D"),
  server = make_teal_transform_server(
    expression(by_subject_plot <- by_subject_plot + ggplot2::labs(caption = footnote))
  )
)

table_decorator_interactive <- teal_transform_module(
  label = "Table",
  ui = function(id) {
    selectInput(
      NS(id, "style"), 
      "Table Style", 
      choices = c("Default", "Striped", "Hover"), 
      selected = "Default"
    )
  },
  server = function(id, data) {
    moduleServer(id, function(input, output, session) {
      logger::log_info("🔵 Footnote called to action!", namespace = "teal.modules.general")
      reactive({
        req(data(), input$style)
        within(data(), {
          style_str <- style
          table <- switch(
            style,
            "Striped" = DT::formatStyle(
              table,
              columns = attr(table$x, "colnames")[-1],
              target = 'row',
              backgroundColor = '#f9f9f9'
            ),
            "Hover" = DT::formatStyle(
              table,
              columns = attr(table$x, "colnames")[-1],
              target = 'row',
              backgroundColor = '#f0f0f0'
            ),
            table
          )
        }, style = input$style)
      })
    })
  }
)

generic_decorator <- teal_transform_module(
  ui = function(id) shiny::textInput(shiny::NS(id, "footnote"), "Footnote", value = "D"),
  server = make_teal_transform_server(
    expression({
      if (exists("by_subject_plot")) by_subject_plot <- by_subject_plot + ggplot2::labs(caption = footnote)
      if (exists("table", inherits = FALSE)) table <- DT::formatStyle(table, columns = attr(table$x, "colnames")[-1], target = 'row', backgroundColor = '#f9f9f9')
      if (exists("summary_plot")) {
        footnote_grob <- grid::textGrob(footnote, x = 0, hjust = 0, gp = grid::gpar(fontsize = 10, fontface = "italic", col = "gray50"))
        
        # Arrange the plot and footnote
        summary_plot <- gridExtra::arrangeGrob(summary_plot, footnote_grob, ncol = 1, heights = grid::unit.c(grid::unit(1, "npc") - grid::unit(1, "lines"), grid::unit(1, "lines")))
      }
      if (exists("combination_plot")) {
        footnote_grob <- grid::textGrob(footnote, x = 0, hjust = 0, gp = grid::gpar(fontsize = 10, fontface = "italic", col = "gray50"))
        
        # Arrange the plot and footnote
        combination_plot <- gridExtra::arrangeGrob(combination_plot, footnote_grob, ncol = 1, heights = grid::unit.c(grid::unit(1, "npc") - grid::unit(1, "lines"), grid::unit(1, "lines")))
      }
    })
  )
)

# CDISC example data
data <- teal_data()
data <- within(data, {
  require(nestcolor)
  ADSL <- rADSL
  ADRS <- rADRS
})
join_keys(data) <- default_cdisc_join_keys[names(data)]

app <- init(
  data = data,
  modules = modules(
    tm_missing_data(
      label = "Flat list",
      decorators = list(
        summary_plot = plot_grob_decorator("A"),
        combination_plot = plot_grob_decorator("B", "combination_plot"),
        summary_table = table_decorator_interactive,
        by_subject_plot = caption_decorator
      )
    ),
    tm_missing_data(
      label = "Complex list",
      decorators = list(
        summary_plot = list(plot_grob_decorator("A")),
        combination_plot = list(plot_grob_decorator("B", "combination_plot")),
        summary_table = list(table_decorator_interactive),
        by_subject_plot = list(caption_decorator)
      )
    ),
    tm_missing_data(
      label = "Complex list",
      decorators = list(generic_decorator)
    ),
    example_module()
  )
)
if (interactive()) {
  shinyApp(app$ui, app$server)
}
```

</details>

<details><summary> Old ~Working~ Example </summary>

```r
pkgload::load_all("../teal")
pkgload::load_all(".")


footnote_dec <- teal_transform_module(
  label = "Footnote",
  ui = function(id) shiny::textInput(shiny::NS(id, "footnote"), "Footnote for Combination Plot", value = "I am a good decorator"),
  server = function(id, data) {
    moduleServer(id, function(input, output, session) {
      logger::log_info("🟢 Footnote called to action!", namespace = "teal.modules.general")
      reactive(
        within(
          data(),
          {
            footnote_str <- footnote
            if (exists('combination_plot_top')) {
              combination_plot_top <- combination_plot_top + ggplot2::labs(caption = footnote_str)
            }
          },
          footnote = input$footnote
        )
      )
    })
  }
)

# general example data
data <- teal_data()
data <- within(data, {
  require(nestcolor)
  
  add_nas <- function(x) {
    x[sample(seq_along(x), floor(length(x) * runif(1, .05, .17)))] <- NA
    x
  }
  
  iris <- iris
  mtcars <- mtcars
  
  iris[] <- lapply(iris, add_nas)
  mtcars[] <- lapply(mtcars, add_nas)
  mtcars[["cyl"]] <- as.factor(mtcars[["cyl"]])
  mtcars[["gear"]] <- as.factor(mtcars[["gear"]])
})

app <- init(
  data = data,
  modules = modules(
    tm_missing_data(decorators = list(footnote_dec))
  )
)
if (interactive()) {
  shinyApp(app$ui, app$server)
}
```

</details>

---------

Co-authored-by: André Veríssimo <[email protected]>

R/utils.R

@@ -280,3 +280,112 @@ assert_single_selection <- function(x,
   }
   invisible(TRUE)
 }
+
+#' Wrappers around `srv_transform_teal_data` that allows to decorate the data
+#' @inheritParams teal::srv_transform_teal_data
+#' @param expr (`expression` or `reactive`) to evaluate on the output of the decoration.
+#' When an expression it must be inline code. See [within()]
+#' Default is `NULL` which won't evaluate any appending code.
+#' @details
+#' `srv_decorate_teal_data` is a wrapper around `srv_transform_teal_data` that
+#' allows to decorate the data with additional expressions.
+#' When original `teal_data` object is in error state, it will show that error
+#' first.
+#'
+#' @keywords internal
+srv_decorate_teal_data <- function(id, data, decorators, expr) {
+  assert_reactive(data)
+  checkmate::assert_list(decorators, "teal_transform_module")
+
+  missing_expr <- missing(expr)
+  if (!missing_expr) {
+    expr <- rlang::enexpr(expr)
+  }
+
+  moduleServer(id, function(input, output, session) {
+    decorated_output <- srv_transform_teal_data("inner", data = data, transformators = decorators)
+
+    reactive({
+      # ensure original errors are displayed and `eval_code` is never executed with NULL
+      req(data(), decorated_output())
+      if (missing_expr) {
+        decorated_output()
+      } else {
+        eval_code(decorated_output(), expr)
+      }
+    })
+  })
+}
+
+#' @rdname srv_decorate_teal_data
+#' @details
+#' `ui_decorate_teal_data` is a wrapper around `ui_transform_teal_data`.
+#' @keywords internal
+ui_decorate_teal_data <- function(id, decorators, ...) {
+  teal::ui_transform_teal_data(NS(id, "inner"), transformators = decorators, ...)
+}
+
+#' Internal function to check if decorators is a valid object
+#' @noRd
+check_decorators <- function(x, names = NULL, null.ok = FALSE) {
+  checkmate::qassert(null.ok, "B1")
+
+  check_message <- checkmate::check_list(
+    x,
+    null.ok = null.ok,
+    names = "named"
+  )
+
+  if (!is.null(names)) {
+    check_message <- if (isTRUE(check_message)) {
+      out_message <- checkmate::check_names(names(x), subset.of = c("default", names))
+      # see https://github.com/insightsengineering/teal.logger/issues/101
+      if (isTRUE(out_message)) {
+        out_message
+      } else {
+        gsub("\\{", "(", gsub("\\}", ")", out_message))
+      }
+    } else {
+      check_message
+    }
+  }
+
+  if (!isTRUE(check_message)) {
+    return(check_message)
+  }
+
+  valid_elements <- vapply(
+    x,
+    checkmate::test_list,
+    types = "teal_transform_module",
+    null.ok = TRUE,
+    FUN.VALUE = logical(1L)
+  )
+
+  if (all(valid_elements)) {
+    return(TRUE)
+  }
+
+  "May only contain the type 'teal_transform_module' or a named list of 'teal_transform_module'."
+}
+
+#' Internal assertion on decorators
+#' @noRd
+assert_decorators <- checkmate::makeAssertionFunction(check_decorators)
+
+#' Subset decorators based on the scope
+#'
+#' `default` is a protected decorator name that is always included in the output,
+#' if it exists
+#'
+#' @param scope (`character`) a character vector of decorator names to include.
+#' @param decorators (named `list`) of list decorators to subset.
+#'
+#' @return A flat list with all decorators to include.
+#' It can be an empty list if none of the scope exists in `decorators` argument.
+#' @keywords internal
+subset_decorators <- function(scope, decorators) {
+  checkmate::assert_character(scope)
+  scope <- intersect(union("default", scope), names(decorators))
+  c(list(), unlist(decorators[scope], recursive = FALSE))
+}