1304 extensions - wrap repetitive code into modules (#1338)

This PR extends #1333 Starting a new PR against the feature branch in case my changes break pipelines. The current feature branch is green and working. The only thing we wanted to improve is the reduction of the repetitive code and inclusion of such code into modules. @gogonzo the last thing to discuss is whether we rename `srv_validate_teal_data` or `srv_validate_reactive_teal_data`. Maybe this discussion can be continued in here #1330 (comment) <details><summary>Tested with below code</summary> ```r pkgload::load_all("teal") # ░█──░█ ─█▀▀█ ░█─── ▀█▀ ░█▀▀▄ # ─░█░█─ ░█▄▄█ ░█─── ░█─ ░█─░█ # ──▀▄▀─ ░█─░█ ░█▄▄█ ▄█▄ ░█▄▄▀ # 1. Teal App with teal_data app <- init( data = teal_data(iris_raw = iris, mtcars = mtcars), modules = modules(example_module("Module 1"), example_module("Module 2")) ) shinyApp(app$ui, app$server) # 2. Teal App with teal_data_module app <- init( data = teal_data_module( ui = function(id) { actionButton(NS(id, "submit"), "Submit") }, server = function(id) { moduleServer(id, function(input, output, session) { eventReactive(input$submit, { teal_data(iris = iris, mtcars = mtcars) }) }) }, once = TRUE # also try once = FALSE ), modules = modules(example_module("Module 1"), example_module("Module 2")) ) shinyApp(app$ui, app$server) # 3. Teal Module with teal_data modules <- modules(example_module(), example_module("mtcars only", datanames = "mtcars")) ui <- fluidPage( "Custom UI", ui_teal(id = "teal_1", modules = modules), ui_teal(id = "teal_2", modules = modules) ) server <- function(input, output, session) { data <- teal_data(iris = iris, mtcars = mtcars) srv_teal(id = "teal_1", data = data, modules = modules) srv_teal(id = "teal_2", data = data, modules = modules) } shinyApp(ui, server) # 4. Teal Module with teal_data_module modules <- modules(example_module("Module 1"), example_module("Module 2")) data <- teal_data_module( ui = function(id) { actionButton(NS(id, "submit"), "Submit") }, server = function(id) { moduleServer(id, function(input, output, session) { eventReactive(input$submit, { teal_data(iris = iris, mtcars = mtcars) }) }) }, once = TRUE # also try once = FALSE ) ui <- fluidPage( "Custom UI", ui_teal(id = "teal1", data = data, modules = modules), ui_teal(id = "teal2", data = data, modules = modules) ) server <- function(input, output, session) { srv_teal(id = "teal1", data = data, modules = modules) srv_teal(id = "teal2", data = data, modules = modules) } shinyApp(ui, server) # 5. Teal Module with reactive(teal_data) modules <- modules(example_module("One"), example_module("Two")) ui <- fluidPage( selectInput("data", "Data", c("iris", "mtcars"), multiple = TRUE), ui_teal(id = "teal_1", modules = modules), ui_teal(id = "teal_2", modules = modules) ) server <- function(input, output, session) { data <- reactive({ req(input$data) within( teal_data(), { if ("iris" %in% selection) { iris <- iris } if ("mtcars" %in% selection) { mtcars <- mtcars } }, selection = input$data ) }) srv_teal(id = "teal_1", data = data, modules = modules) srv_teal(id = "teal_2", data = data, modules = modules) } shinyApp(ui, server) # ░█▀▀▀ ░█▀▀█ ░█▀▀█ ░█▀▀▀█ ░█▀▀█ # ░█▀▀▀ ░█▄▄▀ ░█▄▄▀ ░█──░█ ░█▄▄▀ # ░█▄▄▄ ░█─░█ ░█─░█ ░█▄▄▄█ ░█─░█ # 1. Teal App with teal_data app <- init( data = within(teal_data(), { stop("error") }), modules = modules(example_module("Module 1"), example_module("Module 2")) ) app <- init( data = teal_data(), modules = modules(example_module("Module 1"), example_module("Module 2")) ) # 2. Teal App with teal_data_module app <- init( data = teal_data_module( ui = function(id) { actionButton(NS(id, "submit"), "Submit") }, server = function(id) { moduleServer(id, function(input, output, session) { eventReactive(input$submit, { within( teal_data(), { iris <- head(iris, count) if (count %% 2 != 0) { stop("error") } mtcars <- mtcars }, count = input$submit ) }) }) }, once = FALSE ), modules = modules(example_module("Module 1"), example_module("Module 2")) ) shinyApp(app$ui, app$server) # 3. Teal Module with teal_data modules <- modules(example_module(), example_module("mtcars only", datanames = "mtcars")) ui <- fluidPage( "Custom UI", ui_teal(id = "teal_1", modules = modules), ui_teal(id = "teal_2", modules = modules) ) server <- function(input, output, session) { data <- teal_data(iris = iris, mtcars = mtcars) srv_teal( id = "teal_1", data = within(teal_data(), { stop("error") }), modules = modules ) srv_teal( id = "teal_2", data = within(teal_data(), { stop("error") }), modules = modules ) } shinyApp(ui, server) # 4. Teal Module with teal_data_module modules <- modules(example_module("Module 1"), example_module("Module 2")) data <- teal_data_module( ui = function(id) { actionButton(NS(id, "submit"), "Submit") }, server = function(id) { moduleServer(id, function(input, output, session) { eventReactive(input$submit, { within( teal_data(), { iris <- head(iris, count) if (count %% 2 != 0) { stop("error") } mtcars <- mtcars }, count = input$submit ) }) }) }, once = F ) ui <- fluidPage( "Custom UI", ui_teal(id = "teal", data = data, modules = modules) ) server <- function(input, output, session) { srv_teal(id = "teal", data = data, modules = modules) } shinyApp(ui, server) # 4. Teal Module with teal_data_module - DELEGATE THE DATANAMES VALIDATION AFTER TEAL TRANSFORM modules <- modules(example_module(datanames = "CO2"), example_module("Module 2")) data <- teal_data_module( ui = function(id) { actionButton(NS(id, "submit"), "Submit") }, server = function(id) { moduleServer(id, function(input, output, session) { eventReactive(input$submit, { within( teal_data(), { if (count %% 2 != 0) { CO2 <- CO2 } iris <- head(iris, count) mtcars <- mtcars }, count = input$submit ) }) }) }, once = FALSE ) ui <- fluidPage( "Custom UI", ui_teal(id = "teal", data = data, modules = modules) ) server <- function(input, output, session) { srv_teal(id = "teal", data = data, modules = modules) } shinyApp(ui, server) # 5. Teal Module with reactive(teal_data) - Error is not observed modules <- modules(example_module("One"), example_module("Two")) ui <- fluidPage( selectInput("data", "Data", c("iris", "mtcars"), multiple = TRUE), ui_teal(id = "teal_1", modules = modules), ui_teal(id = "teal_2", modules = modules) ) server <- function(input, output, session) { data <- reactive({ within( teal_data(), { if ("iris" %in% selection) { iris <- iris } else { stop("No iris is an error!") } if ("mtcars" %in% selection) { mtcars <- mtcars } }, selection = input$data ) }) srv_teal(id = "teal_1", data = data, modules = modules) srv_teal(id = "teal_2", data = data, modules = modules) } shinyApp(ui, server) ``` </details> <details><summary>Results of local tests</summary> ```r > options(TESTING_DEPTH = 5) > devtools::test() ℹ Testing teal [INFO] 2024-09-02 12:59:39.2876 pid:23540 token:[] teal You are using teal version 0.15.2.9059 ✔ | F W S OK | Context ✔ | 11 | init [1.0s] ✔ | 6 126 | module_teal [44.0s] ✔ | 95 | modules ✔ | 7 | rcode_utils ✔ | 8 | report_previewer_module ✔ | 6 | shinytest2-data_summary [38.5s] ✔ | 5 | shinytest2-filter_panel [40.7s] ✔ | 17 | shinytest2-init [24.2s] ✔ | 11 | shinytest2-landing_popup [41.1s] ✔ | 4 | shinytest2-module_bookmark_manager [35.4s] ✔ | 5 | shinytest2-modules [38.8s] ✔ | 8 | shinytest2-reporter [72.1s] ✔ | 9 | shinytest2-show-rcode [9.7s] ✔ | 9 | shinytest2-teal_data_module [57.1s] ✔ | 18 | shinytest2-teal_slices [61.3s] ✔ | 4 | shinytest2-utils [9.6s] ✔ | 4 | shinytest2-wunder_bar [18.9s] ✔ | 16 | teal_data_module-eval_code ✔ | 4 | teal_data_module ✔ | 25 | teal_reporter ✔ | 15 | teal_slices-store ✔ | 18 | teal_slices ✔ | 36 | utils [7.4s] ✔ | 17 | validate_has_data ✔ | 36 | validate_inputs ══ Results ══════════════════════════════════════════════════════════════════════════════════════════════════════════════════ Duration: 502.8 s ── Skipped tests (6) ──────────────────────────────────────────────────────────────────────────────────────────────────────── • need a fix in a .slicesGlobal (1): test-module_teal.R:1178:11 • todo (5): test-module_teal.R:1443:7, test-module_teal.R:1450:5, test-module_teal.R:1453:5, test-module_teal.R:1709:5, test-module_teal.R:1715:5 [ FAIL 0 | WARN 0 | SKIP 6 | PASS 514 ] ``` </details> --------- Co-authored-by: github-actions <41898282+github-actions[bot]@users.noreply.github.com>
insightsengineering · Sep 3, 2024 · 5dabd5b · 5dabd5b
1 parent c3ea231
commit 5dabd5b
Show file tree

Hide file tree

Showing 6 changed files with 110 additions and 75 deletions.
diff --git a/.github/workflows/check.yaml b/.github/workflows/check.yaml
@@ -10,6 +10,7 @@ on:
       - ready_for_review
     branches:
       - main
+      - 1304-handle-data-inputs@main
   push:
     branches:
       - main

diff --git a/R/module_nested_tabs.R b/R/module_nested_tabs.R
@@ -302,33 +302,21 @@ srv_teal_module.teal_module <- function(id,
 #' @keywords internal
 ui_validate_teal_data <- function(id) {
   ns <- NS(id)
-  uiOutput(ns("validation_error"))
+  div(
+    ui_check_class_teal_data(ns("class_teal_data")),
+    ui_is_empty_teal_data(ns("is_empty_teal_data"))
+  )
 }
 
 #' @keywords internal
 srv_validate_teal_data <- function(id, data) {
+  checkmate::assert_string(id)
   moduleServer(id, function(input, output, session) {
-    output$validation_error <- renderUI({
-      if (inherits(data(), "teal_data")) {
-        validate(
-          need(
-            !.is_empty_teal_data(data()),
-            "The module did not recieve any data"
-          )
-        )
-      } else {
-        validate(
-          need(
-            FALSE,
-            "The module did not recieve `teal_data`"
-          )
-        )
-      }
-    })
+    srv_check_class_teal_data("check_class_teal_data", data)
+    srv_is_empty_teal_data("is_empty_teal_data", data, "Empty `teal_data` object.")
   })
 }
 
-
 # This function calls a module server function.
 .call_teal_module <- function(modules, datasets, filtered_teal_data, reporter) {
   # collect arguments to run teal_module

diff --git a/R/module_teal.R b/R/module_teal.R
@@ -102,7 +102,7 @@ ui_teal <- function(id,
     shiny_busy_message_panel,
     tags$div(
       class = "teal_validated",
-      uiOutput(ns("shiny_error"))
+      ui_validate_qenv_error(ns("qenv_error"))
     ),
     tags$div(
       id = ns("tabpanel_wrapper"),
@@ -198,23 +198,8 @@ srv_teal <- function(id, data, modules, filter = teal_slices()) {
       }
     })
 
-    output$shiny_error <- renderUI({
-      if (inherits(init_data(), "qenv.error")) {
-        validate(
-          need(
-            FALSE,
-            paste(
-              "Error when executing the `data` module:",
-              strip_style(paste(init_data()$message, collapse = "\n")),
-              "\nCheck your inputs or contact app developer if error persists.",
-              collapse = "\n"
-            )
-          )
-        )
-      }
+    srv_validate_qenv_error("qenv_error", init_data)
 
-      NULL
-    })
     datasets_rv <- if (!isTRUE(attr(filter, "module_specific"))) {
       eventReactive(data_rv(), {
         if (!inherits(data_rv(), "teal_data")) {

diff --git a/R/module_teal_data.R b/R/module_teal_data.R
@@ -61,22 +61,10 @@ srv_teal_data <- function(id,
   moduleServer(id, function(input, output, session) {
     logger::log_debug("srv_teal_data initializing.")
 
-    data_in <- reactive({
-      if (inherits(data(), "teal_data")) {
-        if (.is_empty_teal_data(data())) {
-          validate(
-            need(
-              FALSE,
-              "Empty `teal_data` object."
-            )
-          )
-        }
-      }
-      data()
-    })
+    srv_is_empty_teal_data("is_empty_teal_data", data, "The module did not receive any data")
 
     data_out <- if (is_arg_used(data_module$server, "data")) {
-      data_module$server(id = "data", data = data_in)
+      data_module$server(id = "data", data = data)
     } else {
       data_module$server(id = "data")
     }
@@ -100,10 +88,13 @@ srv_teal_data <- function(id,
 
 #' @rdname module_teal_data
 ui_validate_reactive_teal_data <- function(id) {
+  ns <- NS(id)
   div(
     class = "teal_validated",
-    uiOutput(NS(id, "shiny_errors")),
-    uiOutput(NS(id, "shiny_warnings"))
+    ui_validate_silent_error(ns("silent_error")),
+    ui_validate_qenv_error(ns("qenv_error")),
+    ui_check_class_teal_data(ns("class_teal_data")),
+    ui_check_shiny_warnings(ns("shiny_warnings"))
   )
 }
 
@@ -117,16 +108,33 @@ srv_validate_reactive_teal_data <- function(id, # nolint: object_length
   checkmate::assert_flag(validate_shiny_silent_error)
 
   moduleServer(id, function(input, output, session) {
-    data_out_r <- reactive(tryCatch(data(), error = function(e) e))
+    data_rv <- reactive(tryCatch(data(), error = function(e) e))
+
+    # there is an empty reactive cycle on init!
+    srv_validate_silent_error("silent_error", data_rv, validate_shiny_silent_error)
+    srv_validate_qenv_error("qenv_error", data_rv)
+    srv_check_class_teal_data("class_teal_data", data_rv)
+    srv_check_shiny_warnings("shiny_warnings", data_rv, modules)
+
+    data_rv
+  })
+}
 
-    data_validated <- reactive({
-      # custom module can return error
-      data_out <- data_out_r()
+#' @keywords internal
+ui_validate_silent_error <- function(id) {
+  ns <- NS(id)
+  uiOutput(ns("error"))
+}
 
-      # there is an empty reactive cycle on init!
-      if (inherits(data_out, "shiny.silent.error") && identical(data_out$message, "")) {
+#' @keywords internal
+srv_validate_silent_error <- function(id, data, validate_shiny_silent_error) {
+  checkmate::assert_string(id)
+  checkmate::assert_flag(validate_shiny_silent_error)
+  moduleServer(id, function(input, output, session) {
+    output$error <- renderUI({
+      if (inherits(data(), "shiny.silent.error") && identical(data()$message, "")) {
         if (!validate_shiny_silent_error) {
-          return(teal_data())
+          return(NULL)
         } else {
           validate(
             need(
@@ -140,40 +148,95 @@ srv_validate_reactive_teal_data <- function(id, # nolint: object_length
           )
         }
       }
+    })
+  })
+}
 
-      # to handle errors and qenv.error(s)
-      if (inherits(data_out, c("qenv.error"))) {
+#' @keywords internal
+ui_validate_qenv_error <- function(id) {
+  ns <- NS(id)
+  uiOutput(ns("error"))
+}
+
+#' @keywords internal
+srv_validate_qenv_error <- function(id, data) {
+  checkmate::assert_string(id)
+  moduleServer(id, function(input, output, session) {
+    output$error <- renderUI({
+      if (inherits(data(), c("qenv.error"))) {
         validate(
           need(
             FALSE,
             paste(
               "Error when executing the `data` module:",
-              strip_style(paste(data_out$message, collapse = "\n")),
+              strip_style(paste(data()$message, collapse = "\n")),
               "\nCheck your inputs or contact app developer if error persists.",
               collapse = "\n"
             )
           )
         )
       }
+    })
+  })
+}
 
+#' @keywords internal
+ui_check_class_teal_data <- function(id) {
+  ns <- NS(id)
+  uiOutput(ns("check"))
+}
+
+#' @keywords internal
+srv_check_class_teal_data <- function(id, data) {
+  checkmate::assert_string(id)
+  moduleServer(id, function(input, output, session) {
+    output$check <- renderUI({
       validate(
         need(
-          checkmate::test_class(data_out, "teal_data"),
+          checkmate::test_class(data(), "teal_data"),
           "Did not recieve a valid `teal_data` object. Cannot proceed further."
         )
       )
-
-      data_out
     })
+  })
+}
+
+#' @keywords internal
+ui_is_empty_teal_data <- function(id) {
+  ns <- NS(id)
+  uiOutput(ns("is_empty"))
+}
 
-    output$shiny_errors <- renderUI({
-      data_validated()
-      NULL
+#' @keywords internal
+srv_is_empty_teal_data <- function(id, data, message) {
+  checkmate::assert_string(id)
+  moduleServer(id, function(input, output, session) {
+    output$is_empty <- renderUI({
+      if (inherits(data(), "teal_data")) {
+        validate(
+          need(
+            !.is_empty_teal_data(data()),
+            message
+          )
+        )
+      }
     })
+  })
+}
 
-    output$shiny_warnings <- renderUI({
-      if (inherits(data_out_r(), "teal_data")) {
-        is_modules_ok <- check_modules_datanames(modules = modules, datanames = .teal_data_ls(data_validated()))
+#' @keywords internal
+ui_check_shiny_warnings <- function(id) {
+  ns <- NS(id)
+  uiOutput(NS(id, "warnings"))
+}
+
+#' @keywords internal
+srv_check_shiny_warnings <- function(id, data, modules) {
+  checkmate::assert_string(id)
+  moduleServer(id, function(input, output, session) {
+    output$warnings <- renderUI({
+      if (inherits(data(), "teal_data")) {
+        is_modules_ok <- check_modules_datanames(modules = modules, datanames = .teal_data_ls(data()))
         if (!isTRUE(is_modules_ok)) {
           tags$div(
             class = "teal-output-warning",
@@ -185,7 +248,5 @@ srv_validate_reactive_teal_data <- function(id, # nolint: object_length
         }
       }
     })
-
-    data_validated
   })
 }
diff --git a/tests/testthat/test-module_teal.R b/tests/testthat/test-module_teal.R
@@ -511,7 +511,7 @@ testthat::describe("srv_teal teal_modules", {
           trimws(
             rvest::html_text2(
               rvest::read_html(
-                output[["teal_modules-module_1-validate_datanames-shiny_warnings"]]$html
+                output[["teal_modules-module_1-validate_datanames-shiny_warnings-warnings"]]$html
               )
             )
           ),

diff --git a/tests/testthat/test-shinytest2-filter_panel.R b/tests/testthat/test-shinytest2-filter_panel.R
@@ -1,7 +1,7 @@
 testthat::skip_if_not_installed("shinytest2")
 testthat::skip_if_not_installed("rvest")
 
-testthat::test_that("e2e: module content is updated when a data is filtered in filter panel", {
+testthat::test_that("e2e: module content is updated when data is filtered in filter panel", {
   skip_if_too_deep(5)
   app <- TealAppDriver$new(
     data = simple_teal_data(),