Build out clientData.

Makes testing more sensible instead of having to pad by 1 every time.

DESCRIPTION

@@ -141,6 +141,8 @@ Collate:
     'jqueryui.R'
     'middleware-shiny.R'
     'middleware.R'
+    'timer.R'
+    'mock-session.R'
     'modal.R'
     'modules.R'
     'notifications.R'
@@ -162,7 +164,7 @@ Collate:
     'snapshot.R'
     'tar.R'
     'test-export.R'
-    'timer.R'
+    'test-module.R'
     'update-input.R'
 RoxygenNote: 6.1.1
 Encoding: UTF-8

NAMESPACE

@@ -1,15 +1,18 @@
 # Generated by roxygen2: do not edit by hand
 
+S3method("$",mockclientdata)
 S3method("$",reactivevalues)
 S3method("$",session_proxy)
 S3method("$",shinyoutput)
 S3method("$<-",reactivevalues)
 S3method("$<-",session_proxy)
 S3method("$<-",shinyoutput)
+S3method("[",mockclientdata)
 S3method("[",reactivevalues)
 S3method("[",shinyoutput)
 S3method("[<-",reactivevalues)
 S3method("[<-",shinyoutput)
+S3method("[[",mockclientdata)
 S3method("[[",reactivevalues)
 S3method("[[",session_proxy)
 S3method("[[",shinyoutput)
@@ -257,6 +260,8 @@ export(tagHasAttribute)
 export(tagList)
 export(tagSetChildren)
 export(tags)
+export(testModule)
+export(testServer)
 export(textAreaInput)
 export(textInput)
 export(textOutput)
@@ -306,3 +311,5 @@ importFrom(fastmap,is.key_missing)
 importFrom(fastmap,key_missing)
 importFrom(grDevices,dev.cur)
 importFrom(grDevices,dev.set)
+importFrom(promises,"%...!%")
+importFrom(promises,"%...>%")

R/conditions.R

