298 reset button

DESCRIPTION

@@ -83,6 +83,7 @@ Collate:
     'init.R'
     'module_filter_manager.R'
     'module_nested_tabs.R'
+    'module_snapshot_manager.R'
     'module_tabs_with_filters.R'
     'module_teal.R'
     'module_teal_with_splash.R'

NEWS.md

@@ -3,6 +3,7 @@
 ### New features
 
 * Enabled module specific filter panel. See `module_specific` in `teal::teal_slices` documentation.
+* Enabled capturing and resetting application filter state with snapshots. See `?snapshot`.
 * Enabled `reporter_previewer_module` to customize default values through `srv_args`.
 * Enabled passing own `reporter_previewer_module` in a list of modules to override default one.
 

R/module_filter_manager.R

@@ -1,6 +1,7 @@
 #' Filter manager modal
 #'
-#' Filter manager modal
+#' Opens modal containing the filter manager UI.
+#'
 #' @name module_filter_manager_modal
 #' @inheritParams filter_manager_srv
 #' @examples
@@ -38,6 +39,7 @@
 #' if (interactive()) {
 #'   runApp(app)
 #' }
+#'
 #' @keywords internal
 #'
 NULL
@@ -62,6 +64,7 @@ filter_manager_modal_srv <- function(id, filtered_data_list, filter) {
         modalDialog(
           filter_manager_ui(session$ns("filter_manager")),
           size = "l",
+          footer = NULL,
           easyClose = TRUE
         )
       )
