teal reactivity solution 2

NEWS.md

@@ -1,17 +1,15 @@
 # teal 0.12.0.9022
 
-### Major breaking changes
-
-* The use of `datasets` argument in `modules` has been deprecated and will be removed in a future release. Please use `data` argument instead. `data` is of type `tdata`; see "Creating custom modules" vignettes and function documentation of `teal::new_tdata` for further details.
-
 ### Breaking changes
 
+* The use of `datasets` argument in `modules` has been deprecated and will be removed in a future release. Please use `data` argument instead. `data` is of type `tdata`; see "Creating custom modules" vignettes and function documentation of `teal::new_tdata` for further details.
 * Due to deprecation of `chunks` in `teal.code`, the `teal` framework now uses their replacement (`qenv`) instead. The documentation in `teal` has been updated to reflect this and custom modules written with `chunks` should be updated to use `qenv`.
 
 ### New features
 
 * Added the `validate_inputs` function that transfers input validation messages to app output.
 * `modules` argument of `init` accepts `teal_module` type of object. There is no need to wrap up a single module in `modules()` or `list()`.
+* Updated `module_nested_tabs` so that only active modules are calculated in a teal app.
 
 ### Miscellaneous
 

R/module_nested_tabs.R

@@ -88,9 +88,10 @@ ui_nested_tabs.teal_modules <- function(id, modules, datasets, depth = 0L) {
 #' @export
 #' @keywords internal
 ui_nested_tabs.teal_module <- function(id, modules, datasets, depth = 0L) {
+  ns <- NS(id)
   checkmate::assert_class(datasets, "FilteredData")
   args <- isolate(teal.transform::resolve_delayed(modules$ui_args, datasets))
-  args <- c(list(id = id), args)
+  args <- c(list(id = ns("module")), args)
 
   if (is_arg_used(modules$ui, "datasets")) {
     args <- c(args, datasets = datasets)
@@ -105,6 +106,7 @@ ui_nested_tabs.teal_module <- function(id, modules, datasets, depth = 0L) {
   tags$div(
     id = id,
     class = "teal_module",
+    uiOutput(ns("data_reactive"), inline = TRUE),
     tagList(
       if (depth >= 2L) div(style = "mt-6"),
       do.call(modules$ui, args)
@@ -179,42 +181,61 @@ srv_nested_tabs.teal_module <- function(id, datasets, modules, reporter) {
       "module { deparse1(modules$label) }."
     )
   )
-  modules$server_args <- teal.transform::resolve_delayed(modules$server_args, datasets)
+  moduleServer(id = id, module = function(input, output, session) {
+    modules$server_args <- teal.transform::resolve_delayed(modules$server_args, datasets)
 
-  args <- c(list(id = id), modules$server_args)
-  if (is_arg_used(modules$server, "reporter")) {
-    args <- c(args, list(reporter = reporter))
-  }
+    args <- c(list(id = "module"), modules$server_args)
+    if (is_arg_used(modules$server, "reporter")) {
+      args <- c(args, list(reporter = reporter))
+    }
 
-  if (is_arg_used(modules$server, "datasets")) {
-    args <- c(args, datasets = datasets)
-  }
+    if (is_arg_used(modules$server, "datasets")) {
+      args <- c(args, datasets = datasets)
+    }
 
-  if (is_arg_used(modules$server, "data")) {
-    data <- .datasets_to_data(modules, datasets)
-    args <- c(args, data = list(data))
-  }
+    datanames <- if (identical("all", modules$filter) || is.null(modules$filter)) {
+      datasets$datanames()
+    } else {
+      datasets$get_filterable_datanames(modules$filter) # get_filterable_datanames adds parents if present
+    }
 
-  if (is_arg_used(modules$server, "filter_panel_api")) {
-    filter_panel_api <- teal.slice::FilterPanelAPI$new(datasets)
-    args <- c(args, filter_panel_api = filter_panel_api)
-  }
+    # trigger the data when the tab is selected
+    trigger_data <- reactiveVal(1L)
+    output$data_reactive <- renderUI({
+      lapply(datanames, function(x) {
+        datasets$get_data(x, filtered = TRUE)
+      })
+      isolate(trigger_data(trigger_data() + 1))
 
-  if (is_arg_used(modules$server, "datasets") && is_arg_used(modules$server, "data")) {
-    warning(
-      "Module '", modules$label, "' has `data` and `datasets` arguments in the formals.",
-      "\nIt's recommended to use `data` to work with filtered objects."
-    )
-  }
+      NULL
+    })
 
-  # teal_modules do not suppose to return values as it's never passed anyway
-  # it's assigned here for tests
-  module_output <- if (is_arg_used(modules$server, "id")) {
-    do.call(modules$server, args)
-  } else {
-    do.call(callModule, c(args, list(module = modules$server)))
-  }
-  reactive(modules)
+    if (is_arg_used(modules$server, "data")) {
+      data <- .datasets_to_data(modules, datasets, trigger_data)
+      args <- c(args, data = list(data))
+    }
+
+    if (is_arg_used(modules$server, "filter_panel_api")) {
+      filter_panel_api <- teal.slice::FilterPanelAPI$new(datasets)
+      args <- c(args, filter_panel_api = filter_panel_api)
+    }
+
+    if (is_arg_used(modules$server, "datasets") && is_arg_used(modules$server, "data")) {
+      warning(
+        "Module '", modules$label, "' has `data` and `datasets` arguments in the formals.",
+        "\nIt's recommended to use `data` to work with filtered objects."
+      )
+    }
+
+    # teal_modules do not suppose to return values as it's never passed anyway
+    # it's assigned here for tests
+    module_output <- if (is_arg_used(modules$server, "id")) {
+      do.call(modules$server, args)
+    } else {
+      do.call(callModule, c(args, list(module = modules$server)))
+    }
+    reactive(modules)
+  })
 }
 
 #' Convert `FilteredData` to reactive list of datasets of the `tdata` type.
@@ -225,13 +246,15 @@ srv_nested_tabs.teal_module <- function(id, datasets, modules, reporter) {
 #'
 #' @param module (`teal_module`) module where needed filters are taken from
 #' @param datasets (`FilteredData`) object where needed data are taken from
+#' @param trigger_data (`reactiveVal`) to trigger getting the filtered data
 #' @return list of reactive datasets with following attributes:
 #' - `code` (`character`) containing datasets reproducible code.
 #' - `join_keys` (`JoinKeys`) containing relationships between datasets.
 #' - `metadata` (`list`) containing metadata of datasets.
 #'
 #' @keywords internal
-.datasets_to_data <- function(module, datasets) {
+.datasets_to_data <- function(module, datasets, trigger_data = reactiveVal(1L)) {
+  checkmate::assert_class(trigger_data, "reactiveVal")
   datanames <- if (identical("all", module$filter) || is.null(module$filter)) {
     datasets$datanames()
   } else {
@@ -240,11 +263,9 @@ srv_nested_tabs.teal_module <- function(id, datasets, modules, reporter) {
 
   # list of reactive filtered data
   data <- sapply(
-    datanames,
-    simplify = FALSE,
-    function(x) {
-      reactive(datasets$get_data(x, filtered = TRUE))
-    }
+    USE.NAMES = TRUE,
+    X = datanames,
+    FUN = function(x) eventReactive(trigger_data(), datasets$get_data(x, filtered = TRUE))
   )
 
   hashes <- calculate_hashes(datanames, datasets)
@@ -253,7 +274,8 @@ srv_nested_tabs.teal_module <- function(id, datasets, modules, reporter) {
 
   new_tdata(
     data,
-    reactive(
+    eventReactive(
+      trigger_data(),
       c(
         get_rcode_str_install(),
         get_rcode_libraries(),

tests/testthat/test-module_nested_tabs.R

@@ -278,11 +278,31 @@ get_example_filtered_data <- function() {
   )
 }
 
+testthat::test_that(".datasets_to_data accepts a reactiveVal as trigger_data input", {
+  datasets <- get_example_filtered_data()
+  isolate(datasets$set_filter_state(list(d1 = list(val = list(selected = c(1, 2))))))
+  module <- list(filter = "all")
+  trigger_data <- reactiveVal(1L)
+  testthat::expect_silent(isolate(.datasets_to_data(module, datasets, trigger_data)))
+})
+
+testthat::test_that(".datasets_to_data throws error if trigger_data is not a reactiveVal function", {
+  datasets <- get_example_filtered_data()
+  isolate(datasets$set_filter_state(list(d1 = list(val = list(selected = c(1, 2))))))
+  module <- list(filter = "all")
+  trigger_data <- 1
+  testthat::expect_error(
+    isolate(.datasets_to_data(module, datasets, trigger_data)),
+    "Must inherit from class 'reactiveVal', but has class 'numeric'."
+  )
+})
+
 testthat::test_that(".datasets_to_data returns data which is filtered", {
   datasets <- get_example_filtered_data()
   isolate(datasets$set_filter_state(list(d1 = list(val = list(selected = c(1, 2))))))
   module <- list(filter = "all")
-  data <- isolate(.datasets_to_data(module, datasets))
+  trigger_data <- reactiveVal(1L)
+  data <- isolate(.datasets_to_data(module, datasets, trigger_data))
 
   d1_filtered <- isolate(data[["d1"]]())
   testthat::expect_equal(d1_filtered, data.frame(id = 1:2, pk = 2:3, val = 1:2))
@@ -294,14 +314,16 @@ testthat::test_that(".datasets_to_data returns data which is filtered", {
 testthat::test_that(".datasets_to_data returns only data requested by modules$filter", {
   datasets <- get_example_filtered_data()
   module <- list(filter = "d1")
-  data <- .datasets_to_data(module, datasets)
+  trigger_data <- reactiveVal(1L)
+  data <- .datasets_to_data(module, datasets, trigger_data)
   testthat::expect_equal(isolate(names(data)), "d1")
 })
 
 testthat::test_that(".datasets_to_data returns tdata object", {
   datasets <- get_example_filtered_data()
   module <- list(filter = "all")
-  data <- .datasets_to_data(module, datasets)
+  trigger_data <- reactiveVal(1L)
+  data <- .datasets_to_data(module, datasets, trigger_data)
 
   testthat::expect_s3_class(data, "tdata")
 
@@ -349,7 +371,8 @@ testthat::test_that(".datasets_to_data returns parent datasets for CDISC data",
   )
 
   module <- list(filter = "ADAE")
-  data <- .datasets_to_data(module, datasets)
+  trigger_data <- reactiveVal(1L)
+  data <- .datasets_to_data(module, datasets, trigger_data)
   testthat::expect_setequal(isolate(names(data)), c("ADSL", "ADAE"))
 })