moduleServer/testServer overhaul

DESCRIPTION

@@ -171,7 +171,7 @@ Collate:
     'snapshot.R'
     'tar.R'
     'test-export.R'
-    'test-module.R'
+    'test-server.R'
     'test.R'
     'update-input.R'
 RoxygenNote: 7.1.0

NAMESPACE

@@ -263,7 +263,6 @@ export(tagHasAttribute)
 export(tagList)
 export(tagSetChildren)
 export(tags)
-export(testModule)
 export(testServer)
 export(textAreaInput)
 export(textInput)
@@ -354,4 +353,3 @@ importFrom(htmltools,validateCssUnit)
 importFrom(htmltools,withTags)
 importFrom(promises,"%...!%")
 importFrom(promises,"%...>%")
-importFrom(withr,with_options)

R/mock-session.R

@@ -83,6 +83,8 @@ MockShinySession <- R6Class(
   public = list(
     #' @field env The environment associated with the session.
     env = NULL,
+    #' @field returned The value returned by the module.
+    returned = NULL,
     #' @field singletons Hardcoded as empty. Needed for rendering HTML (i.e. renderUI)
     singletons = character(0),
     #' @field clientData Mock client data that always returns a size for plots
@@ -390,6 +392,13 @@ MockShinySession <- R6Class(
         output = structure(.createOutputWriter(self, ns = ns), class = "shinyoutput"),
         makeScope = function(namespace) self$makeScope(ns(namespace))
       )
+    },
+    # If assigning to `returned`, proactively flush
+    #' @param value The value returned from the module
+    setReturned = function(value) {
+      self$returned <- value
+      private$flush()
+      value
     }
   ),
   private = list(
@@ -400,7 +409,6 @@ MockShinySession <- R6Class(
     timer = NULL,
     closed = FALSE,
     outs = list(),
-    returnedVal = NULL,
 
     flush = function(){
       isolate(private$flushCBs$invoke(..stacktraceon = TRUE))
@@ -410,18 +418,6 @@ MockShinySession <- R6Class(
     }
   ),
   active = list(
-    # If assigning to `returned`, proactively flush
-    #' @field returned The value returned from the module
-    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()
-    },
     #' @field request An empty environment where the request should be. The request isn't meaningfully mocked currently.
     request = function(value) {
       if (!missing(value)){

R/modules.R

@@ -132,7 +132,11 @@ createSessionProxy <- function(parentSession, ...) {
 #'
 #' @export
 moduleServer <- function(id, module, session = getDefaultReactiveDomain()) {
-  callModule(module, id, session = session)
+  if (inherits(session, "MockShinySession")) {
+    testCallModule(module, id, session)
+  } else {
+    callModule(module, id, session = session)
+  }
 }
 
 

R/test-server.R

@@ -0,0 +1,138 @@
+#' @noRd
+testCallModule <- function(module, id, session) {
+  # TODO alan Figure out what to do with id here, necessary for nested usage?
+  body(module) <- rlang::expr({
+    session$env <- base::environment()
+    !!!body(module)
+  })
+
+  session$setReturned(do.call(module, list(
+    input = session$input,
+    output = session$output,
+    session = session
+  )))
+}
+
+# Create a "data mask" suitable for passing to rlang::eval_tidy. Bindings in
+# `env` and bindings in the parent of `env` are merged into a single named list.
+# Bindings in `env` take precedence over bindings in the parent of `env`.
+#' @noRd
+makeMask <- function(env) {
+  stopifnot(length(rlang::env_parents(env)) > 1)
+  stopifnot(all(c("input", "output", "session") %in% ls(env)))
+  child <- as.list(env)
+  parent <- as.list(rlang::env_parent(env))
+  parent_only <- setdiff(names(parent), names(child))
+  append(child, parent[parent_only])
+}
+
+#' @noRd
+isModuleServer <- function(x) {
+  is.function(x) && names(formals(x))[1] == "id"
+}
+
+#' @noRd
+coercableToAppObj <- function(x) {
+  !is.null(getS3method("as.shiny.appobj", class(x), optional = TRUE))
+}
+
+#' Reactive testing for Shiny server functions and modules
+#'
+#' A way to test the reactive interactions in Shiny applications. Reactive
+#' interactions are defined in the server function of applications and in
+#' modules.
+#' @param app The path to an application or module to test. In addition to
+#'   paths, applications may be represented by any object suitable for coercion
+#'   to an `appObj` by `as.shiny.appobj`. Application server functions must
+#'   include a `session` argument in order to be tested.
+#' @param expr Test code containing expectations. The test expression will run
+#'   in the server function environment, meaning that the parameters of the
+#'   server function (e.g. `input`, `output`, and `session`) will be available
+#'   along with any other values created inside of the server function.
+#' @param ... Additional arguments to pass to the module function. These
+#'   arguments are processed with [rlang::list2()] and so are
+#'   _[dynamic][rlang::dyn-dots]_.
+#' @return The result of evaluating `expr`.
+#' @include mock-session.R
+#' @rdname testServer
+#' @examples
+#' server <- function(id, multiplier = 2, prefix = "I am ") {
+#'   moduleServer(id, function(input, output, session) {
+#'     myreactive <- reactive({
+#'       input$x * multiplier
+#'     })
+#'     output$txt <- renderText({
+#'       paste0(prefix, myreactive())
+#'     })
+#'   })
+#' }
+#'
+#' # Basic Usage
+#' # -----------
+#' testServer(server, {
+#'   session$setInputs(x = 1)
+#'   # You're also free to use third-party
+#'   # testing packages like testthat:
+#'   #   expect_equal(myreactive(), 2)
+#'   stopifnot(myreactive() == 2)
+#'   stopifnot(output$txt == "I am 2")
+#'
+#'   session$setInputs(x = 2)
+#'   stopifnot(myreactive() == 4)
+#'   stopifnot(output$txt == "I am 4")
+#'   # Any additional arguments, below, are passed along to the module.
+#' }, multiplier = 2)
+#'
+#' # Advanced Usage
+#' # --------------
+#' multiplier_arg_name = "multiplier"
+#' more_args <- list(prefix = "I am ")
+#' testServer(server, {
+#'   session$setInputs(x = 1)
+#'   stopifnot(myreactive() == 2)
+#'   stopifnot(output$txt == "I am 2")
+#'   # !!/:= and !!! from rlang are used below to splice computed arguments
+#'   # into the testModule() argument list.
+#' }, !!multiplier_arg_name := 2, !!!more_args)
+#' @export
+testServer <- function(app, expr, ...) {
+
+  session <- MockShinySession$new()
+  on.exit(if (!session$isClosed()) session$close())
+
+  if (coercableToAppObj(app)) {
+    appobj <- as.shiny.appobj(app)
+    server <- appobj$serverFuncSource()
+    if (! "session" %in% names(formals(server)))
+      stop("Tested application server functions must declare input, output, and session arguments.")
+    body(server) <- rlang::expr({
+      session$env <- base::environment()
+      !!!body(server)
+    })
+    app <- function() {
+      session$setReturned(server(input = session$input, output = session$output, session = session))
+    }
+  } else if (!isModuleServer(app)) {
+    stop("app argument must be a module function or coercable by as.shiny.appobj")
+  }
+
+
+  isolate(
+    withReactiveDomain(
+      session,
+      withr::with_options(list(`shiny.allowoutputreads` = TRUE), {
+        rlang::exec(app, ...)
+      })
+    )
+  )
+
+  quosure <- rlang::enquo(expr)
+  isolate(
+    withReactiveDomain(
+      session,
+      withr::with_options(list(`shiny.allowoutputreads`=TRUE), {
+        rlang::eval_tidy(quosure, makeMask(session$env), rlang::caller_env())
+      })
+    )
+  )
+}