@@ -133,7 +133,7 @@ captureStackTraces <- function(expr) {
 createStackTracePromiseDomain <- function() {
   # These are actually stateless, we wouldn't have to create a new one each time
   # if we didn't want to. They're pretty cheap though.
-  
+
   d <- promises::new_promise_domain(
     wrapOnFulfilled = function(onFulfilled) {
       force(onFulfilled)
@@ -266,10 +266,10 @@ withLogErrors <- function(expr,
 printError <- function(cond,
   full = getOption("shiny.fullstacktrace", FALSE),
   offset = getOption("shiny.stacktraceoffset", TRUE)) {
-  
-  warning(call. = FALSE, immediate. = TRUE, sprintf("Error in %s: %s", 
+
+  warning(call. = FALSE, immediate. = TRUE, sprintf("Error in %s: %s",
     getCallNames(list(conditionCall(cond))), conditionMessage(cond)))
-  
+
   printStackTrace(cond, full = full, offset = offset)
 }
 
@@ -282,16 +282,16 @@ printStackTrace <- function(cond,
   should_drop <- !full
   should_strip <- !full
   should_prune <- !full
-  
+
   stackTraceCalls <- c(
     attr(cond, "deep.stack.trace", exact = TRUE),
     list(attr(cond, "stack.trace", exact = TRUE))
   )
-  
+
   stackTraceParents <- lapply(stackTraceCalls, attr, which = "parents", exact = TRUE)
   stackTraceCallNames <- lapply(stackTraceCalls, getCallNames)
   stackTraceCalls <- lapply(stackTraceCalls, offsetSrcrefs, offset = offset)
-  
+
   # Use dropTrivialFrames logic to remove trailing bits (.handleSimpleError, h)
   if (should_drop) {
     # toKeep is a list of logical vectors, of which elements (stack frames) to keep
@@ -301,7 +301,7 @@ printStackTrace <- function(cond,
     stackTraceCallNames <- mapply(stackTraceCallNames, FUN = `[`, toKeep, SIMPLIFY = FALSE)
     stackTraceParents <- mapply(stackTraceParents, FUN = `[`, toKeep, SIMPLIFY = FALSE)
   }
-  
+
   delayedAssign("all_true", {
     # List of logical vectors that are all TRUE, the same shape as
     # stackTraceCallNames. Delay the evaluation so we don't create it unless
@@ -310,7 +310,7 @@ printStackTrace <- function(cond,
       rep_len(TRUE, length(st))
     })
   })
-  
+
   # stripStackTraces and lapply(stackTraceParents, pruneStackTrace) return lists
   # of logical vectors. Use mapply(FUN = `&`) to boolean-and each pair of the
   # logical vectors.
@@ -320,7 +320,7 @@ printStackTrace <- function(cond,
     FUN = `&`,
     SIMPLIFY = FALSE
   )
-  
+
   dfs <- mapply(seq_along(stackTraceCalls), rev(stackTraceCalls), rev(stackTraceCallNames), rev(toShow), FUN = function(i, calls, nms, index) {
     st <- data.frame(
       num = rev(which(index)),
@@ -329,7 +329,7 @@ printStackTrace <- function(cond,
       category = rev(getCallCategories(calls[index])),
       stringsAsFactors = FALSE
     )
-    
+
     if (i != 1) {
       message("From earlier call:")
     }
@@ -357,7 +357,7 @@ printStackTrace <- function(cond,
 
     st
   }, SIMPLIFY = FALSE)
-  
+
   invisible()
 }
 
@@ -372,7 +372,7 @@ printStackTrace <- function(cond,
 extractStackTrace <- function(calls,
   full = getOption("shiny.fullstacktrace", FALSE),
   offset = getOption("shiny.stacktraceoffset", TRUE)) {
-  
+
   shinyDeprecated(NULL,
     "extractStackTrace is deprecated. Please contact the Shiny team if you were using this functionality.",
     version = "1.0.5")
@@ -459,19 +459,19 @@ stripOneStackTrace <- function(stackTrace, truncateFloor, startingScore) {
       prefix <- rep_len(FALSE, indexOfFloor)
     }
   }
-  
+
   if (length(stackTrace) == 0) {
     return(list(score = startingScore, character(0)))
   }
-  
+
   score <- rep.int(0L, length(stackTrace))
   score[stackTrace == "..stacktraceon.."] <- 1L
   score[stackTrace == "..stacktraceoff.."] <- -1L
   score <- startingScore + cumsum(score)
-  
+
   toShow <- score > 0 & !(stackTrace %in% c("..stacktraceon..", "..stacktraceoff..", "..stacktracefloor.."))
-  
-  
+
+
   list(score = utils::tail(score, 1), trace = c(prefix, toShow))
 }
 
@@ -486,11 +486,11 @@ pruneStackTrace <- function(parents) {
   # sufficient; we also need to drop nodes that are the last child, but one of
   # their ancestors is not.
   is_dupe <- duplicated(parents, fromLast = TRUE)
-  
+
   # The index of the most recently seen node that was actually kept instead of
   # dropped.
   current_node <- 0
-  
+
   # Loop over the parent indices. Anything that is not parented by current_node
   # (a.k.a. last-known-good node), or is a dupe, can be discarded. Anything that
   # is kept becomes the new current_node.
@@ -502,7 +502,7 @@ pruneStackTrace <- function(parents) {
       FALSE
     }
   }, FUN.VALUE = logical(1))
-  
+
   include
 }
 
@@ -515,7 +515,7 @@ dropTrivialFrames <- function(callnames) {
   # What's the last that *didn't* match stop/.handleSimpleError/h?
   lastGoodCall <- max(which(!hideable))
   toRemove <- length(callnames) - lastGoodCall
-  
+
   c(
     rep_len(TRUE, length(callnames) - toRemove),
     rep_len(FALSE, toRemove)
@@ -530,10 +530,10 @@ offsetSrcrefs <- function(calls, offset = TRUE) {
     # E.g. for "foo [bar.R:10]", line 10 of bar.R will be part of
     # the definition of foo().
     srcrefs <- c(utils::tail(srcrefs, -1), list(NULL))
-    
+
     calls <- setSrcRefs(calls, srcrefs)
   }
-  
+
   calls
 }
 
@@ -550,7 +550,7 @@ formatStackTrace <- function(calls, indent = "    ",
   shinyDeprecated(NULL,
     "extractStackTrace is deprecated. Please contact the Shiny team if you were using this functionality.",
     version = "1.0.5")
-  
+
   st <- extractStackTrace(calls, full = full, offset = offset)
   if (nrow(st) == 0) {
     return(character(0))

R/mock-session.R

@@ -0,0 +1,284 @@
+# TODO: is there a way to get this behavior without exporting these functions? R6?
+# TODO: clientData is documented as a reactiveValues, which this is not. Is it possible that
+#   users are currently assigning into clientData? That would not work as expected here.
+#' @noRd
+#' @export
+`$.mockclientdata` <- function(x, name) {
+  if (name == "allowDataUriScheme") { return(TRUE) }
+  if (name == "pixelratio") { return(1) }
+  if (name == "url_protocol") { return("http:") }
+  if (name == "url_hostname") { return("mocksession") }
+  if (name == "url_port") { return(1234) }
+  if (name == "url_pathname") { return("/mockpath") }
+  if (name == "url_hash") { return("#mockhash") }
+  if (name == "url_hash_initial") { return("#mockhash") }
+  if (name == "url_search") { return("?mocksearch=1") }
+
+  clientRE <- "^output_(.+)_([^_]+)$"
+  if(grepl(clientRE, name)) {
+    # TODO: use proper regex group matching here instead of redundantly parsing
+    el <- sub(clientRE, "\\1", name)
+    att <- sub(clientRE, "\\2", name)
+
+    if (att == "width") {
+      return(600)
+    } else if (att == "height") {
+      return(400)
+    } else if (att == "hidden") {
+      return(FALSE)
+    }
+  }
+  warning("Unexpected clientdata attribute accessed: ", name)
+  return(NULL)
+}
+
+#' @noRd
+#' @export
+`[[.mockclientdata` <- `$.mockclientdata`
+
+#' @noRd
+#' @export
+`[.mockclientdata` <- function(values, name) {
+  stop("Single-bracket indexing of mockclientdata is not allowed.")
+}
+
+#' @include timer.R
+MockShinySession <- R6Class(
+  'MockShinySession',
+  portable = FALSE,
+  class = FALSE,
+  public = list(
+    env = NULL,
+    # Needed for rendering HTML (i.e. renderUI)
+    singletons = character(0),
+    # Define a mock client data that always returns a size for plots
+    clientData = structure(list(), class="mockclientdata"),
+    reactlog = function(logEntry){},
+    incrementBusyCount = function(){},
+    output = NULL,
+    input = NULL,
+    userData = NULL,
+
+    initialize = function() {
+      private$.input <- ReactiveValues$new(dedupe = FALSE, label = "input")
+      private$flushCBs <- Callbacks$new()
+      private$flushedCBs <- Callbacks$new()
+      private$endedCBs <- Callbacks$new()
+      private$timer <- MockableTimerCallbacks$new()
+
+      self$userData <- new.env(parent=emptyenv())
+
+      # create output
+      out <- .createOutputWriter(self)
+      class(out) <- "shinyoutput"
+      self$output <- out
+
+      # Create a read-only copy of the inputs reactive.
+      self$input <- .createReactiveValues(private$.input, readonly = TRUE)
+    },
+    onFlush = function(fun, once) {
+      if (!isTRUE(once)) {
+        return(private$flushCBs$register(fun))
+      } else {
+        dereg <- private$flushCBs$register(function() {
+          dereg()
+          fun()
+        })
+        return(dereg)
+      }
+    },
+    onFlushed = function(fun, once) {
+      if (!isTRUE(once)) {
+        return(private$flushedCBs$register(fun))
+      } else {
+        dereg <- private$flushedCBs$register(function() {
+          dereg()
+          fun()
+        })
+        return(dereg)
+      }
+    },
+    onEnded = function(sessionEndedCallback) {
+      private$endedCBs$register(sessionEndedCallback)
+    },
+
+    isEnded = function(){ private$closed },
+    isClosed = function(){ private$closed },
+    close = function(){ private$closed <- TRUE },
+
+    #FIXME: this is wrong. Will need to be more complex.
+    cycleStartAction = function(callback){ callback() },
+
+    # Needed for image rendering. Base64-encode the given file.
+    fileUrl = function(name, file, contentType='application/octet-stream') {
+      bytes <- file.info(file)$size
+      if (is.na(bytes))
+        return(NULL)
+
+      fileData <- readBin(file, 'raw', n=bytes)
+      b64 <- rawToBase64(fileData)
+      return(paste('data:', contentType, ';base64,', b64, sep=''))
+    },
+
+    setInputs = function(...) {
+      vals <- list(...)
+      # TODO: is there really not a way to access `names` from inside an lapply?
+      lapply(names(vals), function(k){
+        v <- vals[[k]]
+        private$.input$set(k, v)
+      })
+
+      private$flush()
+    },
+
+
+    scheduleTask = function(millis, callback) {
+      id <- private$timer$schedule(millis, callback)
+
+      # Return a deregistration callback
+      function() {
+        invisible(private$timer$unschedule(id))
+      }
+    },
+    elapse = function(millis) {
+      msLeft <- millis
+
+      while (msLeft > 0){
+        t <- private$timer$timeToNextEvent()
+
+        if (is.infinite(t) || t <= 0 || msLeft < t){
+          # Either there's no good upcoming event or we can't make it to it in the allotted time.
+          break
+        }
+        msLeft <- msLeft - t
+        private$timer$elapse(t)
+
+        # timerCallbacks must run before flushReact.
+        private$timer$executeElapsed()
+        private$flush()
+      }
+
+      private$timer$elapse(msLeft)
+
+      # TODO: needed? We're guaranteed to not have anything to run given the above loop, right?
+      private$timer$executeElapsed()
+      private$flush()
+    },
+
+    now = function() {
+      # Contract is to return Sys.time, which is seconds, not millis.
+      private$timer$getElapsed()/1000
+    },
+
+    defineOutput = function(name, value, label) {
+      obs <- observe({
+        # We could just stash the promise, but we get an "unhandled promise error". This bypasses
+        prom <- NULL
+        tryCatch({
+          v <- value(self, name) #TODO: I'm not clear what `name` is supposed to be
+          if (!promises::is.promise(v)){
+            # Make our sync value into a promise
+            prom <- promises::promise(function(resolve, reject){ resolve(v) })
+          } else {
+            prom <- v
+          }
+        }, error=function(e){
+          # Error running value()
+          prom <<- promises::promise(function(resolve, reject){ reject(e) })
+        })
+
+        private$outs[[name]]$promise <- hybrid_chain(
+          prom,
+          function(v){
+            list(val = v, err = NULL)
+          }, catch=function(e){
+            list(val = NULL, err = e)
+          })
+      })
+      private$outs[[name]] <- list(obs = obs, func = value, promise = NULL)
+    },
+
+    getOutput = function(name) {
+      # Unlike the real outputs, we're going to return the last value rather than the unevaluated function
+      if (is.null(private$outs[[name]]$promise)) {
+        stop("The test referenced an output that hasn't been defined yet: output$", name)
+      }
+      # Make promise return
+      v <- extract(private$outs[[name]]$promise)
+      if (!is.null(v$err)){
+        stop(v$err)
+      } else {
+        v$val
+      }
+    },
+
+    registerDataObj = function(name, data, filterFunc) {},
+    allowReconnect = function(value) {},
+    reload = function() {},
+    resetBrush = function(brushId) {
+      warning("session$brush isn't meaningfully mocked on the MockShinySession")
+    },
+    sendCustomMessage = function(type, message) {},
+    sendBinaryMessage = function(type, message) {},
+    sendInputMessage = function(inputId, message) {},
+    setBookmarkExclude = function(names) {
+      warning("Bookmarking isn't meaningfully mocked in MockShinySession")
+    },
+    getBookmarkExclude = function() {
+      warning("Bookmarking isn't meaningfully mocked in MockShinySession")
+    },
+    onBookmark = function(fun) {
+      warning("Bookmarking isn't meaningfully mocked in MockShinySession")
+    },
+    onBookmarked = function(fun) {
+      warning("Bookmarking isn't meaningfully mocked in MockShinySession")
+    },
+    doBookmark = function() {
+      warning("Bookmarking isn't meaningfully mocked in MockShinySession")
+    },
+    onRestore = function(fun) {},
+    onRestored = function(fun) {},
+    exportTestValues = function() {},
+    getTestSnapshotUrl = function(input=TRUE, output=TRUE, export=TRUE, format="json") {},
+    ns = function(id) {
+      paste0("mock-session-", id) # TODO: does this need to be more complex/intelligent?
+    }
+  ),
+  private = list(
+    .input = NULL,
+    flushCBs = NULL,
+    flushedCBs = NULL,
+    endedCBs = NULL,
+    timer = NULL,
+    closed = FALSE,
+    outs = list(),
+    returnedVal = NULL,
+
+    flush = function(){
+      isolate(private$flushCBs$invoke(..stacktraceon = TRUE))
+      flushReact()
+      isolate(private$flushedCBs$invoke(..stacktraceon = TRUE))
+      later::run_now()
+    }
+  ),
+  active = list(
+    # If assigning to `returned`, proactively flush
+    returned = function(value){
+      if(missing(value)){
+        return(private$returnedVal)
+      }
+      # When you assign to returned, that implies that you just ran
+      # the module. So we should proactively flush. We have to do this
+      # here since flush is private.
+      private$returnedVal <- value
+      private$flush()
+    },
+    request = function(value) {
+      if (!missing(value)){
+        stop("session$request can't be assigned to")
+      }
+      warning("session$request doesn't currently simulate a realistic request on MockShinySession")
+      new.env(parent=emptyenv())
+    }
+  )
+)

R/test-module.R

@@ -0,0 +1,145 @@
+# Promise helpers taken from:
+#   https://github.com/rstudio/promises/blob/master/tests/testthat/common.R
+# Block until all pending later tasks have executed
+# FIXME: will this work with multiple promises pending in parallel?
+wait_for_it <- function() {
+  while (!later::loop_empty()) {
+    later::run_now()
+    Sys.sleep(0.1)
+  }
+}
+
+# Block until the promise is resolved/rejected. If resolved, return the value.
+# If rejected, throw (yes throw, not return) the error.
+#' @importFrom promises %...!%
+#' @importFrom promises %...>%
+extract <- function(promise) {
+  promise_value <- NULL
+  error <- NULL
+  promise %...>%
+    (function(value) promise_value <<- value) %...!%
+    (function(reason) error <<- reason)
+
+  wait_for_it()
+  if (!is.null(error))
+    stop(error)
+  else
+    promise_value
+}
+
+#' Test a shiny module
+#' @param module The module under test
+#' @param expr Test code containing expectations. The test expression will run
+#'   in the module's environment, meaning that the module's parameters (e.g.
+#'   `input`, `output`, and `session`) will be available along with any other
+#'   values created inside of the module.
+#' @param args A list of arguments to pass into the module beyond `input`,
+#'   `output`, and `session`.
+#' @param initialState A list describing the initial values for `input`. If no
+#'   initial state is given, `input` will initialize as an empty list.
+#' @param ... Additional named arguments to be passed on to the module function.
+#' @include mock-session.R
+#' @export
+testModule <- function(module, expr, args, ...) {
+  expr <- substitute(expr)
+  .testModule(module, expr, args, ...)
+}
+
+.testModule <- function(module, expr, args, ...) {
+  # Capture the environment from the module
+  # Inserts `session$env <- environment()` at the top of the function
+  fn_body <- body(module)
+  fn_body[seq(3, length(fn_body)+1)] <- fn_body[seq(2, length(fn_body))]
+  fn_body[[2]] <- quote(session$env <- environment())
+  body(module) <- fn_body
+
+  # Substitute expr for later evaluation
+  if (!is.call(expr)){
+    expr <- substitute(expr)
+  }
+
+  # Create a mock session
+  session <- MockShinySession$new()
+
+  # Parse the additional arguments
+  args <- list(...)
+  args[["input"]] <- session$input
+  args[["output"]] <- session$output
+  args[["session"]] <- session
+
+  # Initialize the module
+  isolate(
+    withReactiveDomain(
+      session,
+      withr::with_options(list(`shiny.allowoutputreads`=TRUE), {
+        # Remember that invoking this module implicitly assigns to `session$env`
+        # Also, assigning to `$returned` will cause a flush to happen automatically.
+        session$returned <- do.call(module, args)
+      })
+    )
+  )
+
+  # Run the test expression in a reactive context and in the module's environment.
+  # We don't need to flush before entering the loop because the first expr that we execute is `{`.
+  # So we'll already flush before we get to the good stuff.
+  isolate({
+    withReactiveDomain(
+      session,
+      withr::with_options(list(`shiny.allowoutputreads`=TRUE), {
+        eval(expr, session$env)
+      })
+    )
+  })
+
+  if (!session$isClosed()){
+    session$close()
+  }
+}
+
+#' Test an app's server-side logic
+#' @param expr Test code containing expectations
+#' @param appdir The directory root of the Shiny application. If `NULL`, this function
+#'   will work up the directory hierarchy --- starting with the current directory ---
+#'   looking for a directory that contains an `app.R` or `server.R` file.
+#' @export
+testServer <- function(expr, appDir=NULL) {
+  if (is.null(appDir)){
+    appDir <- findApp()
+  }
+
+  app <- shinyAppDir(appDir)
+  server <- app$serverFuncSource()
+
+  # Add `session` argument if not present
+  fn_formals <- formals(server)
+  if (! "session" %in% names(fn_formals)) {
+    fn_formals$session <- bquote()
+    formals(server) <- fn_formals
+  }
+
+  s3 <<- server
+  # Now test the server as we would a module
+  .testModule(server, expr=substitute(expr))
+}
+
+findApp <- function(startDir="."){
+  dir <- normalizePath(startDir)
+
+  # The loop will either return or stop() itself.
+  while (TRUE){
+    if(file.exists.ci(file.path(dir, "app.R")) || file.exists.ci(file.path(dir, "server.R"))){
+      return(dir)
+    }
+
+    # Move up a directory
+    origDir <- dir
+    dir <- dirname(dir)
+
+    # Testing for "root" path can be tricky. OSs differ and on Windows, network shares
+    # might have a \\ prefix. Easier to just see if we got stuck and abort.
+    if (dir == origDir){
+      # We can go no further.
+      stop("No shiny app was found in ", startDir, " or any of its parent directories")
+    }
+  }
+}

R/timer.R

@@ -62,7 +62,7 @@ BaseTimerCallbacks <- R6Class(
     },
     takeElapsed = function() {
       t <- .now()
-      elapsed <- .times$time < .now()
+      elapsed <- .times$time <= t
       result <- .times[elapsed,]
       .times <<- .times[!elapsed,]
 
@@ -116,6 +116,9 @@ MockableTimerCallbacks <- R6Class(
     },
     elapse = function(millis){
       private$time <<- private$time + millis
+    },
+    getElapsed = function(){
+      private$time
     }
   ), private = list(
     time = 0L

inst/_pkgdown.yml

@@ -215,3 +215,8 @@ reference:
     contents:
       - shinyApp
       - maskReactiveContext
+  - title: Testing
+    desc: Functions intended for testing of Shiny components
+    contents:
+      - testModule
+      - testServer

man/testModule.Rd

@@ -0,0 +1,27 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/test-module.R
+\name{testModule}
+\alias{testModule}
+\title{Test a shiny module}
+\usage{
+testModule(module, expr, args, ...)
+}
+\arguments{
+\item{module}{The module under test}
+
+\item{expr}{Test code containing expectations. The test expression will run
+in the module's environment, meaning that the module's parameters (e.g.
+\code{input}, \code{output}, and \code{session}) will be available along with any other
+values created inside of the module.}
+
+\item{args}{A list of arguments to pass into the module beyond \code{input},
+\code{output}, and \code{session}.}
+
+\item{...}{Additional named arguments to be passed on to the module function.}
+
+\item{initialState}{A list describing the initial values for \code{input}. If no
+initial state is given, \code{input} will initialize as an empty list.}
+}
+\description{
+Test a shiny module
+}

man/testServer.Rd

@@ -0,0 +1,18 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/test-module.R
+\name{testServer}
+\alias{testServer}
+\title{Test an app's server-side logic}
+\usage{
+testServer(expr, appDir = NULL)
+}
+\arguments{
+\item{expr}{Test code containing expectations}
+
+\item{appdir}{The directory root of the Shiny application. If \code{NULL}, this function
+will work up the directory hierarchy --- starting with the current directory ---
+looking for a directory that contains an \code{app.R} or \code{server.R} file.}
+}
+\description{
+Test an app's server-side logic
+}

tests/testthat/test-mock-session.R

@@ -0,0 +1,283 @@
+context("MockShinySession")
+
+test_that("invalidateLater supported", {
+  session <- MockShinySession$new()
+  i <- 0
+  isolate({
+    observe({
+      invalidateLater(10, session)
+      i <<- i + 1
+    })
+  })
+  flushReact()
+  expect_equal(i, 1)
+  session$elapse(10)
+  expect_equal(i, 2)
+})
+
+test_that("reactiveTimer supported", {
+  session <- MockShinySession$new()
+  i <- 0
+  isolate({
+    rt <- reactiveTimer(10, session)
+    observe({
+      rt()
+      i <<- i + 1
+    })
+  })
+  flushReact()
+  expect_equal(i, 1)
+  session$elapse(10)
+  expect_equal(i, 2)
+})
+
+test_that("reactivePoll supported", {
+  session <- MockShinySession$new()
+  i <- 0
+  isolate({
+    rp <- reactivePoll(10, session, Sys.time, function(){ i <<- i + 1 })
+    observe({
+      # Sys.time as the check function will cause it to always run the update.
+      rp()
+    })
+  })
+  flushReact()
+  expect_equal(i, 1)
+  session$elapse(10)
+  flushReact()
+  expect_equal(i, 2)
+})
+
+test_that("renderCachedPlot supported", {
+  session <- MockShinySession$new()
+  isolate({
+    # renderCachedPlot is sensitive to having the cache set for it before entering.
+    origCache <- getShinyOption("cache")
+    shinyOptions(cache = MemoryCache$new())
+    on.exit(shinyOptions(cache = origCache), add=TRUE)
+
+    p <- renderCachedPlot({ plot(1,1) }, { Sys.time() })
+    plt <- p(session, "name")
+
+    # Should have a size defined
+    expect_equal(plt$coordmap$dims$width, 692) #FIXME: why isn't this respecting the clientdata sizes?
+    expect_equal(plt$coordmap$dims$height, 400)
+  })
+})
+
+test_that("renderDataTable supported", {
+  session <- MockShinySession$new()
+  isolate({
+    rt <- renderDataTable({
+      head(iris)
+    })
+    res <- rt(session, "name")
+    expect_equal(res$colnames, colnames(iris))
+  })
+})
+
+test_that("renderImage supported", {
+  session <- MockShinySession$new()
+  isolate({
+    ri <- renderImage({
+      # A temp file to save the output. It will be deleted after renderImage
+      # sends it, because deleteFile=TRUE.
+      outfile <- tempfile(fileext='.png')
+
+      # Generate a png
+      png(outfile, width=400, height=400)
+      plot(1,1)
+      dev.off()
+
+      # Return a list
+      list(src = outfile,
+           alt = "Alt text here")
+    }, deleteFile = TRUE)
+    img <- ri(session, "name")
+    expect_match(img$src, "^data:image/png;base64,")
+    expect_equal(img$alt, "Alt text here")
+  })
+})
+
+test_that("renderPlot supported", {
+  session <- MockShinySession$new()
+  isolate({
+    p <- renderPlot({ plot(1,1) })
+    plt <- p(session, "name")
+
+    # Should have a size defined
+    expect_equal(plt$width, 600)
+    expect_equal(plt$height, 400)
+  })
+})
+
+test_that("renderPrint supported", {
+  session <- MockShinySession$new()
+  isolate({
+    p <- renderPrint({ print("hi") })
+    pt <- p(session, "name")
+
+    expect_equal(pt, "[1] \"hi\"")
+  })
+})
+
+test_that("renderTable supported", {
+  session <- MockShinySession$new()
+  isolate({
+    rt <- renderTable({
+      head(iris)
+    })
+    ren <- rt(session, "name")
+    expect_match(ren, "^<table")
+  })
+})
+
+test_that("renderText supported", {
+  session <- MockShinySession$new()
+  isolate({
+    rt <- renderText({
+      "text here"
+    })
+    ren <- rt(session, "name")
+    expect_equal(ren, "text here")
+  })
+})
+
+test_that("renderUI supported", {
+  session <- MockShinySession$new()
+  isolate({
+    ui <- renderUI({
+      tags$a(href="https://rstudio.com", "link")
+    })
+    ren <- ui(session, "name")
+    expect_equal(ren$deps, list())
+    expect_equal(as.character(ren$html), "<a href=\"https://rstudio.com\">link</a>")
+  })
+})
+
+test_that("session supports allowReconnect", {
+  session <- MockShinySession$new()
+  session$allowReconnect(TRUE)
+  expect_true(TRUE) # testthat insists that every test must have an expectation
+})
+
+test_that("session supports clientData", {
+  session <- MockShinySession$new()
+  expect_equal(session$clientData$allowDataUriScheme, TRUE)
+  expect_equal(session$clientData$pixelratio, 1)
+  expect_equal(session$clientData$url_protocol, "http:")
+  expect_equal(session$clientData$url_hostname, "mocksession")
+  expect_equal(session$clientData$url_port, 1234)
+  expect_equal(session$clientData$url_pathname, "/mockpath")
+  expect_equal(session$clientData$url_hash, "#mockhash")
+  expect_equal(session$clientData$url_hash_initial, "#mockhash")
+  expect_equal(session$clientData$url_search, "?mocksearch=1")
+
+  # Arbitrary names have width, height, and hidden
+  expect_equal(session$clientData$output_arbitrary_width, 600)
+  expect_equal(session$clientData$output_arbitrary_height, 400)
+  expect_equal(session$clientData$output_arbitrary_hidden, FALSE)
+})
+
+test_that("session supports ns", {
+  session <- MockShinySession$new()
+  expect_equal(session$ns("hi"), "mock-session-hi")
+})
+
+test_that("session supports reload", {
+  session <- MockShinySession$new()
+  session$reload()
+  expect_true(TRUE) # testthat insists that every test must have an expectation
+})
+
+test_that("session supports close", {
+  session <- MockShinySession$new()
+  session$close()
+  expect_true(TRUE) # testthat insists that every test must have an expectation
+})
+
+test_that("session supports request", {
+  session <- MockShinySession$new()
+  expect_warning(session$request, "doesn't currently simulate a realistic request")
+  expect_error(session$request <- "blah", "can't be assigned to")
+})
+
+test_that("session supports userData", {
+  session <- MockShinySession$new()
+  expect_length(ls(session$userData), 0)
+  session$userData$x <- 123
+  expect_length(ls(session$userData), 1)
+  expect_equal(session$userData$x, 123)
+})
+
+test_that("session supports resetBrush", {
+  session <- MockShinySession$new()
+  expect_warning(session$resetBrush(1), "isn't meaningfully mocked")
+})
+
+test_that("session supports sendCustomMessage", {
+  session <- MockShinySession$new()
+  session$sendCustomMessage(type=1, message=2)
+  expect_true(TRUE) # testthat insists that every test must have an expectation
+})
+
+test_that("session supports sendBinaryMessage", {
+  session <- MockShinySession$new()
+  session$sendBinaryMessage(type=1, message=2)
+  expect_true(TRUE) # testthat insists that every test must have an expectation
+})
+
+test_that("session supports sendInputMessage", {
+  session <- MockShinySession$new()
+  session$sendInputMessage(inputId=1, message=2)
+  expect_true(TRUE) # testthat insists that every test must have an expectation
+})
+
+test_that("session supports setBookmarkExclude", {
+  session <- MockShinySession$new()
+  expect_warning(session$setBookmarkExclude(names=1), "Bookmarking isn't meaningfully mocked")
+})
+
+test_that("session supports getBookmarkExclude", {
+  session <- MockShinySession$new()
+  expect_warning(session$getBookmarkExclude(), "Bookmarking isn't meaningfully mocked")
+})
+
+test_that("session supports onBookmark", {
+  session <- MockShinySession$new()
+  expect_warning(session$onBookmark(fun=1), "Bookmarking isn't meaningfully mocked")
+})
+
+test_that("session supports onBookmarked", {
+  session <- MockShinySession$new()
+  expect_warning(session$onBookmarked(fun=1), "Bookmarking isn't meaningfully mocked")
+})
+
+test_that("session supports doBookmark", {
+  session <- MockShinySession$new()
+  expect_warning(session$doBookmark(), "Bookmarking isn't meaningfully mocked")
+})
+
+test_that("session supports onRestore", {
+  session <- MockShinySession$new()
+  session$onRestore(fun=1)
+  expect_true(TRUE) # testthat insists that every test must have an expectation
+})
+
+test_that("session supports onRestored", {
+  session <- MockShinySession$new()
+  session$onRestored(fun=1)
+  expect_true(TRUE) # testthat insists that every test must have an expectation
+})
+
+test_that("session supports exportTestValues", {
+  session <- MockShinySession$new()
+  session$exportTestValues()
+  expect_true(TRUE) # testthat insists that every test must have an expectation
+})
+
+test_that("session supports getTestSnapshotUrl", {
+  session <- MockShinySession$new()
+  session$getTestSnapshotUrl(input=1, output=1, export=1, format=1)
+  expect_true(TRUE) # testthat insists that every test must have an expectation
+})

tests/testthat/test-test-module.R

@@ -0,0 +1,618 @@
+context("testModule")
+
+library(promises)
+library(future)
+plan(multisession)
+
+test_that("testModule handles observers", {
+  module <- function(input, output, session) {
+    rv <- reactiveValues(x = 0, y = 0)
+    observe({
+      rv$x <- input$x * 2
+    })
+    observe({
+      rv$y <- rv$x
+    })
+    output$txt <- renderText({
+      paste0("Value: ", rv$x)
+    })
+  }
+
+  testModule(module, {
+    session$setInputs(x=1)
+    expect_equal(rv$y, 2)
+    expect_equal(rv$x, 2)
+    expect_equal(output$txt, "Value: 2")
+
+    session$setInputs(x=2)
+    expect_equal(rv$x, 4)
+    expect_equal(rv$y, 4)
+    expect_equal(output$txt, "Value: 4")
+  })
+})
+
+test_that("inputs aren't directly assignable", {
+  module <- function(input, output, session) {
+  }
+
+  testModule(module, {
+    session$setInputs(x = 0)
+    expect_error({ input$x <- 1 }, "Attempted to assign value to a read-only")
+    expect_error({ input$y <- 1 }, "Attempted to assign value to a read-only")
+  })
+})
+
+test_that("testModule handles more complex expressions", {
+  module <- function(input, output, session){
+    output$txt <- renderText({
+      input$x
+    })
+  }
+
+  testModule(module, {
+    for (i in 1:5){
+      session$setInputs(x=i)
+      expect_equal(output$txt, as.character(i))
+    }
+    expect_equal(output$txt, "5")
+
+    if(TRUE){
+      session$setInputs(x="abc")
+      expect_equal(output$txt, "abc")
+    }
+  })
+})
+
+test_that("testModule handles reactiveVal", {
+  module <- function(input, output, session) {
+    x <- reactiveVal(0)
+    observe({
+      x(input$y + input$z)
+    })
+  }
+
+  testModule(module, {
+    session$setInputs(y=1, z=2)
+
+    expect_equal(x(), 3)
+
+    session$setInputs(z=3)
+    expect_equal(x(), 4)
+
+    session$setInputs(y=5)
+    expect_equal(x(), 8)
+  })
+})
+
+test_that("testModule handles reactives with complex dependency tree", {
+  module <- function(input, output, session) {
+    x <- reactiveValues(x=1)
+    r <- reactive({
+      x$x + input$a + input$b
+    })
+    r2 <- reactive({
+      r() + input$c
+    })
+  }
+
+  testModule(module, {
+    session$setInputs(a=1, b=2, c=3)
+    expect_equal(r(), 4)
+    expect_equal(r2(), 7)
+
+    session$setInputs(a=2)
+    expect_equal(r(), 5)
+    expect_equal(r2(), 8)
+
+    session$setInputs(b=0)
+    expect_equal(r2(), 6)
+    expect_equal(r(), 3)
+
+    session$setInputs(c=4)
+    expect_equal(r(), 3)
+    expect_equal(r2(), 7)
+  })
+})
+
+test_that("testModule handles reactivePoll", {
+  module <- function(input, output, session) {
+    rv <- reactiveValues(x = 0)
+    rp <- reactivePoll(50, session, function(){ as.numeric(Sys.time()) }, function(){
+      isolate(rv$x <- rv$x + 1)
+      as.numeric(Sys.time())
+    })
+
+    observe({rp()})
+  }
+
+  testModule(module, {
+    expect_equal(rv$x, 1)
+
+    for (i in 1:4){
+      session$elapse(50)
+    }
+
+    expect_equal(rv$x, 5)
+  })
+})
+
+test_that("testModule handles reactiveTimer", {
+  module <- function(input, output, session) {
+    rv <- reactiveValues(x = 0)
+
+    rp <- reactiveTimer(50)
+    observe({
+      rp()
+      isolate(rv$x <- rv$x + 1)
+    })
+  }
+
+  testModule(module, {
+    expect_equal(rv$x, 1)
+
+    session$elapse(200)
+
+    expect_equal(rv$x, 5)
+  })
+})
+
+test_that("testModule handles debounce/throttle", {
+  module <- function(input, output, session) {
+    rv <- reactiveValues(t = 0, d = 0)
+    react <- reactive({
+      input$y
+    })
+    rt <- throttle(react, 100)
+    rd <- debounce(react, 100)
+
+    observe({
+      rt() # Invalidate this block on the timer
+      isolate(rv$t <- rv$t + 1)
+    })
+
+    observe({
+      rd()
+      isolate(rv$d <- rv$d + 1)
+    })
+  }
+
+  testModule(module, {
+    session$setInputs(y = TRUE)
+    expect_equal(rv$d, 1)
+    for (i in 2:5){
+      session$setInputs(y = FALSE)
+      session$elapse(51)
+      session$setInputs(y = TRUE)
+      expect_equal(rv$t, i-1)
+      session$elapse(51) # TODO: we usually don't have to pad by a ms, but here we do. Investigate.
+      expect_equal(rv$t, i)
+    }
+    # Never sufficient time to debounce. Not incremented
+    expect_equal(rv$d, 1)
+    session$elapse(50)
+
+    # Now that 100ms has passed since the last update, debounce should have triggered
+    expect_equal(rv$d, 2)
+  })
+})
+
+test_that("testModule wraps output in an observer", {
+  testthat::skip("I'm not sure of a great way to test this without timers.")
+  # And honestly it's so foundational in what we're doing now that it might not be necessary to test?
+
+
+  module <- function(input, output, session) {
+    rv <- reactiveValues(x=0)
+    rp <- reactiveTimer(50)
+    output$txt <- renderText({
+      rp()
+      isolate(rv$x <- rv$x + 1)
+    })
+  }
+
+  testModule(module, {
+    session$setInputs(x=1)
+    # Timers only tick if they're being observed. If the output weren't being
+    # wrapped in an observer, we'd see the value of rv$x initialize to zero and
+    # only increment when we evaluated the output. e.g.:
+    #
+    # expect_equal(rv$x, 0)
+    # Sys.sleep(1)
+    # expect_equal(rv$x, 0)
+    # output$txt()
+    # expect_equal(rv$x, 1)
+
+    expect_equal(rv$x, 1)
+    expect_equal(output$txt, "1")
+    Sys.sleep(.05)
+    Sys.sleep(.05)
+    expect_gt(rv$x, 1)
+    expect_equal(output$txt, as.character(rv$x))
+  })
+
+  # FIXME:
+  #  - Do we want the output to be accessible natively, or some $get() on the output? If we do a get() we could
+  #    do more helpful spy-type things around exec count.
+  #  - plots and such?
+})
+
+test_that("testModule works with async", {
+  module <- function(input, output, session) {
+    output$txt <- renderText({
+      val <- input$x
+      future({ val })
+    })
+
+    output$error <- renderText({
+      future({ stop("error here") })
+    })
+
+    output$sync <- renderText({
+      # No promises here
+      "abc"
+    })
+  }
+
+  testModule(module, {
+    session$setInputs(x=1)
+    expect_equal(output$txt, "1")
+    expect_equal(output$sync, "abc")
+
+    # Error gets thrown repeatedly
+    expect_error(output$error, "error here")
+    expect_error(output$error, "error here")
+
+    # Responds reactively
+    session$setInputs(x=2)
+    expect_equal(output$txt, "2")
+    # Error still thrown
+    expect_error(output$error, "error here")
+  })
+})
+
+test_that("testModule works with multiple promises in parallel", {
+  module <- function(input, output, session) {
+    output$txt1 <- renderText({
+      future({
+        Sys.sleep(1)
+        1
+      })
+    })
+
+    output$txt2 <- renderText({
+      future({
+        Sys.sleep(1)
+        2
+      })
+    })
+  }
+
+  testModule(module, {
+    # As we enter this test code, the promises will still be running in the background.
+    # We'll need to give them ~2s (plus overhead) to complete
+    startMS <- as.numeric(Sys.time()) * 1000
+    expect_equal(output$txt1, "1") # This first call will block waiting for the promise to return
+    expect_equal(output$txt2, "2")
+    expect_equal(output$txt2, "2") # Now that we have the values, access should not incur a 1s delay.
+    expect_equal(output$txt1, "1")
+    expect_equal(output$txt1, "1")
+    expect_equal(output$txt2, "2")
+    endMS <- as.numeric(Sys.time()) * 1000
+
+    # We'll pad quite a bit because promises can introduce some lag. But the point we're trying
+    # to prove is that we're not hitting a 1s delay for each output access, which = 6000ms. If we're
+    # under that, then things are likely working.
+    expect_lt(endMS - startMS, 4000)
+  })
+})
+
+test_that("testModule handles async errors", {
+  module <- function(input, output, session, arg1, arg2){
+    output$err <- renderText({
+      future({ "my error"}) %...>%
+        stop() %...>%
+        print() # Extra steps after the error
+    })
+
+    output$safe <- renderText({
+      future({ safeError("my safe error") }) %...>%
+        stop()
+    })
+  }
+
+  testModule(module, {
+    expect_error(output$err, "my error")
+    # TODO: helper for safe errors so users don't have to learn "shiny.custom.error"?
+    expect_error(output$safe, "my safe error", class="shiny.custom.error")
+  })
+})
+
+test_that("testModule handles modules with additional arguments", {
+  module <- function(input, output, session, arg1, arg2){
+    output$txt1 <- renderText({
+      arg1
+    })
+
+    output$txt2 <- renderText({
+      arg2
+    })
+
+    output$inp <- renderText({
+      input$x
+    })
+  }
+
+  testModule(module, {
+    expect_equal(output$txt1, "val1")
+    expect_equal(output$txt2, "val2")
+  }, arg1="val1", arg2="val2")
+})
+
+test_that("testModule captures htmlwidgets", {
+  # TODO: use a simple built-in htmlwidget instead of something complex like dygraph
+  if (!requireNamespace("dygraphs")){
+    testthat::skip("dygraphs not available to test htmlwidgets")
+  }
+
+  if (!requireNamespace("jsonlite")){
+    testthat::skip("jsonlite not available to test htmlwidgets")
+  }
+
+  module <- function(input, output, session){
+    output$dy <- dygraphs::renderDygraph({
+      dygraphs::dygraph(data.frame(outcome=0:5, year=2000:2005))
+    })
+  }
+
+  testModule(module, {
+    # Really, this test should be specific to each htmlwidget. Here, we don't want to bind ourselves
+    # to the current JSON structure of dygraphs, so we'll just check one element to see that the raw
+    # JSON was exposed and is accessible in tests.
+    d <- jsonlite::fromJSON(output$dy)$x$data
+    expect_equal(d[1,], 0:5)
+    expect_equal(d[2,], 2000:2005)
+  })
+})
+
+test_that("testModule captures renderUI", {
+  module <- function(input, output, session){
+    output$ui <- renderUI({
+      tags$a(href="https://rstudio.com", "hello!")
+    })
+  }
+
+  testModule(module, {
+    expect_equal(output$ui$deps, list())
+    expect_equal(as.character(output$ui$html), "<a href=\"https://rstudio.com\">hello!</a>")
+  })
+})
+
+test_that("testModule captures base graphics outputs", {
+  module <- function(input, output, session){
+    output$fixed <- renderPlot({
+      plot(1,1)
+    }, width=300, height=350)
+
+    output$dynamic <- renderPlot({
+      plot(1,1)
+    })
+  }
+
+  testModule(module, {
+    # We aren't yet able to create reproducible graphics, so this test is intentionally pretty
+    # limited.
+    expect_equal(output$fixed$width, 300)
+    expect_equal(output$fixed$height, 350)
+    expect_match(output$fixed$src, "^data:image/png;base64,")
+
+    # Ensure that the plot defaults to a reasonable size.
+    expect_equal(output$dynamic$width, 600)
+    expect_equal(output$dynamic$height, 400)
+    expect_match(output$dynamic$src, "^data:image/png;base64,")
+
+    # TODO: how do you customize automatically inferred plot sizes?
+    # session$setPlotMeta("dynamic", width=600, height=300) ?
+  })
+})
+
+test_that("testModule captures ggplot2 outputs", {
+  if (!requireNamespace("ggplot2")){
+    testthat::skip("ggplot2 not available")
+  }
+
+  module <- function(input, output, session){
+    output$fixed <- renderPlot({
+      ggplot2::qplot(iris$Sepal.Length, iris$Sepal.Width)
+    }, width=300, height=350)
+
+    output$dynamic <- renderPlot({
+      ggplot2::qplot(iris$Sepal.Length, iris$Sepal.Width)
+    })
+  }
+
+  testModule(module, {
+    expect_equal(output$fixed$width, 300)
+    expect_equal(output$fixed$height, 350)
+    expect_match(output$fixed$src, "^data:image/png;base64,")
+
+    # Ensure that the plot defaults to a reasonable size.
+    expect_equal(output$dynamic$width, 600)
+    expect_equal(output$dynamic$height, 400)
+    expect_match(output$dynamic$src, "^data:image/png;base64,")
+  })
+})
+
+test_that("testModule exposes the returned value from the module", {
+  module <- function(input, output, session){
+    reactive({
+      return(input$a + input$b)
+    })
+  }
+
+  testModule(module, {
+    session$setInputs(a=1, b=2)
+    expect_equal(session$returned(), 3)
+
+    # And retains reactivity
+    session$setInputs(a=2)
+    expect_equal(session$returned(), 4)
+  })
+})
+
+test_that("testModule handles synchronous errors", {
+  module <- function(input, output, session, arg1, arg2){
+    output$err <- renderText({
+      stop("my error")
+    })
+
+    output$safe <- renderText({
+      stop(safeError("my safe error"))
+    })
+  }
+
+  testModule(module, {
+    expect_error(output$err, "my error")
+    # TODO: helper for safe errors so users don't have to learn "shiny.custom.error"?
+    expect_error(output$safe, "my safe error", class="shiny.custom.error")
+  })
+})
+
+test_that("accessing a non-existant output gives an informative message", {
+  module <- function(input, output, session){}
+
+  testModule(module, {
+    expect_error(output$dontexist, "hasn't been defined yet: output\\$dontexist")
+  })
+})
+
+test_that("testServer works", {
+  # app.R
+  testServer({
+    session$setInputs(dist="norm", n=5)
+    expect_length(d(), 5)
+
+    session$setInputs(dist="unif", n=6)
+    expect_length(d(), 6)
+  }, appDir=test_path("../../inst/examples/06_tabsets"))
+
+  # TODO: test with server.R
+})
+
+test_that("testServer works when referencing external globals", {
+  # If global is defined at the top of app.R outside of the server function.
+  testthat::skip("NYI")
+})
+
+test_that("testModule handles invalidateLater", {
+  module <- function(input, output, session) {
+    rv <- reactiveValues(x = 0)
+    observe({
+      isolate(rv$x <- rv$x + 1)
+      # We're only testing one invalidation
+      if (isolate(rv$x) <= 1){
+        invalidateLater(50)
+      }
+    })
+  }
+
+  testModule(module, {
+    # Should have run once
+    expect_equal(rv$x, 1)
+
+    session$elapse(49)
+    expect_equal(rv$x, 1)
+
+    session$elapse(1)
+    # Should have been incremented now
+    expect_equal(rv$x, 2)
+  })
+})
+
+test_that("session ended handlers work", {
+  module <- function(input, output, session){}
+
+  testModule(module, {
+    rv <- reactiveValues(closed = FALSE)
+    session$onEnded(function(){
+      rv$closed <- TRUE
+    })
+
+    expect_equal(session$isEnded(), FALSE)
+    expect_equal(session$isClosed(), FALSE)
+    expect_false(rv$closed, FALSE)
+
+    session$close()
+
+    expect_equal(session$isEnded(), TRUE)
+    expect_equal(session$isClosed(), TRUE)
+    expect_false(rv$closed, TRUE)
+  })
+})
+
+test_that("session flush handlers work", {
+  module <- function(input, output, session) {
+    rv <- reactiveValues(x = 0, flushCounter = 0, flushedCounter = 0,
+                         flushOnceCounter = 0, flushedOnceCounter = 0)
+
+    onFlush(function(){rv$flushCounter <- rv$flushCounter + 1}, once=FALSE)
+    onFlushed(function(){rv$flushedCounter <- rv$flushedCounter + 1}, once=FALSE)
+    onFlushed(function(){rv$flushOnceCounter <- rv$flushOnceCounter + 1}, once=TRUE)
+    onFlushed(function(){rv$flushedOnceCounter <- rv$flushedOnceCounter + 1}, once=TRUE)
+
+    observe({
+      rv$x <- input$x * 2
+    })
+  }
+
+  testModule(module, {
+    session$setInputs(x=1)
+    expect_equal(rv$x, 2)
+    # We're not concerned with the exact values here -- only that they increase
+    fc <- rv$flushCounter
+    fdc <- rv$flushedCounter
+
+    session$setInputs(x=2)
+    expect_gt(rv$flushCounter, fc)
+    expect_gt(rv$flushedCounter, fdc)
+
+    # These should have only run once
+    expect_equal(rv$flushOnceCounter, 1)
+    expect_equal(rv$flushedOnceCounter, 1)
+
+  })
+})
+
+test_that("findApp errors with no app", {
+  calls <- 0
+  nothingExists <- function(path){
+    calls <<- calls + 1
+    FALSE
+  }
+  fa <- rewire(findApp, file.exists.ci=nothingExists)
+  expect_error(
+    expect_warning(fa("/some/path/here"), "No such file or directory"), # since we just made up a path
+    "No shiny app was found in ")
+  expect_equal(calls, 4 * 2) # Checks here, path, some, and / -- looking for app.R and server.R for each
+})
+
+test_that("findApp works with app in current or parent dir", {
+  calls <- 0
+  cd <- normalizePath(".")
+  mockExists <- function(path){
+    # Only TRUE if looking for server.R or app.R in current Dir
+    calls <<- calls + 1
+
+    appPath <- file.path(cd, "app.R")
+    serverPath <- file.path(cd, "server.R")
+    return(path %in% c(appPath, serverPath))
+  }
+  fa <- rewire(findApp, file.exists.ci=mockExists)
+  expect_equal(fa(), cd)
+  expect_equal(calls, 1) # Should get a hit on the first call and stop
+
+  # Reset and point to the parent dir
+  calls <- 0
+  cd <- normalizePath("../") # TODO: won't work if running tests in the root dir.
+  expect_equal(fa(), cd)
+  expect_equal(calls, 3) # Two for current dir and hit on the first in the parent
+})

vignettes/integration-testing.Rmd

@@ -0,0 +1,296 @@
+---
+title: "Integration Testing in Shiny"
+output: rmarkdown::html_vignette
+vignette: >
+  %\VignetteIndexEntry{Your Vignette Title}
+  %\VignetteEncoding{UTF-8}
+  %\VignetteEngine{knitr::rmarkdown}
+editor_options: 
+  chunk_output_type: console
+---
+
+```{r setup, include=FALSE}
+knitr::opts_chunk$set(echo = TRUE)
+```
+
+## Introduction to Inspecting Modules
+
+First, we'll define a simple Shiny module:
+
+```{r}
+library(shiny)
+module <- function(input, output, session) {
+  rv <- reactiveValues(x = 0)
+  observe({
+    rv$x <- input$x * 2
+  })
+  output$txt <- renderText({
+    paste0("Value: ", rv$x)
+  })
+}
+```
+
+This module
+
+  - depends on one input (`x`),
+  - has an intermediate, internal `reactiveValues` (`rv`) which updates reactively,
+  - and updates an output (`txt`) reactively. 
+  
+It would be nice to write tests that confirm that the module behaves the way we expect. We can do so using the `testModule` function.
+
+```{r}
+testModule(module, {
+  cat("Initially, input$x is NULL, right?", is.null(input$x), "\n")
+  
+  # Give input$x a value.
+  session$setInputs(x = 1)
+  
+  cat("Now that x is set to 1, rv$x is: ", rv$x, "\n")
+  cat("\tand output$txt is: ", output$txt, "\n")
+
+  # Now update input$x to a new value
+  session$setInputs(x = 2)
+  
+  cat("After updating x to 2, rv$x is: ", rv$x, "\n")
+  cat("\tand output$txt is: ", output$txt, "\n")
+})
+```
+
+There are a few things to notice in this example. 
+
+First, the test expression provided here assumes the existence of some variables -- specifically, `input`, `output`, and `r`. This is safe because the test code provided to `testModule` is run in the module's environment. This means that any parameters passed in to your module (such as `input`, `output`, and `session`) are readily available, as are any intermediate objects or reactives that you define in the module (such as `r`).
+
+Second, you'll need to give values to any inputs that you want to be defined; by default, they're all `NULL`. We do that using the `session$setInputs()` method. The `session` object used in `testModule` differs from the real `session` object Shiny uses; this allows us to tailor it to be more suitable for testing purposes by modifying or creating new methods such as `setInputs()`.
+
+Last, you're likely used to assigning to `output`, but here we're reading from `output$txt` in order to check its value. When running inside `testModule`, you can simply reference an output and it will give the value produced by the `render` function.
+
+## Automated Tests
+
+Realistically, we don't want to just print the values for manual inspection; we'll want to leverage them in automated tests. That way, we'll be able to build up a collection of tests that we can run against our module in the future to confirm that it always behaves correctly. You can use whatever testing framework you'd like (or none a all!), but we'll use the `expect_*` functions from the testthat package in this example.
+
+```{r}
+# Bring in testthat just for its expectations
+suppressWarnings(library(testthat))
+
+testModule(module, {
+  session$setInputs(x = 1)
+  expect_equal(rv$x, 2)
+  expect_equal(output$txt, "Value: 2")
+
+  session$setInputs(x = 2)
+  expect_equal(rv$x, 4)
+  expect_equal(output$txt, "Value: 4")
+})
+```
+
+If there's no error, then we know our tests ran successfully. If there were a bug, we'd see an error printed. For example:
+
+```{r}
+tryCatch({
+  testModule(module, {
+    session$setInputs(x = 1)
+    
+    # This expectation will fail
+    expect_equal(rv$x, 99)
+  })
+}, error=function(e){
+  print("There was an error!")
+  print(e)
+})
+```
+
+## Promises
+
+`testModule` can handle promises inside of render functions.
+
+```{r}
+library(promises)
+library(future)
+plan(multisession)
+
+module <- function(input, output, session){
+  output$async <- renderText({
+    # Stash the value since you can't do reactivity inside of a promise. See 
+    # https://rstudio.github.io/promises/articles/shiny.html#shiny-specific-caveats-and-limitations
+    t <- input$times
+    
+    # A promise chain that repeats the letter A and then collapses it into a string.
+    future({ rep("A", times=t) }) %...>%
+      paste(collapse="")
+  })
+}
+
+testModule(module, {
+  session$setInputs(times = 3)
+  expect_equal(output$async, "AAA")
+  
+  session$setInputs(times = 5)
+  expect_equal(output$async, "AAAAA")
+})
+```
+
+As you can see, no special precautions were required for a `render` function that uses promises. Behind-the-scenes, the code in `testModule` will block when trying to read from an `output` that returned a promise. This allows you to interact with the outputs in your tests as if they were synchronous.
+
+TODO: What about internal reactives that are promise-based? We don't do anything special for them...
+
+## Modules with additional inputs
+
+`testModule` can also handle modules that accept additional arguments such as this one.
+
+```{r}
+module <- function(input, output, session, arg1, arg2){
+  output$txt1 <- renderText({ arg1 })
+  
+  output$txt2 <- renderText({ arg2 })
+}
+```
+
+Additional arguments should be passed after the test expression as named parameters.
+
+```{r}
+testModule(module, {
+  expect_equal(output$txt1, "val1")
+  expect_equal(output$txt2, "val2")
+}, arg1="val1", arg2="val2")
+```
+
+## Accessing a module's returned value
+
+Some modules return reactive data as an output. For such modules, it can be helpful to test the returned value, as well. The returned value from the module is made available as a property on the mock `session` object as demonstrated in this example.
+
+```{r}
+module <- function(input, output, session){
+    reactive({
+      return(input$a + input$b)
+    })
+  }
+
+  testModule(module, {
+    session$setInputs(a = 1, b = 2)
+    expect_equal(session$returned(), 3)
+
+    # And retains reactivity
+    session$setInputs(a = 2)
+    expect_equal(session$returned(), 4)
+  })
+```
+
+## Timer and Polling
+
+Testing behavior that relies on timing is notoriously difficult. Modules will behave differently on different machines and under different conditions. In order to make testing with time more deterministic, `testModule` uses simulated time that you control, rather than the actual computer time. Let's look at what happens when you try to use "real" time in your testing.
+
+```{r}
+module <- function(input, output, session){
+  rv <- reactiveValues(x=0)
+  
+  observe({
+    invalidateLater(100)
+    isolate(rv$x <- rv$x + 1)
+  })
+}
+
+testModule(module, {
+  expect_equal(rv$x, 1) # The observer runs once at initialization
+  
+  Sys.sleep(1) # Sleep for a second
+  
+  expect_equal(rv$x, 1) # The value hasn't changed
+})
+```
+
+This behavior may be surprising. It seems like `rv$x` should have been incremented 10 times (or perhaps 9, due to computational overhead). But in truth, it hasn't changed at all. This is because `testModule` doesn't consider the actual time on your computer -- only its simulated understanding of time.
+
+In order to cause `testModule` to progress through time, instead of `Sys.sleep`, we'll use `session$elapse` -- another method that exists only on our mocked session object. Using the same module object as above...
+
+```{r}
+testModule(module, {
+  expect_equal(rv$x, 1) # The observer runs once at initialization
+  
+  session$elapse(100) # Simulate the passing of 100ms
+  
+  expect_equal(rv$x, 2) # The observer was invalidated and the value updated!
+  
+  # You can even simulate multiple events in a single elapse
+  session$elapse(300)
+  expect_equal(rv$x, 5)
+})
+```
+
+As you can see, using `session$elapse` caused `testModule` to recognize that (simulted) time had passed which triggered the reactivity as we'd expect. This approach allows you to deterministically control time in your tests while avoiding expensive pauses that would slow down your tests. Using this approach, this test can complete in only a fraction of the 100ms that it simulates.
+
+## Complex Outputs (plots, htmlwidgets)
+
+**Work in progress** -- We intend to add more helpers to make it easier to inspect and validate the raw HTML/JSON content. But for now, validating the output is an exercise left to the user.
+
+Thus far, we've seen how to validate simple outputs like numeric or text values. Real Shiny modules applications often use more complex outputs such as plots or htmlwidgets. Validating the correctness of these is not as simple, but is doable.
+
+You can access the data for even complex outputs in `testModule`, but the structure of the output may initially be foreign to you.
+
+```{r}
+module <- function(input, output, session){
+  output$plot <- renderPlot({
+    df <- data.frame(length = iris$Petal.Length, width = iris$Petal.Width)
+    plot(df)
+  })
+}
+
+testModule(module, {
+  print(str(output$plot))
+})
+```
+
+As you can see, there are a lot of internal details that go into a plot. Behind-the-scenes, these are all the details that Shiny will use to correctly display a plot in a user's browser. You don't need to learn about all of these properties -- and they're all subject to change. 
+
+In terms of your testing strategy, you shouldn't bother yourself with "is Shiny generating the correct structure so that the plot will generate in the browser?" That's a question that the Shiny package itself needs to answer (and one for which we have our own tests). The goal for your tests should be to ask: "is the code that I wrote producing the plot I want?" There are two components to that question:
+
+1. Does the plot generate without producing an error?
+2. Is the plot visually correct?
+
+`testModule` is great for assessing the first component here. By merely referencing `output$plot` in your test, you'll confirm that the plot was generated without an error. The second component is better suited for a shinytest test which actually loads the Shiny app in a headless browser and confirms that the content visually appears the same as it did previously. Doing this kind of test in `testModule` would be complex and may not be reliable as graphics devices differ slightly from platform to platform; i.e. the exact bits in the `src` field of your plot will not necessarily be reproducible between different versions of R or different operating systems.
+
+For htmlwidgets, you can adopt a similar strategy. The goal is not to confirm that the htmlwidget's render function is behaving properly -- but rather that the data that you intend to render is indeed getting rendered properly.
+
+We could modify the above example to better represent this approach.
+
+```{r}
+module <- function(input, output, session){
+  # Move any complex logic into a separate reactive which can be tested comprehensively
+  plotData <- reactive({
+    data.frame(length = iris$Petal.Length, width = iris$Petal.Width)
+  })
+  
+  # And leave the `render` function to be as simple as possible to lessen the need for 
+  # integration tests.
+  output$plot <- renderPlot({
+    plot(plotData())
+  })
+}
+
+testModule(module, {
+  # Confirm that the data reactive is behaving as expected
+  expect_equal(nrow(plotData()), 150)
+  expect_equal(ncol(plotData()), 2)
+  expect_equal(colnames(plotData()), c("length", "width"))
+  
+  # And now the plot function is so simple that there's not much need for 
+  # automated testing. If we did wish to evaluate the plot visually, we could
+  # do so using the shinytest package.
+  output$plot # Just confirming that the plot can be accessed without an error
+})
+```
+
+You could adopt a similar strategy with other plots or htmlwidgets: move the complexity into reactives that can be tested, and leave the complex `render` functions as simple as possible.
+
+## Testing Shiny Applications
+
+In addition to testing Shiny modules, you can also test Shiny applications. The `testServer` function will automatically extract the server portion given an application's directory and you can test it just like you do any other module.
+
+```{r}
+appdir <- system.file("examples/06_tabsets", package="shiny")
+testServer({
+  session$setInputs(dist="norm", n=10)
+  expect_equal(length(d()), 10)
+}, appdir)
+```
+
+As you can see, the test expression can be run for Shiny servers just like it was run for modules.