Module specific filter panels (#837)

DESCRIPTION

@@ -34,8 +34,6 @@ Imports:
     rlang,
     shinyjs,
     stats,
-    styler,
-    teal.code (>= 0.2.0),
     teal.logger (>= 0.1.1),
     teal.reporter (>= 0.1.1),
     teal.slice (>= 0.2.0),
@@ -52,6 +50,7 @@ Suggests:
     scda (>= 0.1.5),
     scda.2022 (>= 0.1.3),
     shinyvalidate,
+    teal.code (>= 0.3.0),
     testthat (>= 3.1.5),
     withr,
     yaml
@@ -82,6 +81,7 @@ Collate:
     'include_css_js.R'
     'modules.R'
     'init.R'
+    'module_filter_manager.R'
     'module_nested_tabs.R'
     'module_tabs_with_filters.R'
     'module_teal.R'
@@ -91,6 +91,7 @@ Collate:
     'show_rcode_modal.R'
     'tdata.R'
     'teal.R'
+    'teal_filters.R'
     'utils.R'
     'validate_inputs.R'
     'validations.R'

NAMESPACE

@@ -32,6 +32,7 @@ export(reporter_previewer_module)
 export(show_rcode_modal)
 export(srv_teal_with_splash)
 export(tdata2env)
+export(teal_filters)
 export(ui_teal_with_splash)
 export(validate_has_data)
 export(validate_has_elements)

R/init.R

@@ -30,72 +30,10 @@
 #'   more details.
 #' @param title (`NULL` or `character`)\cr
 #'   The browser window title (defaults to the host URL of the page).
-#' @param filter (`teal_slices` or `list`)\cr
-#'   You can define filters that show when the app starts.
-#'   There are two ways to specify the filter states:
-#'   1) with a `teal_slices` object - see `?teal.slice::teal_slice` for details
-#'   2) with a named list (deprecated)
-#'
-#'   List names should be named according to `datanames` passed to the `data` argument.
-#'   In case of  data.frame` the list should be composed as follows:
-#'   ```
-#'   list(<dataname1> = list(<varname1> = ..., <varname2> = ...),
-#'        <dataname2> = list(...),
-#'        ...)
-#'
-#'   ```
-#'
-#'   For example, filters for variable `Sepal.Length` in `iris` can be specified as
-#'   follows:
-#'   ```
-#'   list(iris = list(Sepal.Length = list(selected = c(5.0, 7.0))))
-#'   # or
-#'   list(iris = list(Sepal.Length = c(5.0, 7.0)))
-#'   ```
-#'
-#'   In case developer would like to include `NA` and `Inf` values in  the
-#'   filtered dataset.
-#'   ```
-#'   list(Species = list(selected = c(5.0, 7.0), keep_na = TRUE, keep_inf = TRUE))
-#'   list(Species = c(c(5.0, 7.0), NA, Inf))
-#'   ```
-#'
-#'   To initialize with specific variable filter with all values on start, one
-#'   can use
-#'   ```
-#'   list(Species = list())
-#'   ```
-#'   `filter` should be set with respect to the class of the column:
-#'   * `numeric`: `selected` should be a two elements vector defining the range
-#'   of the filter.
-#'   * `Date`: `selected` should be a two elements vector defining the date-range
-#'   of the filter
-#'   * `POSIXct`: `selected` should be a two elements vector defining the
-#'   `datetime` range of the filter
-#'   * `character` and `factor`: `selected` should be a vector of any length
-#'   defining initial values selected to filter.
-#'   \cr
-#'   `filter` for `MultiAssayExperiment` objects should be specified in slightly
-#'   different way. Since it contains patient data with list of experiments,
-#'   `filter` list should be created as follows:
-#'   \cr
-#'
-#'   ```
-#'   list(
-#'     <MAE dataname> = list(
-#'       subjects = list(<column in colData> = ..., <column in colData> = ...),
-#'       <experiment name> = list(
-#'         subset = list(<column in rowData of experiment> = ...,
-#'                       <column in rowData of experiment> = ...),
-#'         select = list(<column in colData of experiment> = ...,
-#'                       <column in colData of experiment> = ...)
-#'       )
-#'     )
-#'   )
-#'   ```
-#'  By adding the `filterable` attribute it is possible to control which variables can be filtered for each
-#'  dataset. See the example below where `ADSL` can only be filtered by `AGE`, `SEX` or `RACE`.
-#'
+#' @param filter (`teal_slices`)\cr
+#'   Specification of initial filter. Filters can be specified using [teal::teal_filters()].
+#'   Old way of specifying filters through a list is deprecated and will be removed in the
+#'   next release. Please fix your applications to use [teal::teal_filters()].
 #' @param header (`shiny.tag` or `character`) \cr
 #'   the header of the app. Note shiny code placed here (and in the footer
 #'   argument) will be placed in the app's `ui` function so code which needs to be placed in the `ui` function
@@ -126,12 +64,12 @@
 #'   ),
 #'   modules = modules(
 #'     module(
-#'       "data source",
+#'       label = "data source",
 #'       server = function(input, output, session, data) {},
 #'       ui = function(id, ...) div(p("information about data source")),
 #'       filters = "all"
 #'     ),
-#'     example_module(),
+#'     example_module(label = "example teal module"),
 #'     module(
 #'       "ADSL AGE histogram",
 #'       server = function(input, output, session, data) {
@@ -147,9 +85,16 @@
 #'     )
 #'   ),
 #'   title = "App title",
-#'   filter = teal.slice:::filter_settings(
-#'     teal.slice:::filter_var("ADSL", "AGE"),
-#'     exclude = list(ADSL = setdiff(names(ADSL), c("AGE", "SEX", "RACE")))
+#'   filter = teal::teal_filters(
+#'     teal.slice::filter_var(dataname = "ADSL", varname = "AGE"),
+#'     teal.slice::filter_var(dataname = "ADSL", varname = "SEX"),
+#'     teal.slice::filter_var(dataname = "ADSL", varname = "RACE"),
+#'     exclude_varnames = list(ADSL = setdiff(names(ADSL), c("AGE", "SEX", "RACE"))),
+#'     mapping = list(
+#'       `example teal module` = "ADSL RACE",
+#'       `ADSL AGE histogram` = "ADSL AGE",
+#'       global_filters = "ADSL SEX"
+#'     )
 #'   ),
 #'   header = tags$h1("Sample App"),
 #'   footer = tags$p("Copyright 2017 - 2020")
@@ -161,7 +106,7 @@
 init <- function(data,
                  modules,
                  title = NULL,
-                 filter = list(),
+                 filter = teal_filters(),
                  header = tags$p(),
                  footer = tags$p(),
                  id = character(0)) {
@@ -175,9 +120,6 @@ init <- function(data,
     checkmate::check_class(filter, "teal_slices"),
     checkmate::check_list(filter, names = "named")
   )
-  if (!teal.slice:::is.teal_slices(filter)) {
-    checkmate::assert_subset(names(filter), choices = teal.data::get_dataname(data))
-  }
   checkmate::assert_multi_class(header, c("shiny.tag", "character"))
   checkmate::assert_multi_class(footer, c("shiny.tag", "character"))
   checkmate::assert_character(id, max.len = 1, any.missing = FALSE)
@@ -191,6 +133,75 @@ init <- function(data,
     modules <- do.call(teal::modules, modules)
   }
 
+  # resolve modules datanames
+  datanames <- teal.data::get_dataname(data)
+  join_keys <- data$get_join_keys()
+  resolve_modules_datanames <- function(modules) {
+    if (inherits(modules, "teal_modules")) {
+      modules$children <- sapply(modules$children, resolve_modules_datanames, simplify = FALSE)
+      modules
+    } else {
+      modules$filters <- if (identical(modules$filters, "all")) {
+        datanames
+      } else if (is.character(modules$filters)) {
+        datanames_adjusted <- intersect(modules$filters, datanames)
+        include_parent_datanames(dataname = datanames_adjusted, join_keys = join_keys)
+      }
+      modules
+    }
+  }
+  modules <- resolve_modules_datanames(modules = modules)
+
+  if (!inherits(filter, "teal_slices")) {
+    checkmate::assert_subset(names(filter), choices = datanames)
+    # as.teal_slices is lifted from teal.slice package, see zzz.R
+    # This is a temporary measure and will be removed two release cycles from now (now meaning 0.13.0).
+    filter <- as.teal_slices(filter)
+  }
+
+
+
+  # check teal_slices
+  for (i in seq_along(filter)) {
+    dataname_i <- shiny::isolate(filter[[i]]$dataname)
+    if (!dataname_i %in% datanames) {
+      stop(
+        sprintf(
+          "filter[[%s]] has a different dataname than available in a 'data':\n %s not in %s",
+          i,
+          dataname_i,
+          toString(datanames)
+        )
+      )
+    }
+  }
+
+  if (isTRUE(attr(filter, "module_specific"))) {
+    module_names <- unlist(c(module_labels(modules), "global_filters"))
+    failed_mod_names <- setdiff(names(attr(filter, "mapping")), module_names)
+    if (length(failed_mod_names)) {
+      stop(
+        sprintf(
+          "Some module names in the mapping arguments don't match module labels.\n %s not in %s",
+          toString(failed_mod_names),
+          toString(unique(module_names))
+        )
+      )
+    }
+
+    if (anyDuplicated(module_names)) {
+      # In teal we are able to set nested modules with duplicated label.
+      # Because mapping argument bases on the relationship between module-label and filter-id,
+      # it is possible that module-label in mapping might refer to multiple teal_module (identified by the same label)
+      stop(
+        sprintf(
+          "Module labels should be unique when teal_filters(mapping = TRUE). Duplicated labels:\n%s ",
+          toString(module_names[duplicated(module_names)])
+        )
+      )
+    }
+  }
+
   # Note regarding case `id = character(0)`:
   # rather than using `callModule` and creating a submodule of this module, we directly modify
   # the `ui` and `server` with `id = character(0)` and calling the server function directly
@@ -200,6 +211,7 @@ init <- function(data,
     server = function(input, output, session) {
       # copy object so that load won't be shared between the session
       data <- data$copy(deep = TRUE)
+      filter <- deep_copy_filter(filter)
       srv_teal_with_splash(id = id, data = data, modules = modules, filter = filter)
     }
   )