928 upload snapshot file (#929)

Closes #928 

Added possibility to upload a snapshot file to the snapshot manager
module.
The snapshot manager control bar (top row in table) receives a third
button. Clicking it opens a modal dialog that allows for selecting a
`.json` file to upload and naming the snapshot.
The new snapshot is added to the snapshot list and the filter manager
dialog is reopened so that the user may immediately apply the new
snapshot.

To ensure that the uploaded snapshot matches the app, `teal_slices`
class receives the `app_id` attribute, which can be set with the
`app_id` argument to `teal::teal_slices`. The attribute will be set by
`init` to stamp a `teal_slices`. The attribute will be stored along with
other attributes. Upon uploading a snapshot, the app id of the upload
will be compared to that of the app.

`slices_restore` had to be re-defined in the `teal` namespace because it
calls `teal_slices` and that must be the one from `teal`.


#### TESTING
```
options(teal.log_level = "WARN", teal.show_js_log = FALSE)

library(teal.modules.general)
pkgload::load_all("../teal.slice")
pkgload::load_all("../teal")

rm(list = ls())

funny_module <- function (label = "Filter states", datanames = "all") {
  checkmate::assert_string(label)
  module(
    label = label,
    datanames = datanames,
    ui = function(id, ...) {
      ns <- NS(id)
      div(
        h2("The following filter calls are generated:"),
        verbatimTextOutput(ns("filter_states")),
        verbatimTextOutput(ns("filter_calls")),
        actionButton(ns("reset"), "reset_to_default")
      )
    },
    server = function(input, output, session, data, filter_panel_api) {
      checkmate::assert_class(data, "tdata")
      observeEvent(input$reset, set_filter_state(filter_panel_api, default_filters))
      output$filter_states <-  renderPrint({
        logger::log_trace("rendering text1")
        filter_panel_api %>% get_filter_state()
      })
      output$filter_calls <- renderText({
        logger::log_trace("rendering text2")
        attr(data, "code")()
      })
    }
  )
}

dead_module <- function(label = "empty module", datanames = NULL) {
  module(label = label,
         datanames = datanames,
         ui = function(id) {
           ns <- NS(id)
           tagList(
             h4("this is just text")
           )
         },
         server = function(id, filter_panel_api, reporter) {
           message("hello")
         }
  )
}

default_filters <- teal::teal_slices(
  teal_slice("iris", "Sepal.Length"),
  teal_slice("iris", "Sepal.Width"),
  teal_slice("iris", "Species", fixed = TRUE),
  teal_slice("mtcars", "mpg"),
  exclude_varnames = list(
    iris = c("Petal.Length"),
    mtcars = c("qsec", "drat")
  ),
  module_specific = TRUE,
  mapping = list(
    table = "iris Species",
    funny1 = c("iris Sepal.Length", "iris Sepal.Width", "iris Species"),
    funny2 = "iris Species",
    global_filters = "mtcars mpg"
  )
)

app <- init(
  data = teal_data(
    dataset("iris", iris),
    dataset("mtcars", mtcars)
  ),
  modules = modules(
    tm_data_table(
      "table",
      variables_selected = list(),
      dt_args = list()
    ),
    modules(
      label = "tab1",
      funny_module("funny1", datanames = NULL),
      funny_module("funny2", datanames = "iris"),
      dead_module("empty", datanames = NULL)
    )
  ),
  filter = default_filters
)

shinyApp(app$ui, app$server, options = list(launch.browser = TRUE))
```

---------

Signed-off-by: Aleksander Chlebowski <[email protected]>
Co-authored-by: github-actions <41898282+github-actions[bot]@users.noreply.github.com>

.lintr

@@ -1,5 +1,6 @@
 linters: linters_with_defaults(
   line_length_linter = line_length_linter(120),
   cyclocomp_linter = NULL,
-  object_usage_linter = NULL
+  object_usage_linter = NULL,
+  indentation_linter = NULL
   )

NEWS.md

@@ -5,6 +5,8 @@
 * Enhanced a `module` validation checks so that it won't throw messages about `data` argument unnecessarily.
 * Removed `Report previewer` module from mapping matrix display in filter manager.
 * Added internal functions for storing and restoring of `teal_slices` objects.
+* Filter state snapshots can now be uploaded from file. See `?snapshot`.
+* Added argument to `teal_slices` and made modifications to `init` to enable tagging `teal_slices` with an app id to safely upload snapshots from disk.
 
 # teal 0.14.0
 

R/init.R

@@ -164,6 +164,17 @@ init <- function(data,
   # convert teal.slice::teal_slices to teal::teal_slices
   filter <- as.teal_slices(as.list(filter))
 
+  # Calculate app hash to ensure snapshot compatibility. See ?snapshot. Raw data must be extracted from environments.
+  hashables <- mget(c("data", "modules"))
+  hashables$data <- sapply(hashables$data$get_datanames(), function(dn) {
+    if (hashables$data$is_pulled()) {
+      hashables$data$get_dataset(dn)$get_raw_data()
+    } else {
+      hashables$data$get_code(dn)
+    }
+  }, simplify = FALSE)
+  attr(filter, "app_id") <- rlang::hash(hashables)
+
   # check teal_slices
   for (i in seq_along(filter)) {
     dataname_i <- shiny::isolate(filter[[i]]$dataname)

R/module_filter_manager.R

@@ -137,7 +137,7 @@ filter_manager_srv <- function(id, filtered_data_list, filter) {
       }
 
     # Create mapping fo filters to modules in matrix form (presented as data.frame).
-    # Modules get NAs for filteres that cannot be set for them.
+    # Modules get NAs for filters that cannot be set for them.
     mapping_matrix <- reactive({
       state_ids_global <- vapply(slices_global(), `[[`, character(1L), "id")
       mapping_smooth <- lapply(filtered_data_list, function(x) {

R/module_snapshot_manager.R

@@ -4,11 +4,13 @@
 #'
 #' This module introduces snapshots: stored descriptions of the filter state of the entire application.
 #' Snapshots allow the user to save the current filter state of the application for later use in the session,
-#' as well as to save it to file in order to share it with an app developer or other users.
+#' as well as to save it to file in order to share it with an app developer or other users,
+#' who in turn can upload it to their own session.
 #'
 #' The snapshot manager is accessed through the filter manager, with the cog icon in the top right corner.
-#' At the beginning of a session it presents two icons: a camera and an circular arrow.
-#' Clicking the camera captures a snapshot and clicking the arrow resets initial application state.
+#' At the beginning of a session it presents three icons: a camera, an upload, and an circular arrow.
+#' Clicking the camera captures a snapshot, clicking the upload adds a snapshot from a file
+#' and applies the filter states therein, and clicking the arrow resets initial application state.
 #' As snapshots are added, they will show up as rows in a table and each will have a select button and a save button.
 #'
 #' @section Server logic:
@@ -49,6 +51,19 @@
 #' To save a snapshot, the snapshot is retrieved and reassembled just like for restoring,
 #' and then saved to file with [`slices_store`].
 #'
+#' When a snapshot is uploaded, it will first be added to storage just like a newly created one,
+#' and then used to restore app state much like a snapshot taken from storage.
+#' Upon clicking the upload icon the user will be prompted for a file to upload
+#' and may choose to name the new snapshot. The name defaults to the name of the file (the extension is dropped)
+#' and normal naming rules apply. Loading the file yields a `teal_slices` object,
+#' which is disassembled for storage and used directly for restoring app state.
+#'
+#' @section Transferring snapshots:
+#' Snapshots uploaded from disk should only be used in the same application they come from.
+#' To ensure this is the case, `init` stamps `teal_slices` with an app id that is stored in the `app_id` attribute of
+#' a `teal_slices` object. When a snapshot is restored from file, its `app_id` is compared to that
+#' of the current app state and only if the match is the snapshot admitted to the session.
+#'
 #' @param id (`character(1)`) `shiny` module id
 #' @param slices_global (`reactiveVal`) that contains a `teal_slices` object
 #'                      containing all `teal_slice`s existing in the app, both active and inactive
@@ -75,6 +90,7 @@ snapshot_manager_ui <- function(id) {
       class = "snapshot_table_row",
       span(tags$b("Snapshot manager")),
       actionLink(ns("snapshot_add"), label = NULL, icon = icon("camera"), title = "add snapshot"),
+      actionLink(ns("snapshot_load"), label = NULL, icon = icon("upload"), title = "upload snapshot"),
       actionLink(ns("snapshot_reset"), label = NULL, icon = icon("undo"), title = "reset initial state"),
       NULL
     ),
@@ -96,15 +112,16 @@ snapshot_manager_srv <- function(id, slices_global, mapping_matrix, filtered_dat
   moduleServer(id, function(input, output, session) {
     ns <- session$ns
 
-    # Store global filter states.
+    # Store global filter states ----
     filter <- isolate(slices_global())
     snapshot_history <- reactiveVal({
       list(
         "Initial application state" = as.list(filter, recursive = TRUE)
       )
     })
 
-    # Snapshot current application state - name snaphsot.
+    # Snapshot current application state ----
+    # Name snaphsot.
     observeEvent(input$snapshot_add, {
       showModal(
         modalDialog(
@@ -117,7 +134,7 @@ snapshot_manager_srv <- function(id, slices_global, mapping_matrix, filtered_dat
         )
       )
     })
-    # Snapshot current application state - store snaphsot.
+    # Store snaphsot.
     observeEvent(input$snapshot_name_accept, {
       snapshot_name <- trimws(input$snapshot_name)
       if (identical(snapshot_name, "")) {
@@ -131,7 +148,7 @@ snapshot_manager_srv <- function(id, slices_global, mapping_matrix, filtered_dat
           "This name is in conflict with other snapshot names. Please choose a different one.",
           type = "message"
         )
-        updateTextInput(inputId = "snapshot_name", value = , placeholder = "Meaningful, unique name")
+        updateTextInput(inputId = "snapshot_name", value = "", placeholder = "Meaningful, unique name")
       } else {
         snapshot <- as.list(slices_global(), recursive = TRUE)
         attr(snapshot, "mapping") <- matrix_to_mapping(mapping_matrix())
@@ -144,7 +161,76 @@ snapshot_manager_srv <- function(id, slices_global, mapping_matrix, filtered_dat
       }
     })
 
-    # Restore initial state.
+    # Upload a snapshot file ----
+    # Select file.
+    observeEvent(input$snapshot_load, {
+      showModal(
+        modalDialog(
+          fileInput(ns("snapshot_file"), "Choose snapshot file", accept = ".json", width = "100%"),
+          textInput(
+            ns("snapshot_name"),
+            "Name the snapshot (optional)",
+            width = "100%",
+            placeholder = "Meaningful, unique name"
+          ),
+          footer = tagList(
+            actionButton(ns("snaphot_file_accept"), "Accept", icon = icon("thumbs-up")),
+            modalButton(label = "Cancel", icon = icon("thumbs-down"))
+          )
+        )
+      )
+    })
+    # Store new snapshot to list and restore filter states.
+    observeEvent(input$snaphot_file_accept, {
+      snapshot_name <- trimws(input$snapshot_name)
+      if (identical(snapshot_name, "")) {
+        snapshot_name <- tools::file_path_sans_ext(input$snapshot_file$name)
+      }
+      if (is.element(make.names(snapshot_name), make.names(names(snapshot_history())))) {
+        showNotification(
+          "This name is in conflict with other snapshot names. Please choose a different one.",
+          type = "message"
+        )
+        updateTextInput(inputId = "snapshot_name", value = "", placeholder = "Meaningful, unique name")
+      } else {
+        # Restore snapshot and verify app compatibility.
+        snapshot_state <- try(slices_restore(input$snapshot_file$datapath))
+        if (!inherits(snapshot_state, "modules_teal_slices")) {
+          showNotification(
+            "File appears to be corrupt.",
+            type = "error"
+          )
+        } else if (!identical(attr(snapshot_state, "app_id"), attr(slices_global(), "app_id"))) {
+          showNotification(
+            "This snapshot file is not compatible with the app and cannot be loaded.",
+            type = "warning"
+          )
+        } else {
+          # Add to snapshot history.
+          snapshot <- as.list(snapshot_state, recursive = TRUE)
+          snapshot_update <- c(snapshot_history(), list(snapshot))
+          names(snapshot_update)[length(snapshot_update)] <- snapshot_name
+          snapshot_history(snapshot_update)
+          ### Begin simplified restore procedure. ###
+          mapping_unfolded <- unfold_mapping(attr(snapshot_state, "mapping"), names(filtered_data_list))
+          mapply(
+            function(filtered_data, filter_ids) {
+              filtered_data$clear_filter_states(force = TRUE)
+              slices <- Filter(function(x) x$id %in% filter_ids, snapshot_state)
+              filtered_data$set_filter_state(slices)
+            },
+            filtered_data = filtered_data_list,
+            filter_ids = mapping_unfolded
+          )
+          slices_global(snapshot_state)
+          removeModal()
+          ### End  simplified restore procedure. ###
+        }
+      }
+    })
+    # Apply newly added snapshot.
+
+    # Restore initial state ----
     observeEvent(input$snapshot_reset, {
       s <- "Initial application state"
       ### Begin restore procedure. ###
@@ -165,6 +251,7 @@ snapshot_manager_srv <- function(id, slices_global, mapping_matrix, filtered_dat
       ### End restore procedure. ###
     })
 
+    # Build snapshot table ----
     # Create UI elements and server logic for the snapshot table.
     # Observers must be tracked to avoid duplication and excess reactivity.
     # Remaining elements are tracked likewise for consistency and a slight speed margin.

R/teal_slices.R

@@ -18,6 +18,10 @@
 #'  If missing, all filters will be applied to all modules.
 #'  If empty list, all filters will be available to all modules but will start inactive.
 #'  If `module_specific` is `FALSE`, only `global_filters` will be active on start.
+#' @param app_id (`character(1)`)\cr
+#'  For internal use only, do not set manually.
+#'  Added by `init` so that a `teal_slices` can be matched to the app in which it was used.
+#'  Used for verifying snapshots uploaded from file. See `snapshot`.
 #'
 #' @param x (`list`) of lists to convert to `teal_slices`
 #'
@@ -56,11 +60,13 @@ teal_slices <- function(...,
                         count_type = NULL,
                         allow_add = TRUE,
                         module_specific = FALSE,
-                        mapping) {
+                        mapping,
+                        app_id = NULL) {
   shiny::isolate({
     checkmate::assert_flag(allow_add)
     checkmate::assert_flag(module_specific)
     if (!missing(mapping)) checkmate::assert_list(mapping, types = c("character", "NULL"), names = "named")
+    checkmate::assert_string(app_id, null.ok = TRUE)
 
     slices <- list(...)
     all_slice_id <- vapply(slices, `[[`, character(1L), "id")
@@ -90,6 +96,7 @@ teal_slices <- function(...,
     )
     attr(tss, "mapping") <- mapping
     attr(tss, "module_specific") <- module_specific
+    attr(tss, "app_id") <- app_id
     class(tss) <- c("modules_teal_slices", class(tss))
     tss
   })