@@ -75,145 +78,153 @@ filter_manager_modal_srv <- function(id, filtered_data_list, filter) {
 filter_manager_ui <- function(id) {
   ns <- NS(id)
   div(
-    tableOutput(ns("slices_table"))
+    class = "filter_manager_content",
+    tableOutput(ns("slices_table")),
+    snapshot_manager_ui(ns("snapshot_manager"))
   )
 }
 
 #' Manage multiple `FilteredData` objects
 #'
-#' Manage multiple `FilteredData` objects
+#' Oversee filter states in the whole application.
 #'
 #' @rdname module_filter_manager
 #' @details
 #' This module observes the changes of the filters in each `FilteredData` object
-#' and keeps track of all filters used. Map of the filters is kept in so called
-#' `slices_map` object where each `FilteredData` is linked with its active filters.
-#' This map is represented in the UI as a matrix where rows are ids of the filters and
-#' columns are names of the `filtered_data_list` (named after teal modules).
+#' and keeps track of all filters used. A mapping of filters to modules
+#' is kept in the `mapping_matrix` object (which is actually a `data.frame`)
+#' that tracks which filters (rows) are active in which modules (columns).
 #'
 #' @param id (`character(1)`)\cr
 #'  `shiny` module id.
-#' @param filtered_data_list (`list` of `FilteredData`)\cr
-#'  Names of the list should be the same as `teal_module$label`.
+#' @param filtered_data_list (`named list`)\cr
+#'  A list, possibly nested, of `FilteredData` objects.
+#'  Each `FilteredData` will be served to one module in the `teal` application.
+#'  The structure of the list must reflect the nesting of modules in tabs
+#'  and names of the list must be the same as labels of their respective modules.
 #' @inheritParams init
+#' @return A list of `reactive`s, each holding a `teal_slices`, as returned by `filter_manager_module_srv`.
 #' @keywords internal
+#'
 filter_manager_srv <- function(id, filtered_data_list, filter) {
   moduleServer(id, function(input, output, session) {
     logger::log_trace("filter_manager_srv initializing for: { paste(names(filtered_data_list), collapse = ', ')}.")
 
-    # instead of unlist which unlist with concatenating nested names with '.'
-    flatten_nested <- function(x, name = NULL) {
-      if (inherits(x, "FilteredData")) {
-        setNames(list(x), name)
-      } else {
-        unlist(lapply(names(x), function(name) flatten_nested(x[[name]], name)))
-      }
-    }
-    filtered_data_list <- flatten_nested(filtered_data_list)
+    is_module_specific <- isTRUE(attr(filter, "module_specific"))
 
-    # global list of slices (all available teal_slice)
+    # Create global list of slices.
+    # Contains all available teal_slice objects available to all modules.
+    # Passed whole to instances of FilteredData used for individual modules.
+    # Down there a subset that pertains to the data sets used in that module is applied and displayed.
     slices_global <- reactiveVal(filter)
 
-    # create a reactive map between modules and filters
-    slices_map <- sapply(
-      names(filtered_data_list),
-      function(module_name) {
-        shiny::reactiveVal(
-          unlist(attr(filter, "mapping")[c(module_name, "global_filters")], use.names = FALSE)
-        )
+    filtered_data_list <-
+      if (!is_module_specific) {
+        # Retrieve the first FilteredData from potentially nested list.
+        # List of length one is named "global_filters" because that name is forbidden for a module label.
+        list(global_filters = filtered_data_list[[1]])
+      } else {
+        # Flatten potentially nested list of FilteredData objects while maintaining useful names.
+        # Simply using `unlist` would result in concatenated names.
+        flatten_nested <- function(x, name = NULL) {
+          if (inherits(x, "FilteredData")) {
+            setNames(list(x), name)
+          } else {
+            unlist(lapply(names(x), function(name) flatten_nested(x[[name]], name)))
+          }
+        }
+        flatten_nested(filtered_data_list)
       }
+
+    # Create mapping fo filters to modules in matrix form (presented as data.frame).
+    mapping_matrix <- reactive({
+      module_states <- lapply(filtered_data_list, function(x) x$get_filter_state())
+      mapping_ragged <- lapply(module_states, function(x) vapply(x, `[[`, character(1L), "id"))
+      all_names <- vapply(slices_global(), `[[`, character(1L), "id")
+      mapping_smooth <- lapply(mapping_ragged, is.element, el = all_names)
+      as.data.frame(mapping_smooth, row.names = all_names, check.names = FALSE)
+    })
+
+    output$slices_table <- renderTable(
+      expr = {
+        # Display logical values as UTF characters.
+        mm <- mapping_matrix()
+        mm[] <- lapply(mm, ifelse, yes = intToUtf8(9989), no = intToUtf8(10060))
+        if (!is_module_specific) colnames(mm) <- "Global Filters"
+        mm
+      },
+      align = paste(c("l", rep("c", ncol(mapping_matrix()))), collapse = ""),
+      rownames = TRUE
     )
 
+    # Create list of module calls.
     modules_out <- lapply(names(filtered_data_list), function(module_name) {
       filter_manager_module_srv(
         id = module_name,
         module_fd = filtered_data_list[[module_name]],
-        slices_map_module = slices_map[[module_name]],
         slices_global = slices_global
       )
     })
 
-    mapping_matrix <- reactive({
-      module_names <- names(filtered_data_list)
-      filter_names <- vapply(X = slices_global(), `[[`, character(1), "id")
-      mapping_matrix <- matrix(
-        FALSE,
-        nrow = length(filter_names),
-        ncol = length(module_names),
-        dimnames = list(filter_names, module_names)
-      )
-      for (i in module_names) {
-        mapping_matrix[slices_map[[i]](), i] <- TRUE
-      }
-      mapping_matrix
-    })
-
-    output$slices_table <- renderTable(rownames = TRUE, {
-      as.data.frame(mapping_matrix())
-    })
+    # Call snapshot manager.
+    snapshot_manager_srv("snapshot_manager", slices_global, mapping_matrix, filtered_data_list)
 
     modules_out # returned for testing purpose
   })
 }
 
 #' Module specific filter manager
 #'
-#' This module compares filters between single `FilteredData` settings
-#' and global `teal_slices`. Updates appropriate objects `module_fd`,
-#' `slices_map_module`, `slices_global` to keep them consistent.
+#' Track filter states in single module.
+#'
+#' This module tracks the state of a single `FilteredData` object and global `teal_slices`
+#' and updates both objects as necessary. Filter states added in different modules
+#' Filter states added any individual module are added to global `teal_slices`
+#' and from there become available in other modules
+#' by setting `private$available_teal_slices` in each `FilteredData`.
 #'
 #' @param id (`character(1)`)\cr
 #'  `shiny` module id.
 #' @param module_fd (`FilteredData`)\cr
 #'   object to filter data in the teal-module
-#' @param slices_map_module (`reactiveVal` of `character`)\cr
-#'   `id` of the `teal_slice` objects used in the module specific `FilteredData`.
-#' @param slices_global (`reactiveVal` or `teal_slices`)\cr
-#'   stores a list of all available filters which can be utilized in several ways, for example:
-#'   - to disable/enable specific filter in the module
-#'   - to restore filter saved settings
-#'   - to save current filter settings panel
-#' @return shiny module returning NULL
+#' @param slices_global (`reactiveVal`)\cr
+#'   stores `teal_slices` with all available filters; allows the following actions:
+#'   - to disable/enable a specific filter in a module
+#'   - to restore saved filter settings
+#'   - to save current filter panel settings
+#' @return A `reactive` expression containing the slices active in this module.
 #' @keywords internal
-filter_manager_module_srv <- function(id, module_fd, slices_map_module, slices_global) {
+#'
+filter_manager_module_srv <- function(id, module_fd, slices_global) {
   moduleServer(id, function(input, output, session) {
-    setdiff_teal_slices <- function(x, y) {
-      Filter(
-        function(xx) {
-          !any(vapply(y, function(yy) identical(yy, xx), logical(1)))
-        },
-        x
-      )
-    }
-
-    available_slices <- reactive(
+    # Only operate on slices that refer to data sets present in this module.
+    available_slices <- reactive({
       Filter(function(slice) slice$dataname %in% module_fd$datanames(), slices_global())
-    )
+    })
     module_fd$set_available_teal_slices(available_slices)
+
+    # Track filter state of this module.
     slices_module <- reactive(module_fd$get_filter_state())
 
-    previous_slices <- reactiveVal(shiny::isolate(slices_module()))
+    # Reactive values for comparing states.
+    previous_slices <- reactiveVal(isolate(slices_module()))
     slices_added <- reactiveVal(NULL)
-    slices_activated <- reactiveVal(NULL)
-    slices_deactivated <- reactiveVal(NULL)
 
-    observeEvent(slices_module(), {
+    # Observe changes in module filter state and trigger appropriate actions.
+    observeEvent(slices_module(), ignoreNULL = FALSE, {
       logger::log_trace("filter_manager_srv@1 detecting states deltas in module: { id }.")
       added <- setdiff_teal_slices(slices_module(), slices_global())
-      activated <- setdiff_teal_slices(slices_module(), previous_slices())
-      deactivated <- setdiff_teal_slices(previous_slices(), slices_module())
       if (length(added)) slices_added(added)
-      if (length(activated)) slices_activated(activated)
-      if (length(deactivated)) slices_deactivated(deactivated)
       previous_slices(slices_module())
     })
 
     observeEvent(slices_added(), ignoreNULL = TRUE, {
       logger::log_trace("filter_manager_srv@2 added filter in module: { id }.")
+      # In case the new state has the same id as an existing state, add a suffix to it.
+      global_ids <- vapply(slices_global(), `[[`, character(1L), "id")
       lapply(
         slices_added(),
         function(slice) {
-          global_ids <- vapply(slices_global(), function(x) x$id, character(1))
           if (slice$id %in% global_ids) {
             slice$id <- utils::tail(make.unique(c(global_ids, slice$id), sep = "_"), 1)
           }
@@ -224,20 +235,6 @@ filter_manager_module_srv <- function(id, module_fd, slices_map_module, slices_g
       slices_added(NULL)
     })
 
-    observeEvent(slices_activated(), ignoreNULL = TRUE, {
-      logger::log_trace("filter_manager_srv@3 activated filter in module: { id }.")
-      activated_ids <- vapply(slices_activated(), `[[`, character(1), "id")
-      slices_map_module(c(slices_map_module(), activated_ids))
-      slices_activated(NULL)
-    })
-
-    observeEvent(slices_deactivated(), ignoreNULL = TRUE, {
-      logger::log_trace("filter_manager_srv@4 deactivated filter in module: { id }.")
-      deactivated_ids <- vapply(slices_deactivated(), `[[`, character(1), "id")
-      slices_map_module(setdiff(slices_map_module(), deactivated_ids))
-      slices_deactivated(NULL)
-    })
-
     slices_module # returned for testing purpose
   })
 }

R/module_nested_tabs.R

@@ -13,8 +13,8 @@
 #' @param depth (`integer(1)`)\cr
 #'  number which helps to determine depth of the modules nesting.
 #' @param is_module_specific (`logical(1)`)\cr
-#'  flag determining if the filter panel is global or module-specific. When `module_specific`
-#'  is `TRUE` then a filter panel is called inside of each module tab.
+#'  flag determining if the filter panel is global or module-specific.
+#'  When set to `TRUE`, a filter panel is called inside of each module tab.
 #' @return depending on class of `modules`:
 #'   - `teal_module`: instantiated UI of the module
 #'   - `teal_modules`: `tabsetPanel` with each tab corresponding to recursively