Adds decorate functionality to module output

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)
@@ -30,12 +31,14 @@ export(reporter_previewer_module)
 export(set_datanames)
 export(show_rcode_modal)
 export(srv_teal)
+export(srv_teal_transform_module)
 export(srv_teal_with_splash)
 export(tdata2env)
 export(teal_data_module)
 export(teal_slices)
 export(teal_transform_module)
 export(ui_teal)
+export(ui_teal_transform_module)
 export(ui_teal_with_splash)
 export(validate_has_data)
 export(validate_has_elements)

R/module_nested_tabs.R

@@ -92,10 +92,6 @@ 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"),
@@ -108,6 +104,10 @@ ui_teal_module.teal_module <- function(id, modules, depth = 0L) {
     ),
     tags$div(
       id = ns("teal_module_ui"),
+      tags$div(
+        class = "teal_validated",
+        ui_check_module_datanames(ns("validate_datanames"))
+      ),
       do.call(modules$ui, args)
     )
   )
@@ -126,19 +126,13 @@ ui_teal_module.teal_module <- function(id, modules, depth = 0L) {
             ui_data_summary(ns("data_summary")),
             ui_filter_data(ns("filter_panel")),
             if (length(modules$transformers) > 0 && !isTRUE(attr(modules$transformers, "custom_ui"))) {
-              ui_transform_data(ns("data_transform"), transforms = modules$transformers, class = "well")
+              ui_teal_transform_module(ns("data_transform"), transforms = modules$transformers, class = "well")
             },
             class = "teal_secondary_col"
           )
         )
       } else {
-        div(
-          div(
-            class = "teal_validated",
-            uiOutput(ns("data_input_error"))
-          ),
-          ui_teal
-        )
+        ui_teal
       }
     )
   )
@@ -262,7 +256,7 @@ srv_teal_module.teal_module <- function(id,
     )
 
     is_transformer_failed <- reactiveValues()
