Merge pull request rstudio#1760 from rstudio/wch-snapshot-preprocess

Add snapshotPreprocess function

Author: wch

DESCRIPTION

@@ -1,7 +1,7 @@
 Package: shiny
 Type: Package
 Title: Web Application Framework for R
-Version: 1.0.3.9000
+Version: 1.0.3.9001
 Authors@R: c(
     person("Winston", "Chang", role = c("aut", "cre"), email = "[email protected]"),
     person("Joe", "Cheng", role = "aut", email = "[email protected]"),
@@ -84,7 +84,7 @@ Suggests:
     magrittr
 URL: http://shiny.rstudio.com
 BugReports: https://github.com/rstudio/shiny/issues
-Collate:
+Collate: 
     'app.R'
     'bookmark-state-local.R'
     'stack.R'
@@ -144,6 +144,7 @@ Collate:
     'shinyui.R'
     'shinywrappers.R'
     'showcase.R'
+    'snapshot.R'
     'tar.R'
     'test-export.R'
     'timer.R'

NAMESPACE

@@ -218,6 +218,7 @@ export(sidebarPanel)
 export(singleton)
 export(sliderInput)
 export(snapshotExclude)
+export(snapshotPreprocess)
 export(span)
 export(splitLayout)
 export(stopApp)

NEWS.md

@@ -1,4 +1,4 @@
-shiny 1.0.3.9000
+shiny 1.0.3.9001
 ================
 
 ## Full changelog
@@ -21,6 +21,8 @@ shiny 1.0.3.9000
 
 * Addressed [#1738](https://github.com/rstudio/shiny/issues/1738): The `updateTextInput` and `updateTextAreaInput` functions can now update the placeholder. ([#1742](https://github.com/rstudio/shiny/pull/1742))
 
+* Added new `snapshotPreprocess()` function, which is used for preprocessing output values before taking a test snapshot. ([#1760](https://github.com/rstudio/shiny/pull/1760))
+
 ### Bug fixes
 
 * Fixed [#1546](https://github.com/rstudio/shiny/issues/1546): make it possible (without any hacks) to write arbitrary data into a module's `session$userData` (which is exactly the same environment as the parent's `session$userData`). To be clear, it allows something like `session$userData$x <- TRUE`, but not something like `session$userData <- TRUE` (that is not allowed in any context, whether you're in the main app, or in a module) ([#1732](https://github.com/rstudio/shiny/pull/1732)).

R/shiny.R

@@ -658,6 +658,19 @@ ShinySession <- R6Class(
             }, logical(1))
             values$output <- values$output[!exclude_idx]
 
+            # Apply snapshotPreprocess functions for outputs that have them.
+            values$output <- lapply(
+              setNames(names(values$output), names(values$output)),
+              function(name) {
+                preprocess <- attr(private$.outputs[[name]], "snapshotPreprocess", TRUE)
+                if (is.function(preprocess)) {
+                  preprocess(values$output[[name]])
+                } else {
+                   values$output[[name]]
+                }
+              }
+            )
+
             values$output <- sortByName(values$output)
           }
 
@@ -1889,17 +1902,6 @@ outputOptions <- function(x, name, ...) {
   .subset2(x, 'impl')$outputOptions(name, ...)
 }
 
-
-#' Mark an output to be excluded from test snapshots
-#'
-#' @param x A reactive which will be assigned to an output.
-#'
-#' @export
-snapshotExclude <- function(x) {
-  markOutputAttrs(x, snapshotExclude = TRUE)
-}
-
-
 #' Add callbacks for Shiny session events
 #'
 #' These functions are for registering callbacks on Shiny session events.

R/shinywrappers.R

@@ -93,9 +93,13 @@ as.tags.shiny.render.function <- function(x, ..., inline = FALSE) {
 #'
 #' @inheritParams markRenderFunction
 #' @param snapshotExclude If TRUE, exclude the output from test snapshots.
+#' @param snapshotPreprocess A function for preprocessing the value before
+#'   taking a test snapshot.
 #'
 #' @keywords internal
-markOutputAttrs <- function(renderFunc, snapshotExclude = NULL) {
+markOutputAttrs <- function(renderFunc, snapshotExclude = NULL,
+  snapshotPreprocess = NULL)
+{
   # Add the outputAttrs attribute if necessary
   if (is.null(attr(renderFunc, "outputAttrs", TRUE))) {
     attr(renderFunc, "outputAttrs") <- list()
@@ -105,6 +109,10 @@ markOutputAttrs <- function(renderFunc, snapshotExclude = NULL) {
     attr(renderFunc, "outputAttrs")$snapshotExclude <- snapshotExclude
   }
 
+  if (!is.null(snapshotPreprocess)) {
+    attr(renderFunc, "outputAttrs")$snapshotPreprocess <- snapshotPreprocess
+  }
+
   renderFunc
 }
 
@@ -533,7 +541,18 @@ renderDataTable <- function(expr, options = NULL, searchDelay = 500,
     )
   }
 
-  markRenderFunction(dataTableOutput, renderFunc, outputArgs = outputArgs)
+  renderFunc <- markRenderFunction(dataTableOutput, renderFunc, outputArgs = outputArgs)
+
+  renderFunc <- snapshotPreprocess(renderFunc, function(value) {
+    # Remove the action field so that it's not saved in test snapshots. It
+    # contains a value that changes every time an app is run, and shouldn't be
+    # stored for test snapshots. It will be something like:
+    # "session/e0d14d3fe97f672f9655a127f2a1e079/dataobj/table?w=&nonce=7f5d6d54e22450a3"
+    value$action <- NULL
+    value
+  })
+
+  renderFunc
 }
 
 # a data frame containing the DataTables 1.9 and 1.10 names

R/snapshot.R

@@ -0,0 +1,20 @@
+#' Mark an output to be excluded from test snapshots
+#'
+#' @param x A reactive which will be assigned to an output.
+#'
+#' @export
+snapshotExclude <- function(x) {
+  markOutputAttrs(x, snapshotExclude = TRUE)
+}
+
+#' Add a function for preprocessing an output before taking a test snapshot
+#'
+#' @param x A reactive which will be assigned to an output.
+#' @param fun A function that takes the output value as an input and returns a
+#'   modified value. The returned value will be used for the test snapshot.
+#'
+#' @export
+snapshotPreprocess <- function(x, fun) {
+  markOutputAttrs(x, snapshotPreprocess = fun)
+}
+

inst/staticdocs/index.r

@@ -194,6 +194,7 @@ sd_section("Utility functions",
     "plotPNG",
     "exportTestValues",
     "snapshotExclude",
+    "snapshotPreprocess",
     "markOutputAttrs",
     "repeatable",
     "shinyDeprecated",