Merge remote-tracking branch 'origin/main' into 479_mirai_lockfile@main

Author: gogonzo

DESCRIPTION

@@ -1,8 +1,8 @@
 Type: Package
 Package: teal
 Title: Exploratory Web Apps for Analyzing Clinical Trials Data
-Version: 0.15.2.9056
-Date: 2024-08-16
+Version: 0.15.2.9059
+Date: 2024-08-28
 Authors@R: c(
     person("Dawid", "Kaledkowski", , "[email protected]", role = c("aut", "cre"),
            comment = c(ORCID = "0000-0001-9533-457X")),
@@ -90,6 +90,7 @@ Roxygen: list(markdown = TRUE)
 RoxygenNote: 7.3.2
 Collate:
     'TealAppDriver.R'
+    'checkmate.R'
     'dummy_functions.R'
     'get_rcode_utils.R'
     'include_css_js.R'

NEWS.md

@@ -1,4 +1,4 @@
-# teal 0.15.2.9056
+# teal 0.15.2.9059
 
 ### New features
 

R/checkmate.R

@@ -0,0 +1,49 @@
+#' Check that argument is reactive.
+#'
+#' @inherit checkmate::check_class params return
+#'
+#' @keywords internal
+check_reactive <- function(x, null.ok = FALSE) { # nolint: object_name_linter.
+  if (!isTRUE(checkmate::test_class(x, classes = "reactive", null.ok = null.ok))) {
+    cl <- class(x)
+    return(sprintf(
+      "Must be a reactive (i.e. inherit from 'reactive' class) but has class%s '%s'",
+      if (length(cl) > 1L) "es" else "",
+      paste0(cl, collapse = "','")
+    ))
+  }
+  return(TRUE)
+}
+#' @rdname check_reactive
+test_reactive <- function(x, null.ok = FALSE) { # nolint: object_name_linter.
+  isTRUE(check_reactive(x, null.ok = null.ok))
+}
+#' @rdname check_reactive
+assert_reactive <- checkmate::makeAssertionFunction(check_reactive)
+
+#' Capture error and decorate error message.
+#'
+#' @param x object to evaluate
+#' @param pre (`character(1)`) A string to prepend to error message
+#' @param post (`character(1)`) A string to append to error message
+#'
+#' @return `x` if no error, otherwise throws error with decorated message
+#'
+#' @keywords internal
+decorate_err_msg <- function(x, pre = character(0), post = character(0)) {
+  tryCatch(
+    x,
+    error = function(e) {
+      stop(
+        "\n",
+        pre,
+        "\n",
+        e$message,
+        "\n",
+        post,
+        call. = FALSE
+      )
+    }
+  )
+  x
+}

R/init.R

@@ -216,8 +216,8 @@ init <- function(data,
     }
 
     is_modules_ok <- check_modules_datanames(modules, .teal_data_datanames(data))
-    if (!isTRUE(is_modules_ok)) {
-      lapply(is_modules_ok$string, logger::log_warn)
+    if (!isTRUE(is_modules_ok) && length(unlist(extract_transformers(modules))) == 0) {
+      lapply(is_modules_ok$string, warning, call. = FALSE)
     }
 
     is_filter_ok <- check_filter_datanames(filter, .teal_data_datanames(data))

R/module_data_summary.R

@@ -54,7 +54,7 @@ ui_data_summary <- function(id) {
 
 #' @rdname module_data_summary
 srv_data_summary <- function(id, teal_data) {
-  checkmate::check_class(teal_data, "reactive")
+  assert_reactive(teal_data)
   moduleServer(
     id = id,
     function(input, output, session) {
@@ -142,11 +142,13 @@ get_filter_overview <- function(teal_data) {
   datanames <- teal.data::datanames(teal_data())
   joinkeys <- teal.data::join_keys(teal_data())
   filtered_data_objs <- sapply(
-    datanames, function(name) teal.code::get_env(teal_data())[[name]],
+    datanames,
+    function(name) teal.code::get_env(teal_data())[[name]],
     simplify = FALSE
   )
   unfiltered_data_objs <- sapply(
-    datanames, function(name) teal.code::get_env(teal_data())[[paste0(name, "._raw_")]],
+    datanames,
+    function(name) teal.code::get_env(teal_data())[[paste0(name, "._raw_")]],
     simplify = FALSE
   )
 

R/module_filter_data.R

@@ -25,7 +25,7 @@ ui_filter_data <- function(id) {
 
 #' @rdname module_filter_data
 srv_filter_data <- function(id, datasets, active_datanames, data_rv, is_active) {
-  checkmate::assert_class(datasets, "reactive")
+  assert_reactive(datasets)
   moduleServer(id, function(input, output, session) {
     output$panel <- renderUI({
       req(inherits(datasets(), "FilteredData"))

R/module_filter_manager.R

@@ -173,7 +173,7 @@ srv_filter_manager <- function(id, slices_global) {
 #' @rdname module_filter_manager
 srv_module_filter_manager <- function(id, module_fd, slices_global) {
   checkmate::assert_string(id)
-  checkmate::assert_class(module_fd, "reactive")
+  assert_reactive(module_fd)
   checkmate::assert_class(slices_global, ".slicesGlobal")
 
   moduleServer(id, function(input, output, session) {

R/module_init_data.R

@@ -79,7 +79,7 @@ srv_init_data <- function(id, data, modules, filter = teal_slices()) {
       )
     } else if (inherits(data, "teal_data")) {
       reactiveVal(data)
-    } else if (inherits(data, c("reactive", "reactiveVal"))) {
+    } else if (test_reactive(data)) {
       .fallback_on_failure(this = data, that = reactive(req(FALSE)), label = "Reactive data")
     }
 

R/module_nested_tabs.R

@@ -130,9 +130,9 @@ srv_teal_module <- function(id,
                             reporter = teal.reporter::Reporter$new(),
                             is_active = reactive(TRUE)) {
   checkmate::assert_string(id)
-  checkmate::assert_class(data_rv, "reactive")
+  assert_reactive(data_rv)
   checkmate::assert_multi_class(modules, c("teal_modules", "teal_module"))
-  checkmate::assert_class(datasets, "reactive", null.ok = TRUE)
+  assert_reactive(datasets, null.ok = TRUE)
   checkmate::assert_class(slices_global, ".slicesGlobal")
   checkmate::assert_class(reporter, "Reporter")
   UseMethod("srv_teal_module", modules)

R/module_teal_data.R

@@ -55,7 +55,6 @@ srv_teal_data <- function(id,
                           modules = NULL,
                           validate_shiny_silent_error = TRUE) {
   checkmate::assert_string(id)
-  checkmate::assert_class(data, "reactive")
   checkmate::assert_class(data_module, "teal_data_module")
   checkmate::assert_multi_class(modules, c("teal_modules", "teal_module"), null.ok = TRUE)
 
@@ -96,16 +95,16 @@ srv_validate_reactive_teal_data <- function(id, # nolint: object_length
                                             data,
                                             modules = NULL,
                                             validate_shiny_silent_error = FALSE) {
-  moduleServer(id, function(input, output, session) {
-    if (!is.reactive(data)) {
-      stop("The `teal_data_module` passed to `data` must return a reactive expression.", call. = FALSE)
-    }
+  checkmate::assert_string(id)
+  checkmate::assert_multi_class(modules, c("teal_modules", "teal_module"), null.ok = TRUE)
+  checkmate::assert_flag(validate_shiny_silent_error)
 
-    data_out_rv <- reactive(tryCatch(data(), error = function(e) e))
+  moduleServer(id, function(input, output, session) {
+    data_out_r <- reactive(tryCatch(data(), error = function(e) e))
 
     data_validated <- reactive({
       # custom module can return error
-      data_out <- data_out_rv()
+      data_out <- data_out_r()
 
       # there is an empty reactive cycle on init!
       if (inherits(data_out, "shiny.silent.error") && identical(data_out$message, "")) {
@@ -116,9 +115,9 @@ srv_validate_reactive_teal_data <- function(id, # nolint: object_length
             need(
               FALSE,
               paste(
-                strip_style(data_out$message),
+                "Shiny error when executing the `data` module",
                 "Check your inputs or contact app developer if error persists.",
-                sep = ifelse(identical(data_out$message, ""), "", "\n")
+                collapse = "\n"
               )
             )
           )
@@ -130,23 +129,24 @@ srv_validate_reactive_teal_data <- function(id, # nolint: object_length
         validate(
           need(
             FALSE,
-            paste(
-              "Error when executing `teal_data_module` passed to `data`:\n ",
+            paste0(
+              "Error when executing the `data` module:",
               strip_style(paste(data_out$message, collapse = "\n")),
-              "\n Check your inputs or contact app developer if error persists."
+              "Check your inputs or contact app developer if error persists.",
+              collapse = "\n"
             )
           )
         )
       }
 
       validate(
         need(
-          inherits(data_out, "teal_data"),
-          paste(
-            "Error: `teal_data_module` passed to `data` failed to return `teal_data` object, returned",
-            strip_style(toString(sQuote(class(data_out)))),
-            "instead.",
-            "\n Check your inputs or contact app developer if error persists."
+          checkmate::test_class(data_out, "teal_data"),
+          paste0(
+            "Assertion on return value from the 'data' module failed:",
+            checkmate::test_class(data_out, "teal_data"),
+            "Check your inputs or contact app developer if error persists.",
+            collapse = "\n"
           )
         )
       )
@@ -160,7 +160,7 @@ srv_validate_reactive_teal_data <- function(id, # nolint: object_length
     })
 
     output$shiny_warnings <- renderUI({
-      if (inherits(data_out_rv(), "teal_data")) {
+      if (inherits(data_out_r(), "teal_data")) {
         is_modules_ok <- check_modules_datanames(modules = modules, datanames = .teal_data_ls(data_validated()))
         if (!isTRUE(is_modules_ok)) {
           tags$div(
@@ -191,8 +191,8 @@ srv_validate_reactive_teal_data <- function(id, # nolint: object_length
 #' @return `reactive` `teal_data`
 #' @keywords internal
 .fallback_on_failure <- function(this, that, label) {
-  checkmate::assert_class(this, "reactive")
-  checkmate::assert_class(that, "reactive")
+  assert_reactive(this)
+  assert_reactive(that)
   checkmate::assert_string(label)
 
   reactive({