-    transformed_teal_data <- srv_transform_data(
+    transformed_teal_data <- srv_teal_transform_module(
       "data_transform",
       data = filtered_teal_data,
       transforms = modules$transformers,
@@ -275,11 +269,9 @@ srv_teal_module.teal_module <- function(id,
     observeEvent(any_transformer_failed(), {
       if (isTRUE(any_transformer_failed())) {
         shinyjs::hide("teal_module_ui")
-        shinyjs::hide("validate_datanames")
         shinyjs::show("transformer_failure_info")
       } else {
         shinyjs::show("teal_module_ui")
-        shinyjs::show("validate_datanames")
         shinyjs::hide("transformer_failure_info")
       }
     })
@@ -291,7 +283,7 @@ srv_teal_module.teal_module <- function(id,
       .subset_teal_data(all_teal_data, module_datanames)
     })
 
-    srv_validate_reactive_teal_data(
+    srv_check_module_datanames(
       "validate_datanames",
       data = module_teal_data,
       modules = modules

R/module_teal.R

@@ -20,7 +20,7 @@
 #' performed:
 #' - data loading in [`module_init_data`]
 #' - data filtering in [`module_filter_data`]
-#' - data transformation in [`module_transform_data`]
+#' - data transformation in [`module_teal_transform_module`]
 #'
 #' ## Fallback on failure
 #'
@@ -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, ls(teal.code::get_env(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())
       )
     }
 

R/module_teal_data.R

@@ -106,7 +106,7 @@ ui_validate_reactive_teal_data <- function(id) {
       class = "teal_validated",
       ui_validate_error(ns("silent_error")),
       ui_check_class_teal_data(ns("class_teal_data")),
-      ui_check_shiny_warnings(ns("shiny_warnings"))
+      ui_check_module_datanames(ns("shiny_warnings"))
     ),
     div(
       class = "teal_validated",
@@ -129,7 +129,7 @@ srv_validate_reactive_teal_data <- function(id, # nolint: object_length
     # there is an empty reactive cycle on `init` and `data_rv` has `shiny.silent.error` class
     srv_validate_error("silent_error", data, validate_shiny_silent_error)
     srv_check_class_teal_data("class_teal_data", data)
-    srv_check_shiny_warnings("shiny_warnings", data, modules)
+    srv_check_module_datanames("shiny_warnings", data, modules)
     output$previous_failed <- renderUI({
       if (hide_validation_error()) {
         shinyjs::hide("validate_messages")
@@ -211,13 +211,13 @@ srv_check_class_teal_data <- function(id, data) {
 }
 
 #' @keywords internal
-ui_check_shiny_warnings <- function(id) {
+ui_check_module_datanames <- function(id) {
   ns <- NS(id)
   uiOutput(NS(id, "message"))
 }
 
 #' @keywords internal
-srv_check_shiny_warnings <- function(id, data, modules) {
+srv_check_module_datanames <- function(id, data, modules) {
   checkmate::assert_string(id)
   moduleServer(id, function(input, output, session) {
     output$message <- renderUI({

R/module_transform_data.R

@@ -1,31 +1,40 @@
 #' Module to transform `reactive` `teal_data`
 #'
-#' Module calls multiple [`module_teal_data`] in sequence so that `reactive teal_data` output
+#' Module calls [teal_transform_module()] in sequence so that `reactive teal_data` output
 #' from one module is handed over to the following module's input.
 #'
 #' @inheritParams module_teal_data
 #' @inheritParams teal_modules
 #' @return `reactive` `teal_data`
 #'
 #'
-#' @name module_transform_data
-#' @keywords internal
+#' @name module_teal_transform_module
 NULL
 
-#' @rdname module_transform_data
-ui_transform_data <- function(id, transforms, class = "well") {
+#' @export
+#' @rdname module_teal_transform_module
+ui_teal_transform_module <- function(id, transforms, class = "well") {
   checkmate::assert_string(id)
-  checkmate::assert_list(transforms, "teal_transform_module", null.ok = TRUE)
-  ns <- NS(id)
+  if (length(transforms) == 0L) {
+    return(NULL)
+  }
+  if (inherits(transforms, "teal_transform_module")) {
+    transforms <- list(transforms)
+  }
+  checkmate::assert_list(transforms, "teal_transform_module")
+
   labels <- lapply(transforms, function(x) attr(x, "label"))
   ids <- get_unique_labels(labels)
   names(transforms) <- ids
 
   lapply(
     names(transforms),
     function(name) {
+      child_id <- NS(id)(name)
+      ns <- NS(child_id)
       data_mod <- transforms[[name]]
-      wrapper_id <- ns(sprintf("wrapper_%s", name))
+      transform_wrapper_id <- ns(sprintf("wrapper_%s", name))
+
       div( # todo: accordion?
         # class .teal_validated changes the color of the boarder on error in ui_validate_reactive_teal_data
         #   For details see tealValidate.js file.
@@ -40,39 +49,89 @@ ui_transform_data <- function(id, transforms, class = "well") {
           class = "remove pull-right fa fa-angle-down",
           style = "cursor: pointer;",
           title = "fold/expand transform panel",
-          onclick = sprintf("togglePanelItems(this, '%s', 'fa-angle-right', 'fa-angle-down');", wrapper_id)
+          onclick = sprintf("togglePanelItems(this, '%s', 'fa-angle-right', 'fa-angle-down');", transform_wrapper_id)
         ),
-        div(
-          id = wrapper_id,
-          ui_teal_data(id = ns(name), data_module = transforms[[name]]$ui)
+        tags$div(
+          id = transform_wrapper_id,
+          if (is.null(data_mod$ui)) {
+            return(NULL)
+          } else {
+            data_mod$ui(id = ns(name))
+          },
+          div(
+            id = ns("validate_messages"),
+            class = "teal_validated",
+            uiOutput(ns("error_wrapper"))
+          )
         )
       )
     }
   )
 }
 
-#' @rdname module_transform_data
-srv_transform_data <- function(id, data, transforms, modules, is_transformer_failed = reactiveValues()) {
+#' @export
+#' @rdname module_teal_transform_module
+srv_teal_transform_module <- function(id, data, transforms, modules = NULL, is_transformer_failed = reactiveValues()) {
   checkmate::assert_string(id)
   assert_reactive(data)
-  checkmate::assert_list(transforms, "teal_transform_module", null.ok = TRUE)
-  checkmate::assert_class(modules, "teal_module")
+  checkmate::assert_class(modules, "teal_module", null.ok = TRUE)
   if (length(transforms) == 0L) {
     return(data)
   }
+  if (inherits(transforms, "teal_transform_module")) {
+    transforms <- list(transforms)
+  }
+  checkmate::assert_list(transforms, "teal_transform_module", null.ok = TRUE)
   labels <- lapply(transforms, function(x) attr(x, "label"))
   ids <- get_unique_labels(labels)
   names(transforms) <- ids
+
   moduleServer(id, function(input, output, session) {
-    logger::log_debug("srv_teal_data_modules initializing.")
     Reduce(
-      function(previous_result, name) {
-        srv_teal_data(
-          id = name,
-          data_module = function(id) transforms[[name]]$server(id, previous_result),
-          modules = modules,
-          is_transformer_failed = is_transformer_failed
-        )
+      function(data_previous, name) {
+        moduleServer(name, function(input, output, session) {
+          logger::log_debug("srv_teal_transform_module initializing for { name }.")
+          is_transformer_failed[[name]] <- FALSE
+          data_out <- transforms[[name]]$server(name, data = data_previous)
+          data_handled <- reactive(tryCatch(data_out(), error = function(e) e))
+          observeEvent(data_handled(), {
+            if (inherits(data_handled(), "teal_data")) {
+              is_transformer_failed[[name]] <- FALSE
+            } else {
+              is_transformer_failed[[name]] <- TRUE
+            }
+          })
+
+          is_previous_failed <- reactive({
+            idx_this <- which(names(is_transformer_failed) == name)
+            is_transformer_failed_list <- reactiveValuesToList(is_transformer_failed)
+            idx_failures <- which(unlist(is_transformer_failed_list))
+            any(idx_failures < idx_this)
+          })
+
+          srv_validate_error("silent_error", data_handled, validate_shiny_silent_error = FALSE)
+          srv_check_class_teal_data("class_teal_data", data_handled)
+          if (!is.null(modules)) {
+            srv_check_module_datanames("datanames_warning", data_handled, modules)
+          }
+
+          transform_wrapper_id <- sprintf("wrapper_%s", name)
+          output$error_wrapper <- renderUI({
+            if (is_previous_failed()) {
+              shinyjs::disable(transform_wrapper_id)
+              tags$div("One of previous transformers failed. Please fix and continue.", class = "teal-output-warning")
+            } else {
+              shinyjs::enable(transform_wrapper_id)
+              shiny::tagList(
+                ui_validate_error(session$ns("silent_error")),
+                ui_check_class_teal_data(session$ns("class_teal_data")),
+                ui_check_module_datanames(session$ns("datanames_warning"))
+              )
+            }
+          })
+
+          .trigger_on_success(data_handled)
+        })
       },
       x = names(transforms),
       init = data

R/modules.R

@@ -48,14 +48,12 @@ setOldClass("teal_modules")
 #' @param server_args (named `list`) with additional arguments passed on to the server function.
 #' @param ui_args (named `list`) with additional arguments passed on to the UI function.
 #' @param x (`teal_module` or `teal_modules`) Object to format/print.
-#' @param indent (`integer(1)`) Indention level; each nested element is indented one level more.
-#' @param transformers (`list` of `teal_data_module`) that will be applied to transform the data.
+#' @param transformers (`list` of `teal_transform_module`) that will be applied to transform module's data input.
 #' Each transform module UI will appear in the `teal` application, unless the `custom_ui` attribute is set on the list.
 #' If so, the module developer is responsible to display the UI in the module itself. `datanames` of the `transformers`
 #' will be added to the `datanames`.
 #'
-#' When the transformation does not have sufficient input data, the resulting data will fallback
-#' to the last successful transform or, in case there are none, to the filtered data.
+#'
 #' @param ...
 #' - For `modules()`: (`teal_module` or `teal_modules`) Objects to wrap into a tab.
 #' - For `format()` and `print()`: Arguments passed to other methods.
@@ -315,7 +313,12 @@ modules <- function(..., label = "root") {
 
 #' @rdname teal_modules
 #' @export
-format.teal_module <- function(x, indent = 0, ...) {
+format.teal_module <- function(x, ...) {
+  if (is.null(list(...)$indent)) {
+    indent <- 0L
+  } else {
+    indent <- list(...)$indent
+  }
   paste0(paste(rep(" ", indent), collapse = ""), "+ ", x$label, "\n", collapse = "")
 }
 
@@ -330,7 +333,13 @@ print.teal_module <- function(x, ...) {
 
 #' @rdname teal_modules
 #' @export
-format.teal_modules <- function(x, indent = 0, ...) {
+format.teal_modules <- function(x, ...) {
+  if (is.null(list(...)$indent)) {
+    indent <- 0L
+  } else {
+    indent <- list(...)$indent
+  }
+
   paste(
     c(
       paste0(rep(" ", indent), "+ ", x$label, "\n"),