Merge pull request #2682 from rstudio/jeff/int-test

Introduce integration testing framework

DESCRIPTION

@@ -78,7 +78,8 @@ Imports:
     tools,
     crayon,
     rlang (>= 0.4.0),
-    fastmap (>= 1.0.0)
+    fastmap (>= 1.0.0),
+    withr
 Suggests:
     datasets,
     Cairo (>= 1.5-5),
@@ -89,7 +90,9 @@ Suggests:
     ggplot2,
     reactlog (>= 1.0.0),
     magrittr,
-    yaml
+    yaml,
+    future,
+    dygraphs
 URL: http://shiny.rstudio.com
 BugReports: https://github.com/rstudio/shiny/issues
 Collate:
@@ -164,6 +167,7 @@ Collate:
     'snapshot.R'
     'tar.R'
     'test-export.R'
+    'test-module.R'
     'update-input.R'
 RoxygenNote: 6.1.1
 Encoding: UTF-8

NAMESPACE

@@ -37,6 +37,7 @@ export("conditionStackTrace<-")
 export(..stacktraceoff..)
 export(..stacktraceon..)
 export(HTML)
+export(MockShinySession)
 export(NS)
 export(Progress)
 export(a)
@@ -260,6 +261,8 @@ export(tagHasAttribute)
 export(tagList)
 export(tagSetChildren)
 export(tags)
+export(testModule)
+export(testServer)
 export(textAreaInput)
 export(textInput)
 export(textOutput)
@@ -311,3 +314,4 @@ importFrom(grDevices,dev.cur)
 importFrom(grDevices,dev.set)
 importFrom(promises,"%...!%")
 importFrom(promises,"%...>%")
+importFrom(withr,with_options)

R/mock-session.R

@@ -69,7 +69,9 @@ extract <- function(promise) {
   stop("Single-bracket indexing of mockclientdata is not allowed.")
 }
 
+#' Mock Shiny Session
 #' @include timer.R
+#' @export
 MockShinySession <- R6Class(
   'MockShinySession',
   portable = FALSE,

R/test-module.R

@@ -0,0 +1,109 @@
+
+
+#' Test a shiny module
+#' @param module The module to 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 ... 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, ...)
+}
+
+#' @noRd
+#' @importFrom withr with_options
+.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
+
+  # Create a mock session
+  session <- MockShinySession$new()
+
+  # Parse the additional arguments
+  args <- list(..., input = session$input, output = session$output, 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, new.env(parent=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
+  }
+
+  # 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")
+    }
+  }
+}

inst/_pkgdown.yml

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

tests/test-modules/06_tabsets/app.R

@@ -0,0 +1,94 @@
+library(shiny)
+
+global <- 123
+
+# Define UI for random distribution app ----
+ui <- fluidPage(
+
+  # App title ----
+  titlePanel("Tabsets"),
+
+  # Sidebar layout with input and output definitions ----
+  sidebarLayout(
+
+    # Sidebar panel for inputs ----
+    sidebarPanel(
+
+      # Input: Select the random distribution type ----
+      radioButtons("dist", "Distribution type:",
+                   c("Normal" = "norm",
+                     "Uniform" = "unif",
+                     "Log-normal" = "lnorm",
+                     "Exponential" = "exp")),
+
+      # br() element to introduce extra vertical spacing ----
+      br(),
+
+      # Input: Slider for the number of observations to generate ----
+      sliderInput("n",
+                  "Number of observations:",
+                  value = 500,
+                  min = 1,
+                  max = 1000)
+
+    ),
+
+    # Main panel for displaying outputs ----
+    mainPanel(
+
+      # Output: Tabset w/ plot, summary, and table ----
+      tabsetPanel(type = "tabs",
+                  tabPanel("Plot", plotOutput("plot")),
+                  tabPanel("Summary", verbatimTextOutput("summary")),
+                  tabPanel("Table", tableOutput("table"))
+      )
+
+    )
+  )
+)
+
+# Define server logic for random distribution app ----
+server <- function(input, output) {
+
+  # Reactive expression to generate the requested distribution ----
+  # This is called whenever the inputs change. The output functions
+  # defined below then use the value computed from this expression
+  d <- reactive({
+    dist <- switch(input$dist,
+                   norm = rnorm,
+                   unif = runif,
+                   lnorm = rlnorm,
+                   exp = rexp,
+                   rnorm)
+
+    dist(input$n)
+  })
+
+  # Generate a plot of the data ----
+  # Also uses the inputs to build the plot label. Note that the
+  # dependencies on the inputs and the data reactive expression are
+  # both tracked, and all expressions are called in the sequence
+  # implied by the dependency graph.
+  output$plot <- renderPlot({
+    dist <- input$dist
+    n <- input$n
+
+    hist(d(),
+         main = paste("r", dist, "(", n, ")", sep = ""),
+         col = "#75AADB", border = "white")
+  })
+
+  # Generate a summary of the data ----
+  output$summary <- renderPrint({
+    summary(d())
+  })
+
+  # Generate an HTML table view of the data ----
+  output$table <- renderTable({
+    d()
+  })
+
+}
+
+# Create Shiny app ----
+shinyApp(ui, server)

tests/test-modules/server_r/server.R

@@ -0,0 +1,44 @@
+library(shiny)
+
+# Define server logic for random distribution app ----
+function(input, output) {
+
+  # Reactive expression to generate the requested distribution ----
+  # This is called whenever the inputs change. The output functions
+  # defined below then use the value computed from this expression
+  d <- reactive({
+    dist <- switch(input$dist,
+                   norm = rnorm,
+                   unif = runif,
+                   lnorm = rlnorm,
+                   exp = rexp,
+                   rnorm)
+
+    dist(input$n)
+  })
+
+  # Generate a plot of the data ----
+  # Also uses the inputs to build the plot label. Note that the
+  # dependencies on the inputs and the data reactive expression are
+  # both tracked, and all expressions are called in the sequence
+  # implied by the dependency graph.
+  output$plot <- renderPlot({
+    dist <- input$dist
+    n <- input$n
+
+    hist(d(),
+         main = paste("r", dist, "(", n, ")", sep = ""),
+         col = "#75AADB", border = "white")
+  })
+
+  # Generate a summary of the data ----
+  output$summary <- renderPrint({
+    summary(d())
+  })
+
+  # Generate an HTML table view of the data ----
+  output$table <- renderTable({
+    d()
+  })
+
+}