document

Remove deprecated arguments from plotOutput/imageOuput

.travis.yml

@@ -6,7 +6,11 @@ matrix:
       r_packages:
         - devtools
         - rprojroot
-      script: ./tools/checkDocsCurrent.sh
+      script: ./tools/documentation/checkDocsCurrent.sh
+      env:
+        # GITHUB_PAT for gh::gh calls
+        - secure: "Hk4piVNtDobLT1dQPnCOcM7sOlwNGJOU5cpvbRvOxYSgxP+Bj2MyRZMe825rdHkHbFez0h8w3tJOBf9DDBH7PC1BhhNll2+WM/WxGlkNleg8vsoH/Xopffl+2YgtWbAYZjQ2j0QYdgNn0e/TY86/ggk9qit6+gpsZ7z/HmWQuVY="
+
     - name: "Javascript check"
       language: node_js
       cache: yarn

DESCRIPTION

@@ -79,7 +79,9 @@ Imports:
     crayon,
     rlang (>= 0.4.0),
     fastmap (>= 1.0.0),
-    withr
+    withr,
+    commonmark (>= 1.7),
+    glue (>= 1.3.2)
 Suggests:
     datasets,
     Cairo (>= 1.5-5),
@@ -95,11 +97,13 @@ Suggests:
     future,
     dygraphs
 Remotes:
-    rstudio/htmltools
+    rstudio/htmltools,
+    rstudio/shinytest
 URL: http://shiny.rstudio.com
 BugReports: https://github.com/rstudio/shiny/issues
 Collate:
     'app.R'
+    'app_template.R'
     'bookmark-state-local.R'
     'stack.R'
     'bookmark-state.R'
@@ -155,6 +159,7 @@ Collate:
     'priorityqueue.R'
     'progress.R'
     'react.R'
+    'reexports.R'
     'render-cached-plot.R'
     'render-plot.R'
     'render-table.R'
@@ -170,9 +175,9 @@ Collate:
     'snapshot.R'
     'tar.R'
     'test-export.R'
-    'test-module.R'
+    'test-server.R'
     'test.R'
     'update-input.R'
-RoxygenNote: 7.0.2
+RoxygenNote: 7.1.0
 Encoding: UTF-8
 Roxygen: list(markdown = TRUE)

NAMESPACE

@@ -142,8 +142,10 @@ export(loadSupport)
 export(mainPanel)
 export(makeReactiveBinding)
 export(markRenderFunction)
+export(markdown)
 export(maskReactiveContext)
 export(memoryCache)
+export(migrateLegacyShinytest)
 export(modalButton)
 export(modalDialog)
 export(moduleServer)
@@ -229,6 +231,7 @@ export(setSerializer)
 export(shinyApp)
 export(shinyAppDir)
 export(shinyAppFile)
+export(shinyAppTemplate)
 export(shinyOptions)
 export(shinyServer)
 export(shinyUI)
@@ -263,7 +266,6 @@ export(tagHasAttribute)
 export(tagList)
 export(tagSetChildren)
 export(tags)
-export(testModule)
 export(testServer)
 export(textAreaInput)
 export(textInput)
@@ -272,6 +274,7 @@ export(throttle)
 export(titlePanel)
 export(uiOutput)
 export(updateActionButton)
+export(updateActionLink)
 export(updateCheckboxGroupInput)
 export(updateCheckboxInput)
 export(updateDateInput)
@@ -314,6 +317,43 @@ importFrom(fastmap,is.key_missing)
 importFrom(fastmap,key_missing)
 importFrom(grDevices,dev.cur)
 importFrom(grDevices,dev.set)
+importFrom(htmltools,HTML)
+importFrom(htmltools,a)
+importFrom(htmltools,br)
+importFrom(htmltools,code)
+importFrom(htmltools,div)
+importFrom(htmltools,em)
+importFrom(htmltools,h1)
+importFrom(htmltools,h2)
+importFrom(htmltools,h3)
+importFrom(htmltools,h4)
+importFrom(htmltools,h5)
+importFrom(htmltools,h6)
+importFrom(htmltools,hr)
+importFrom(htmltools,htmlTemplate)
+importFrom(htmltools,img)
+importFrom(htmltools,includeCSS)
+importFrom(htmltools,includeHTML)
+importFrom(htmltools,includeMarkdown)
+importFrom(htmltools,includeScript)
+importFrom(htmltools,includeText)
+importFrom(htmltools,is.singleton)
+importFrom(htmltools,p)
+importFrom(htmltools,pre)
+importFrom(htmltools,singleton)
+importFrom(htmltools,span)
+importFrom(htmltools,strong)
+importFrom(htmltools,suppressDependencies)
+importFrom(htmltools,tag)
+importFrom(htmltools,tagAppendAttributes)
+importFrom(htmltools,tagAppendChild)
+importFrom(htmltools,tagAppendChildren)
+importFrom(htmltools,tagGetAttribute)
+importFrom(htmltools,tagHasAttribute)
+importFrom(htmltools,tagList)
+importFrom(htmltools,tagSetChildren)
+importFrom(htmltools,tags)
+importFrom(htmltools,validateCssUnit)
+importFrom(htmltools,withTags)
 importFrom(promises,"%...!%")
 importFrom(promises,"%...>%")
-importFrom(withr,with_options)

NEWS.md

@@ -7,8 +7,16 @@ shiny 1.4.0.9001
 
 ### New features
 
+* The new `shinyAppTemplate()` function creates a new template Shiny application, where components are optional, such as helper files in an R/ subdirectory, a module, and various kids of tests. ([#2704](https://github.com/rstudio/shiny/pull/2704))
+
+* `runTests()` is a new function that behaves much like R CMD check. `runTests()` invokes all of the top-level R files in the tests/ directory inside an application, in that application's environment. ([#2585](https://github.com/rstudio/shiny/pull/2585))
+
+* `testServer()` and `testModule()` are two new functions for testing reactive behavior inside server functions and modules, respectively. ([#2682](https://github.com/rstudio/shiny/pull/2682), [#2764](https://github.com/rstudio/shiny/pull/2764))
+
 * The new `moduleServer` function provides a simpler interface for creating and using modules. ([#2773](https://github.com/rstudio/shiny/pull/2773))
 
+* Resolved [#2732](https://github.com/rstudio/shiny/issues/2732): `markdown()` is a new function for writing Markdown with Github extensions directly in Shiny UIs. Markdown rendering is performed by the [commonmark](https://github.com/jeroen/commonmark) package. ([#2737](https://github.com/rstudio/shiny/pull/2737))
+
 ### Minor new features and improvements
 
 * Fixed [#2042](https://github.com/rstudio/shiny/issues/2042), [#2628](https://github.com/rstudio/shiny/issues/2628): In a `dateInput` and `dateRangeInput`, disabled months and years are now a lighter gray, to make it easier to see that they are disabled. ([#2690](https://github.com/rstudio/shiny/pull/2690))
@@ -19,6 +27,10 @@ shiny 1.4.0.9001
 
 * `getDefaultReactiveDomain()` can now be called inside a `session$onSessionEnded` callback and will return the calling `session` information. ([#2757](https://github.com/rstudio/shiny/pull/2757))
 
+* Added a `'function'` class to `reactive()` and `reactiveVal()` objects. ([#2793](https://github.com/rstudio/shiny/pull/2793))
+
+* Added function `updateActionLink()` to update an `actionLink()` label and/or icon value. ([#2811](https://github.com/rstudio/shiny/pull/2811))
+
 ### Bug fixes
 
 * Fixed [#2606](https://github.com/rstudio/shiny/issues/2606): `debounce()` would not work properly if the code in the reactive expression threw an error on the first run. ([#2652](https://github.com/rstudio/shiny/pull/2652))
@@ -28,6 +40,18 @@ shiny 1.4.0.9001
 ### Documentation Updates
 
 
+shiny 1.4.0.2
+===========
+
+Minor patch release: fixed some timing-dependent tests failed intermittently on CRAN build machines.
+
+
+shiny 1.4.0.1
+===========
+
+Minor patch release to account for changes to the grid package that will be upcoming in the R 4.0 release ([#2776](https://github.com/rstudio/shiny/pull/2776)).
+
+
 shiny 1.4.0
 ===========
 

R/app.R

@@ -325,37 +325,49 @@ initAutoReloadMonitor <- function(dir) {
 #' @details The files are sourced in alphabetical order (as determined by
 #'   [list.files]). `global.R` is evaluated before the supporting R files in the
 #'   `R/` directory.
-#' @param appDir The application directory
+#' @param appDir The application directory. If `appDir` is `NULL` or
+#'   not supplied, the nearest enclosing directory that is a Shiny app, starting
+#'   with the current directory, is used.
 #' @param renv The environmeny in which the files in the `R/` directory should
 #'   be evaluated.
 #' @param globalrenv The environment in which `global.R` should be evaluated. If
 #'   `NULL`, `global.R` will not be evaluated at all.
 #' @export
-loadSupport <- function(appDir, renv=new.env(parent=globalenv()), globalrenv=globalenv()){
+loadSupport <- function(appDir=NULL, renv=new.env(parent=globalenv()), globalrenv=globalenv()){
+  require(shiny)
+
+  if (is.null(appDir)) {
+    appDir <- findEnclosingApp(".")
+  }
+
   if (!is.null(globalrenv)){
     # Evaluate global.R, if it exists.
-    if (file.exists(file.path.ci(appDir, "global.R"))){
-      sourceUTF8(file.path.ci(appDir, "global.R"), envir=globalrenv)
+    globalPath <- file.path.ci(appDir, "global.R")
+    if (file.exists(globalPath)){
+      withr::with_dir(appDir, {
+        sourceUTF8(basename(globalPath), envir=globalrenv)
+      })
     }
   }
 
+
   helpersDir <- file.path(appDir, "R")
 
   disabled <- list.files(helpersDir, pattern="^_disable_autoload\\.r$", recursive=FALSE, ignore.case=TRUE)
   if (length(disabled) > 0){
-    message("R/_disable_autoload.R detected; not loading the R/ directory automatically")
     return(invisible(renv))
   }
 
   helpers <- list.files(helpersDir, pattern="\\.[rR]$", recursive=FALSE, full.names=TRUE)
+  # Ensure files in R/ are sorted according to the 'C' locale before sourcing.
+  # This convention is based on the default for packages. For details, see:
+  # https://cran.r-project.org/doc/manuals/r-release/R-exts.html#The-DESCRIPTION-file
+  helpers <- sort(helpers, method = "radix")
+  helpers <- normalizePath(helpers)
 
-  if (length(helpers) > 0){
-    message("Automatically loading ", length(helpers), " .R file",
-            ifelse(length(helpers) != 1, "s", ""),
-            " found in the R/ directory.\nSee https://rstd.io/shiny-autoload for more info.")
-  }
-
-  lapply(helpers, sourceUTF8, envir=renv)
+  withr::with_dir(appDir, {
+    lapply(helpers, sourceUTF8, envir=renv)
+  })
 
   invisible(renv)
 }

R/app_template.R

@@ -0,0 +1,283 @@
+#' Generate a Shiny application from a template
+#'
+#' This function populates a directory with files for a Shiny application.
+#'
+#' In an interactive R session, this function will, by default, prompt the user
+#' which components to add to the application.
+#'
+#' The full example application includes the following files and directories:
+#'
+#' ```
+#' appdir/
+#' |- app.R
+#' |- R
+#' |   |- my-module.R
+#' |   `- sort.R
+#' `- tests
+#'     |- shinytest.R
+#'     |- shinytest
+#'     |   `- mytest.R
+#'     |- testthat.R
+#'     `- testthat
+#'         |- helper-load.R
+#'         |- test-mymodule.R
+#'         |- test-server.R
+#'         `- test-sort.R
+#' ```
+#'
+#' Some notes about these files:
+#' * `app.R` is the main application file.
+#' * All files in the `R/` subdirectory are automatically sourced when the
+#'   application is run.
+#' * `R/sort.R` and `R/my-module.R` are automatically sourced when
+#'   the application is run. The first contains a function `lexical_sort()`,
+#'   and the second contains code for a [Shiny module](moduleServer()) which
+#'   is used in the application.
+#' * `tests/` contains various tests for the application. You may
+#'   choose to use or remove any of them. They can be executed by the
+#'   [runTests()] function.
+#' * `tests/shinytest.R` is a test runner for test files in the
+#'   `tests/shinytest/` directory.
+#' * `tests/shinytest/mytest.R` is a test that uses the
+#'   [shinytest](https://rstudio.github.io/shinytest/) package to do
+#'   snapshot-based testing.
+#' * `tests/testthat.R` is a test runner for test files in the
+#'   `tests/testthat/` directory using the [testthat](https://testthat.r-lib.org/) package.
+#' * `tests/testthat/test-mymodule.R` is a test for an application's module server function.
+#' * `tests/testthat/test-server.R` is a test for the application's server code
+#' * `tests/testthat/test-sort.R` is a test for a supporting function in the `R/` directory.
+#'
+#' @param path Path to create new shiny application template.
+#' @param examples Either one of "default", "ask", "all", or any combination of
+#'   "app", "rdir", "module", "shinytest", and "testthat". In an
+#'   interactive session, "default" falls back to "ask"; in a non-interactive
+#'   session, "default" falls back to "all". With "ask", this function will
+#'   prompt the user to select which template items will be added to the new app
+#'   directory. With "all", all template items will be added to the app
+#'   directory.
+#' @param dryrun If `TRUE`, don't actually write any files; just print out what
+#'   would be written.
+#'
+#' @export
+shinyAppTemplate <- function(path = NULL, examples = "default", dryrun = FALSE)
+{
+  if (is.null(path)) {
+    stop("Please provide a `path`.")
+  }
+
+  # =======================================================
+  # Option handling
+  # =======================================================
+
+  choices <- c(
+    app       = "app.R            : Main application file",
+    rdir      = "R/sort.R         : Helper file with R code",
+    module    = "R/my-module.R    : Example module",
+    shinytest = "tests/shinytest/ : Tests using shinytest package",
+    testthat  = "tests/testthat/  : Tests using testthat"
+  )
+
+  if (identical(examples, "default")) {
+    if (interactive()) {
+      examples <- "ask"
+    } else {
+      examples <- "all"
+    }
+  }
+
+  if (!identical(examples, "ask") &&
+      !identical(examples, "all") &&
+      any(! examples %in% names(choices)))
+  {
+    stop('`examples` must be one of "default", "ask", "all", or any combination of "',
+      paste(names(choices), collapse = '", "'), '".')
+  }
+
+  if (identical(examples, "ask")) {
+    response <- select_menu(
+      c(all = "All", choices),
+      title = paste0(
+        "Select which of the following to add at ", path, "/ :"
+      ),
+      msg = "Enter one or more numbers (with spaces), or an empty line to exit: \n"
+    )
+
+    examples <- names(response)
+  }
+
+  examples <- unique(examples)
+
+  if ("all" %in% examples) {
+    examples <- names(choices)
+  }
+
+  if (length(examples) == 0) {
+    return(invisible())
+  }
+
+  if ("shinytest" %in% examples) {
+    if (system.file(package = "shinytest") != "" &&
+        utils::packageVersion("shinytest") <= "1.3.1.9000")
+    {
+      message(
+        "The tests/shinytest directory needs shinytest 1.4.0 or later to work properly.\n",
+      )
+      if (system.file(package = "shinytest") != "") {
+        message("You currently have shinytest ",
+                utils::packageVersion("shinytest"), " installed.")
+      }
+
+    }
+  }
+
+  # =======================================================
+  # Utility functions
+  # =======================================================
+
+  # Check if a directory is empty, ignoring certain files
+  dir_is_empty <- function(path) {
+    files <- list.files(path, all.files = TRUE, no.. = TRUE)
+    # Ignore .DS_Store files, which are sometimes automatically created on macOS
+    files <- setdiff(files, ".DS_Store")
+    return(length(files) != 0)
+  }
+
+  # Helper to resolve paths relative to our template
+  template_path <- function(...) {
+    system.file("app_template", ..., package = "shiny")
+  }
+
+  # Resolve path relative to destination
+  dest_path <- function(...) {
+    file.path(path, ...)
+  }
+
+  mkdir <- function(path) {
+    if (!dirExists(path)) {
+      message("Creating ", ensure_trailing_slash(path))
+      if (!dryrun) {
+        dir.create(path, recursive = TRUE)
+      }
+    }
+  }
+
+  # Copy a file from the template directory to the destination directory. If the
+  # file has templating code (it contains `{{` in the text), then run it through
+  # the htmlTemplate().
+  copy_file_one <- function(name) {
+    from <- template_path(name)
+    to <- dest_path(name)
+
+    message("Creating ", to)
+    if (file.exists(to)) {
+      stop(to, " already exists. Please remove it and try again.", call. = FALSE)
+    }
+
+    if (!dryrun) {
+      is_template <- any(grepl("{{", readLines(from), fixed = TRUE))
+
+      if (is_template) {
+        writeChar(
+          as.character(htmlTemplate(
+            from,
+            rdir = "rdir" %in% examples,
+            module = "module" %in% examples
+          )),
+          con = to,
+          eos = NULL
+        )
+      } else {
+        file.copy(from, to)
+      }
+    }
+  }
+
+  # Copy multiple files from template to destination.
+  copy_file <- function(names) {
+    for (name in names) {
+      copy_file_one(name)
+    }
+  }
+
+  # Copy the files for a tests/ subdirectory
+  copy_test_dir <- function(name) {
+    files <- dir(template_path("tests"), recursive = TRUE)
+    # Note: This is not the same as using dir(pattern = "^shinytest"), since
+    # that will not match files inside of shinytest/.
+    files <- files[grepl(paste0("^", name), files)]
+
+    # Filter out files that are not module files in the R directory.
+    if (! "rdir" %in% examples) {
+      # find all files in the testthat folder that are not module or server files
+      is_r_folder_file <- (!grepl("module|server", basename(files))) & (dirname(files) == "testthat")
+      files <- files[!is_r_folder_file]
+    }
+
+    # Filter out module files, if applicable.
+    if (! "module" %in% examples) {
+      files <- files[!grepl("module", files)]
+    }
+
+    mkdir(dest_path("tests"))
+
+    # Create any subdirectories if needed
+    dirs <- setdiff(unique(dirname(files)), ".")
+    for (dir in dirs) {
+      mkdir(dest_path("tests", dir))
+    }
+
+    copy_file(file.path("tests", files))
+  }
+
+  # =======================================================
+  # Main function
+  # =======================================================
+
+  if (is.null(path)) {
+    stop("`path` is missing.")
+  }
+  if (file.exists(path) && !dirExists(path)) {
+    stop(path, " exists but is not a directory.")
+  }
+
+  if (dirExists(path) && dir_is_empty(path)) {
+    if (interactive()) {
+      response <- readline(paste0(
+        ensure_trailing_slash(path),
+        " is not empty. Do you want to create a Shiny app in this directory anyway? [y/n] "
+      ))
+      if (tolower(response) != "y") {
+        return(invisible())
+      }
+    }
+  } else {
+    mkdir(path)
+  }
+
+  if ("app" %in% examples) {
+    copy_file("app.R")
+  }
+
+  # R/ dir with non-module files
+  if ("rdir" %in% examples) {
+    non_module_files <- dir(template_path("R"), pattern = "[^(module)].R$")
+    mkdir(dest_path("R"))
+    copy_file(file.path("R", non_module_files))
+  }
+
+  # R/ dir with module files
+  if ("module" %in% examples) {
+    module_files <- dir(template_path("R"), pattern = "module.R$")
+    mkdir(dest_path("R"))
+    copy_file(file.path("R", module_files))
+  }
+
+  # tests/ dir
+  if ("shinytest" %in% examples) {
+    copy_test_dir("shinytest")
+  }
+  if ("testthat" %in% examples) {
+    copy_test_dir("testthat")
+  }
+  invisible()
+}

R/bootstrap.R

@@ -842,42 +842,9 @@ verbatimTextOutput <- function(outputId, placeholder = FALSE) {
 #' @rdname plotOutput
 #' @export
 imageOutput <- function(outputId, width = "100%", height="400px",
-                        click = NULL, dblclick = NULL,
-                        hover = NULL, hoverDelay = NULL, hoverDelayType = NULL,
-                        brush = NULL,
-                        clickId = NULL, hoverId = NULL,
+                        click = NULL, dblclick = NULL, hover = NULL, brush = NULL,
                         inline = FALSE) {
 
-  if (!is.null(clickId)) {
-    shinyDeprecated(
-      msg = paste("The 'clickId' argument is deprecated. ",
-                  "Please use 'click' instead. ",
-                  "See ?imageOutput or ?plotOutput for more information."),
-      version = "0.11.1"
-    )
-    click <- clickId
-  }
-
-  if (!is.null(hoverId)) {
-    shinyDeprecated(
-      msg = paste("The 'hoverId' argument is deprecated. ",
-                  "Please use 'hover' instead. ",
-                  "See ?imageOutput or ?plotOutput for more information."),
-      version = "0.11.1"
-    )
-    hover <- hoverId
-  }
-
-  if (!is.null(hoverDelay) || !is.null(hoverDelayType)) {
-    shinyDeprecated(
-      msg = paste("The 'hoverDelay'and 'hoverDelayType' arguments are deprecated. ",
-                  "Please use 'hoverOpts' instead. ",
-                  "See ?imageOutput or ?plotOutput for more information."),
-      version = "0.11.1"
-    )
-    hover <- hoverOpts(id = hover, delay = hoverDelay, delayType = hoverDelayType)
-  }
-
   style <- if (!inline) {
     paste("width:", validateCssUnit(width), ";", "height:", validateCssUnit(height))
   }
@@ -984,14 +951,6 @@ imageOutput <- function(outputId, width = "100%", height="400px",
 #'   named list with `x` and `y` elements indicating the mouse
 #'   position. To control the hover time or hover delay type, you must use
 #'   [hoverOpts()].
-#' @param clickId Deprecated; use `click` instead. Also see the
-#'   [clickOpts()] function.
-#' @param hoverId Deprecated; use `hover` instead. Also see the
-#'   [hoverOpts()] function.
-#' @param hoverDelay Deprecated; use `hover` instead. Also see the
-#'   [hoverOpts()] function.
-#' @param hoverDelayType Deprecated; use `hover` instead. Also see the
-#'   [hoverOpts()] function.
 #' @param brush Similar to the `click` argument, this can be `NULL`
 #'   (the default), a string, or an object created by the
 #'   [brushOpts()] function. If you use a value like
@@ -1175,16 +1134,12 @@ imageOutput <- function(outputId, width = "100%", height="400px",
 #' }
 #' @export
 plotOutput <- function(outputId, width = "100%", height="400px",
-                       click = NULL, dblclick = NULL,
-                       hover = NULL, hoverDelay = NULL, hoverDelayType = NULL,
-                       brush = NULL,
-                       clickId = NULL, hoverId = NULL,
+                       click = NULL, dblclick = NULL, hover = NULL, brush = NULL,
                        inline = FALSE) {
 
   # Result is the same as imageOutput, except for HTML class
   res <- imageOutput(outputId, width, height, click, dblclick,
-                     hover, hoverDelay, hoverDelayType, brush,
-                     clickId, hoverId, inline)
+                     hover, brush, inline)
 
   res$attribs$class <- "shiny-plot-output"
   res

R/cache-utils.R

@@ -1,11 +1,3 @@
-#' @importFrom fastmap key_missing
-#' @export
-fastmap::key_missing
-
-#' @importFrom fastmap is.key_missing
-#' @export
-fastmap::is.key_missing
-
 
 validate_key <- function(key) {
   if (!is.character(key) || length(key) != 1 || nchar(key) == 0) {
@@ -15,4 +7,3 @@ validate_key <- function(key) {
     stop("Invalid key: ", key, ". Only lowercase letters and numbers are allowed.")
   }
 }
-

R/image-interact-opts.R

@@ -10,7 +10,7 @@
 #'   then the server will receive click events even when the mouse is outside
 #'   the plotting area, as long as it is still inside the image.
 #' @export
-clickOpts <- function(id = NULL, clip = TRUE) {
+clickOpts <- function(id, clip = TRUE) {
   if (is.null(id))
     stop("id must not be NULL")
 
@@ -36,7 +36,7 @@ clickOpts <- function(id = NULL, clip = TRUE) {
 #' @param delay Maximum delay (in ms) between a pair clicks for them to be
 #'   counted as a double-click.
 #' @export
-dblclickOpts <- function(id = NULL, clip = TRUE, delay = 400) {
+dblclickOpts <- function(id, clip = TRUE, delay = 400) {
   if (is.null(id))
     stop("id must not be NULL")
 
@@ -69,7 +69,7 @@ dblclickOpts <- function(id = NULL, clip = TRUE, delay = 400) {
 #'   `NULL` when the mouse exits the plotting area. If `FALSE`, the
 #'   value will stop changing when the cursor exits the plotting area.
 #' @export
-hoverOpts <- function(id = NULL, delay = 300,
+hoverOpts <- function(id, delay = 300,
                       delayType = c("debounce", "throttle"), clip = TRUE,
                       nullOutside = TRUE) {
   if (is.null(id))
@@ -117,7 +117,7 @@ hoverOpts <- function(id = NULL, delay = 300,
 #'   brush. Using `TRUE` is useful if you want to clear the brush whenever
 #'   the plot is updated.
 #' @export
-brushOpts <- function(id = NULL, fill = "#9cf", stroke = "#036",
+brushOpts <- function(id, fill = "#9cf", stroke = "#036",
                       opacity = 0.25, delay = 300,
                       delayType = c("debounce", "throttle"), clip = TRUE,
                       direction = c("xy", "x", "y"),

R/input-action.R

@@ -16,7 +16,7 @@
 #'
 #' ui <- fluidPage(
 #'   sliderInput("obs", "Number of observations", 0, 1000, 500),
-#'   actionButton("goButton", "Go!"),
+#'   actionButton("goButton", "Go!", class = "btn-success"),
 #'   plotOutput("distPlot")
 #' )
 #'
@@ -36,6 +36,10 @@
 #'
 #' }
 #'
+#' ## Example of adding extra class values
+#' actionButton("largeButton", "Large Primary Button", class = "btn-primary btn-lg")
+#' actionLink("infoLink", "Information Link", class = "btn-info")
+#'
 #' @seealso [observeEvent()] and [eventReactive()]
 #'
 #' @section Server value:

R/mock-session.R

@@ -70,16 +70,9 @@ extract <- function(promise) {
 }
 
 #' @noRd
-patchModuleFunction <- function(module) {
-  body(module) <- rlang::expr({
-    withr::with_options(base::list(`shiny.allowoutputreads` = TRUE), {
-      session$setEnv(base::environment())
-      session$setReturned({
-        !!!body(module)
-      })
-    })
-  })
-  module
+mapNames <- function(func, vals) {
+  names(vals) <- vapply(names(vals), func, character(1))
+  vals
 }
 
 #' Mock Shiny Session
@@ -96,6 +89,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
@@ -113,8 +108,7 @@ MockShinySession <- R6Class(
     userData = NULL,
     #' @field progressStack A stack of progress objects
     progressStack = 'Stack',
-    #' @field TRUE when a moduleServer()-based module is under test
-    isModuleServer = FALSE,
+
     #' @description Create a new MockShinySession
     initialize = function() {
       private$.input <- ReactiveValues$new(dedupe = FALSE, label = "input")
@@ -195,20 +189,35 @@ MockShinySession <- R6Class(
       return(paste('data:', contentType, ';base64,', b64, sep=''))
     },
 
-    #' @description Sets reactive values associated with the `session$inputs` object
-    #'   and flushes the reactives.
-    #' @param ... The inputs to set.
+    #' @description Sets reactive values associated with the `session$inputs`
+    #'   object and flushes the reactives.
+    #' @param ... The inputs to set. These arguments are processed with
+    #'   [rlang::list2()] and so are _[dynamic][rlang::dyn-dots]_. Input names
+    #'   may not be duplicated.
     #' @examples
-    #' s <- MockShinySession$new()
-    #' s$setInputs(x=1, y=2)
+    #' \dontrun{
+    #' session$setInputs(x=1, y=2)
+    #' }
     setInputs = function(...) {
-      vals <- list(...)
+      vals <- rlang::dots_list(..., .homonyms = "error")
       mapply(names(vals), vals, FUN = function(name, value) {
         private$.input$set(name, value)
       })
       private$flush()
     },
 
+    #' @description Simulates clicking an action button.
+    #' @param id The id of the button to click.
+    #' @examples
+    #' \dontrun{
+    #' session$click("button1")
+    #' }
+    click = function(id) {
+      val <- (private$.input$get(id) %OR% 0L) + 1L
+      self$setInputs(!!id := val)
+      val
+    },
+
     #' @description An internal method which shouldn't be used by others.
     #' @param millis The number of milliseconds on which to schedule a callback
     #' @param callback The function to schedule
@@ -385,47 +394,58 @@ MockShinySession <- R6Class(
     #' @param export Not used
     #' @param format Not used
     getTestSnapshotUrl = function(input=TRUE, output=TRUE, export=TRUE, format="json") {},
-    #' @description Returns the given id prefixed by `mock-session-`.
+    #' @description Returns the given id prefixed by this namespace's id.
     #' @param id The id to modify.
     ns = function(id) {
-      paste0("mock-session-", id) # TODO: does this need to be more complex/intelligent?
+      NS(private$nsPrefix, id)
     },
     #' @description Trigger a reactive flush right now.
     flushReact = function(){
       private$flush()
     },
-    setEnv = function(env) {
-      self$env <- env
-    },
-    setReturned = function(value) {
-      private$returnedVal <- value
-      private$flush()
-      value
-    },
     #' @description Create and return a namespace-specific session proxy.
     #' @param namespace Character vector indicating a namespace.
     makeScope = function(namespace) {
       ns <- NS(namespace)
-      proxy <- createSessionProxy(
+      createSessionProxy(
         self,
         input = .createReactiveValues(private$.input, readonly = TRUE, ns = ns),
         output = structure(.createOutputWriter(self, ns = ns), class = "shinyoutput"),
         makeScope = function(namespace) self$makeScope(ns(namespace)),
-        env = NULL,
-        returned = NULL,
-        setEnv = function(env) assign("env", env, envir = proxy),
-        setReturned = function(value) {
-          assign("returned", value, envir = proxy)
-          private$flush()
-          value
-        },
+        ns = function(namespace) ns(namespace),
+        click = function(id) self$click(ns(id)),
         setInputs = function(...) {
-          args <- list(...)
-          names(args) <- ns(names(args))
-          do.call(self$setInputs, args)
+          self$setInputs(!!!mapNames(ns, rlang::dots_list(..., .homonyms = "error")))
         }
       )
-      proxy
+    },
+    #' @description Set the environment associated with a testServer() call, but
+    #'   only if it has not previously been set. This ensures that only the
+    #'   environment of the outermost module under test is the one retained. In
+    #'   other words, the first assignment wins.
+    #' @param env The environment to retain.
+    setEnv = function(env) {
+      if (is.null(self$env)) {
+        stopifnot(all(c("input", "output", "session") %in% ls(env)))
+        self$env <- env
+      }
+    },
+    #' @description Set the value returned by the module call and proactively
+    #'   flush. Note that this method may be called multiple times if modules
+    #'   are nested. The last assignment, corresponding to an invocation of
+    #'   setReturned() in the outermost module, wins.
+    #' @param value The value returned from the module
+    setReturned = function(value) {
+      self$returned <- value
+      value
+    },
+    #' @description Get the value returned by the module call.
+    getReturned = function() self$returned,
+    #' @description Return a distinct character identifier for use as a proxy
+    #'   namespace.
+    genId = function() {
+      private$idCounter <- private$idCounter + 1
+      paste0("proxy", private$idCounter)
     }
   ),
   private = list(
@@ -436,7 +456,8 @@ MockShinySession <- R6Class(
     timer = NULL,
     closed = FALSE,
     outs = list(),
-    returnedVal = NULL,
+    nsPrefix = "mock-session",
+    idCounter = 0,
 
     flush = function(){
       isolate(private$flushCBs$invoke(..stacktraceon = TRUE))
@@ -446,18 +467,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)){
@@ -468,4 +477,3 @@ MockShinySession <- R6Class(
     }
   )
 )
-

R/modules.R

@@ -36,7 +36,6 @@ createSessionProxy <- function(parentSession, ...) {
 
 `[[<-.session_proxy` <- `$<-.session_proxy`
 
-
 #' Shiny modules
 #'
 #' Shiny's module feature lets you break complicated UI and server logic into
@@ -44,8 +43,9 @@ createSessionProxy <- function(parentSession, ...) {
 #' modules are easier to reuse and easier to reason about. See the article at
 #' <http://shiny.rstudio.com/articles/modules.html> to learn more.
 #'
-#' Starting in Shiny 1.5.0, we recommend using `moduleFunction` instead of
-#' `callModule`, because syntax is a little easier to understand.
+#' Starting in Shiny 1.5.0, we recommend using `moduleServer` instead of
+#' `callModule`, because the syntax is a little easier to understand, and
+#' modules created with `moduleServer` can be tested with [`testServer()`].
 #'
 #' @param module A Shiny module server function.
 #' @param id An ID string that corresponds with the ID used to call the module's
@@ -70,16 +70,19 @@ createSessionProxy <- function(parentSession, ...) {
 #'
 #' # Define the server logic for a module
 #' counterServer <- function(id) {
-#'   moduleServer(id, function(input, output, session) {
-#'     count <- reactiveVal(0)
-#'     observeEvent(input$button, {
-#'       count(count() + 1)
-#'     })
-#'     output$out <- renderText({
-#'       count()
-#'     })
-#'     count
-#'   })
+#'   moduleServer(
+#'     id,
+#'     function(input, output, session) {
+#'       count <- reactiveVal(0)
+#'       observeEvent(input$button, {
+#'         count(count() + 1)
+#'       })
+#'       output$out <- renderText({
+#'         count()
+#'       })
+#'       count
+#'     }
+#'   )
 #' }
 #'
 #' # Use the module in an app
@@ -91,7 +94,9 @@ createSessionProxy <- function(parentSession, ...) {
 #'   counterServer("counter1")
 #'   counterServer("counter2")
 #' }
-#' shinyApp(ui, server)
+#' if (interactive()) {
+#'   shinyApp(ui, server)
+#' }
 #'
 #'
 #'
@@ -99,16 +104,19 @@ createSessionProxy <- function(parentSession, ...) {
 #' # add them to your function. In this case `prefix` is text that will be
 #' # printed before the count.
 #' counterServer2 <- function(id, prefix = NULL) {
-#'   moduleServer(id, function(input, output, session) {
-#'     count <- reactiveVal(0)
-#'     observeEvent(input$button, {
-#'       count(count() + 1)
-#'     })
-#'     output$out <- renderText({
-#'       paste0(prefix, count())
-#'     })
-#'     count
-#'   })
+#'   moduleServer(
+#'     id,
+#'     function(input, output, session) {
+#'       count <- reactiveVal(0)
+#'       observeEvent(input$button, {
+#'         count(count() + 1)
+#'       })
+#'       output$out <- renderText({
+#'         paste0(prefix, count())
+#'       })
+#'       count
+#'     }
+#'   )
 #' }
 #'
 #' ui <- fluidPage(
@@ -117,37 +125,27 @@ createSessionProxy <- function(parentSession, ...) {
 #' server <- function(input, output, session) {
 #'   counterServer2("counter", "The current count is: ")
 #' }
-#' shinyApp(ui, server)
+#' if (interactive()) {
+#'   shinyApp(ui, server)
+#' }
 #'
 #' @export
 moduleServer <- function(id, module, session = getDefaultReactiveDomain()) {
-  if (inherits(sessionFor(session), "MockShinySession")) {
-    module <- patchModuleFunction(module)
-    isolate(callModule(module, id, session = session))
-  } else {
-    callModule(module, id, session = session)
+  if (inherits(session, "MockShinySession")) {
+    body(module) <- rlang::expr({
+      session$setEnv(base::environment())
+      session$setReturned({ !!!body(module) })
+    })
   }
+  callModule(module, id, session = session)
 }
 
-#' @noRd
-sessionFor <- function(session) {
-  if (inherits(session, c("MockShinySession", "ShinySession")))
-    return(session)
-
-  if (!inherits(session, "session_proxy"))
-    stop("session must be a ShinySession, MockShinySession, or session_proxy object.")
-
-  while (inherits(session, "session_proxy"))
-    session <- session$parent
-
-  session
-}
 
 #' @rdname moduleServer
 #' @export
 callModule <- function(module, id, ..., session = getDefaultReactiveDomain()) {
-  if (!inherits(session, c("ShinySession", "MockShinySession", "session_proxy"))) {
-    stop("session must be a ShinySession, MockShinySession, or session_proxy object.")
+  if (!inherits(session, c("ShinySession", "session_proxy", "MockShinySession"))) {
+    stop("session must be a ShinySession or session_proxy object.")
   }
   childScope <- session$makeScope(id)
 

R/reactives.R

@@ -222,7 +222,7 @@ reactiveVal <- function(value = NULL, label = NULL) {
         rv$set(x)
       }
     },
-    class = c("reactiveVal", "reactive"),
+    class = c("reactiveVal", "reactive", "function"),
     label = label,
     .impl = rv
   )
@@ -969,7 +969,7 @@ reactive <- function(x, env = parent.frame(), quoted = FALSE, label = NULL,
   if (length(srcref) >= 2) attr(label, "srcref") <- srcref[[2]]
   attr(label, "srcfile") <- srcFileOfRef(srcref[[1]])
   o <- Observable$new(fun, label, domain, ..stacktraceon = ..stacktraceon)
-  structure(o$getValue, observable = o, class = c("reactiveExpr", "reactive"))
+  structure(o$getValue, observable = o, class = c("reactiveExpr", "reactive", "function"))
 }
 
 # Given the srcref to a reactive expression, attempts to figure out what the

R/reexports.R

@@ -0,0 +1,195 @@
+####
+# Generated by `./tools/updateReexports.R`: do not edit by hand
+# Please call `source('tools/updateReexports.R') from the root folder to update`
+####
+
+
+# fastmap key_missing.Rd -------------------------------------------------------
+
+#' @importFrom fastmap key_missing
+#' @export
+fastmap::key_missing
+
+#' @importFrom fastmap is.key_missing
+#' @export
+fastmap::is.key_missing
+
+
+
+# htmltools builder.Rd ---------------------------------------------------------
+
+#' @importFrom htmltools tags
+#' @export
+htmltools::tags
+
+#' @importFrom htmltools p
+#' @export
+htmltools::p
+
+#' @importFrom htmltools h1
+#' @export
+htmltools::h1
+
+#' @importFrom htmltools h2
+#' @export
+htmltools::h2
+
+#' @importFrom htmltools h3
+#' @export
+htmltools::h3
+
+#' @importFrom htmltools h4
+#' @export
+htmltools::h4
+
+#' @importFrom htmltools h5
+#' @export
+htmltools::h5
+
+#' @importFrom htmltools h6
+#' @export
+htmltools::h6
+
+#' @importFrom htmltools a
+#' @export
+htmltools::a
+
+#' @importFrom htmltools br
+#' @export
+htmltools::br
+
+#' @importFrom htmltools div
+#' @export
+htmltools::div
+
+#' @importFrom htmltools span
+#' @export
+htmltools::span
+
+#' @importFrom htmltools pre
+#' @export
+htmltools::pre
+
+#' @importFrom htmltools code
+#' @export
+htmltools::code
+
+#' @importFrom htmltools img
+#' @export
+htmltools::img
+
+#' @importFrom htmltools strong
+#' @export
+htmltools::strong
+
+#' @importFrom htmltools em
+#' @export
+htmltools::em
+
+#' @importFrom htmltools hr
+#' @export
+htmltools::hr
+
+
+# htmltools tag.Rd -------------------------------------------------------------
+
+#' @importFrom htmltools tag
+#' @export
+htmltools::tag
+
+#' @importFrom htmltools tagList
+#' @export
+htmltools::tagList
+
+#' @importFrom htmltools tagAppendAttributes
+#' @export
+htmltools::tagAppendAttributes
+
+#' @importFrom htmltools tagHasAttribute
+#' @export
+htmltools::tagHasAttribute
+
+#' @importFrom htmltools tagGetAttribute
+#' @export
+htmltools::tagGetAttribute
+
+#' @importFrom htmltools tagAppendChild
+#' @export
+htmltools::tagAppendChild
+
+#' @importFrom htmltools tagAppendChildren
+#' @export
+htmltools::tagAppendChildren
+
+#' @importFrom htmltools tagSetChildren
+#' @export
+htmltools::tagSetChildren
+
+
+# htmltools HTML.Rd ------------------------------------------------------------
+
+#' @importFrom htmltools HTML
+#' @export
+htmltools::HTML
+
+
+# htmltools include.Rd ---------------------------------------------------------
+
+#' @importFrom htmltools includeHTML
+#' @export
+htmltools::includeHTML
+
+#' @importFrom htmltools includeText
+#' @export
+htmltools::includeText
+
+#' @importFrom htmltools includeMarkdown
+#' @export
+htmltools::includeMarkdown
+
+#' @importFrom htmltools includeCSS
+#' @export
+htmltools::includeCSS
+
+#' @importFrom htmltools includeScript
+#' @export
+htmltools::includeScript
+
+
+# htmltools singleton.Rd -------------------------------------------------------
+
+#' @importFrom htmltools singleton
+#' @export
+htmltools::singleton
+
+#' @importFrom htmltools is.singleton
+#' @export
+htmltools::is.singleton
+
+
+# htmltools validateCssUnit.Rd -------------------------------------------------
+
+#' @importFrom htmltools validateCssUnit
+#' @export
+htmltools::validateCssUnit
+
+
+# htmltools htmlTemplate.Rd ----------------------------------------------------
+
+#' @importFrom htmltools htmlTemplate
+#' @export
+htmltools::htmlTemplate
+
+
+# htmltools suppressDependencies.Rd --------------------------------------------
+
+#' @importFrom htmltools suppressDependencies
+#' @export
+htmltools::suppressDependencies
+
+
+# htmltools withTags.Rd --------------------------------------------------------
+
+#' @importFrom htmltools withTags
+#' @export
+htmltools::withTags

R/render-plot.R

@@ -889,6 +889,14 @@ find_panel_info_non_api <- function(b, ggplot_format) {
   })
 }
 
+# Use public API for getting the unit's type (grid::unitType(), added in R 4.0)
+# https://github.com/wch/r-source/blob/f9b8a42/src/library/grid/R/unit.R#L179
+getUnitType <- function(u) {
+  tryCatch(
+    get("unitType", envir = asNamespace("grid"))(u),
+    error = function(e) attr(u, "unit", exact = TRUE)
+  )
+}
 
 # Given a gtable object, return the x and y ranges (in pixel dimensions)
 find_panel_ranges <- function(g, res) {
@@ -904,11 +912,11 @@ find_panel_ranges <- function(g, res) {
     if (inherits(x, "unit.list")) {
       # For ggplot2 <= 1.0.1
       vapply(x, FUN.VALUE = logical(1), function(u) {
-        isTRUE(attr(u, "unit", exact = TRUE) == "null")
+        isTRUE(getUnitType(u) == "null")
       })
     } else {
       # For later versions of ggplot2
-      attr(x, "unit", exact = TRUE) == "null"
+      getUnitType(x) == "null"
     }
   }
 
@@ -948,7 +956,11 @@ find_panel_ranges <- function(g, res) {
 
     # The plotting panels all are 'null' units.
     null_sizes <- rep(NA_real_, length(rel_sizes))
-    null_sizes[null_idx] <- as.numeric(rel_sizes[null_idx])
+    # Workaround for `[.unit` forbidding zero-length subsets
+    # https://github.com/wch/r-source/blob/f9b8a42/src/library/grid/R/unit.R#L448-L450
+    if (length(null_idx)) {
+      null_sizes[null_idx] <- as.numeric(rel_sizes[null_idx])
+    }
 
     # Total size allocated for panels is the total image size minus absolute
     # (non-panel) elements.

R/shiny.R

@@ -2296,3 +2296,56 @@ ShinyServerTimingRecorder <- R6Class("ShinyServerTimingRecorder",
 )
 
 missingOutput <- function(...) req(FALSE)
+
+#' Insert inline Markdown
+#'
+#' This function accepts
+#' [Markdown](https://en.wikipedia.org/wiki/Markdown)-syntax text and returns
+#' HTML that may be included in Shiny UIs.
+#'
+#' Leading whitespace is trimmed from Markdown text with [glue::trim()].
+#' Whitespace trimming ensures Markdown is processed correctly even when the
+#' call to `markdown()` is indented within surrounding R code.
+#'
+#' By default, [Github extensions][commonmark::extensions] are enabled, but this
+#' can be disabled by passing `extensions = FALSE`.
+#'
+#' Markdown rendering is performed by [commonmark::markdown_html()]. Additional
+#' arguments to `markdown()` are passed as arguments to `markdown_html()`
+#'
+#' @param mds A character vector of Markdown source to convert to HTML. If the
+#'   vector has more than one element, a single-element character vector of
+#'   concatenated HTML is returned.
+#' @param extensions Enable Github syntax extensions; defaults to `TRUE`.
+#' @param .noWS Character vector used to omit some of the whitespace that would
+#'   normally be written around generated HTML. Valid options include `before`,
+#'   `after`, and `outside` (equivalent to `before` and `end`).
+#' @param ... Additional arguments to pass to [commonmark::markdown_html()].
+#'   These arguments are _[dynamic][rlang::dyn-dots]_.
+#'
+#' @return a character vector marked as HTML.
+#' @export
+#' @examples
+#' ui <- fluidPage(
+#'   markdown("
+#'     # Markdown Example
+#'
+#'     This is a markdown paragraph, and will be contained within a `<p>` tag
+#'     in the UI.
+#'
+#'     The following is an unordered list, which will be represented in the UI as
+#'     a `<ul>` with `<li>` children:
+#'
+#'     * a bullet
+#'     * another
+#'
+#'     [Links](https://developer.mozilla.org/en-US/docs/Web/HTML/Element/a) work;
+#'     so does *emphasis*.
+#'
+#'     To see more of what's possible, check out [commonmark.org/help](https://commonmark.org/help).
+#'     ")
+#' )
+markdown <- function(mds, extensions = TRUE, .noWS = NULL, ...) {
+  html <- rlang::exec(commonmark::markdown_html, glue::trim(mds), extensions = extensions, ...)
+  htmltools::HTML(html, .noWS = .noWS)
+}

R/showcase.R

@@ -104,20 +104,18 @@ navTabsDropdown <- function(files) {
 
 tabContentHelper <- function(files, path, language) {
   lapply(files, function(file) {
-    with(tags,
-      div(class=paste("tab-pane",
+      tags$div(class=paste("tab-pane",
                       if (tolower(file) %in% c("app.r", "server.r")) " active"
                       else "",
                       sep=""),
           id=paste(gsub(".", "_", file, fixed=TRUE),
                    "_code", sep=""),
-          pre(class="shiny-code",
+          tags$pre(class="shiny-code",
               # we need to prevent the indentation of <code> ... </code>
               HTML(format(tags$code(
                 class=paste0("language-", language),
                 paste(readUTF8(file.path.ci(path, file)), collapse="\n")
               ), indent = FALSE))))
-    )
   })
 }
 

R/test-module.R

@@ -1,158 +0,0 @@
-
-
-#' Integration testing for Shiny modules or server functions
-#'
-#' Offer a way to test the reactive interactions in Shiny --- either in Shiny
-#' modules or in the server portion of a Shiny application. For more
-#' information, visit [the Shiny Dev Center article on integration
-#' testing](https://shiny.rstudio.com/articles/integration-testing.html).
-#' @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 ... 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 testModule
-#' @examples
-#' module <- function(input, output, session, multiplier = 2, prefix = "I am ") {
-#'   myreactive <- reactive({
-#'     input$x * multiplier
-#'   })
-#'   output$txt <- renderText({
-#'     paste0(prefix, myreactive())
-#'   })
-#' }
-#'
-#' # Basic Usage
-#' # -----------
-#' testModule(module, {
-#'   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 ")
-#' testModule(module, {
-#'   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
-testModule <- function(module, expr, ...) {
-  .testModule(
-    module,
-    quosure = rlang::enquo(expr),
-    dots = rlang::list2(...),
-    env = rlang::caller_env()
-  )
-}
-
-isOldModule <- function(func) {
-  stopifnot(is.function(func))
-  required <- c("input", "output", "session")
-  declared <- names(formals(func))
-  setequal(required, intersect(required, declared))
-}
-
-#' @noRd
-.testModule <- function(module, quosure, dots, env) {
-  session <- MockShinySession$new()
-  on.exit(if (!session$isClosed()) session$close())
-
-  if (isOldModule(module)) {
-    module <- patchModuleFunction(module)
-    args <- append(dots, list(input = session$input, output = session$output, session = session))
-  } else {
-    args <- dots
-  }
-
-  isolate(withReactiveDomain(session, do.call(module, args)))
-
-  isolate({
-    withReactiveDomain(
-      session,
-      withr::with_options(list(`shiny.allowoutputreads`=TRUE), {
-        rlang::eval_tidy(
-          quosure,
-          data = rlang::as_data_mask(as.list(session$env)),
-          env = env
-        )
-      })
-    )
-  })
-}
-
-#' Test an app's server-side logic
-#' @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.
-#' @rdname testModule
-#' @export
-testServer <- function(expr, appDir=NULL) {
-  if (is.null(appDir)){
-    appDir <- findApp()
-  }
-
-  app <- shinyAppDir(appDir)
-  message("Testing application found in: ", appDir)
-  server <- app$serverFuncSource()
-
-  origwd <- getwd()
-  setwd(appDir)
-  on.exit({ setwd(origwd) }, add=TRUE)
-
-  # Add `session` argument if not present
-  fn_formals <- formals(server)
-  if (! "session" %in% names(fn_formals)) {
-    fn_formals$session <- bquote()
-    formals(server) <- fn_formals
-  }
-
-  # Test the server function almost as if it were a module. `dots` is empty
-  # because server functions never take additional arguments.
-  .testModule(
-    server,
-    quosure = rlang::enquo(expr),
-    dots = list(),
-    env = rlang::caller_env()
-  )
-}
-
-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/test-server.R

@@ -0,0 +1,145 @@
+#' @noRd
+isModuleServer <- function(x) {
+  is.function(x) && names(formals(x))[1] == "id"
+}
+
+#' 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. If `app` is `NULL` or
+#'   not supplied, the nearest enclosing directory that is a Shiny app, starting
+#'   with the current directory, is used.
+#' @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]_. If `app` is a module, and no `id` argument is
+#'   provided, one will be generated and supplied automatically.
+#' @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())
+#'     })
+#'   })
+#' }
+#'
+#' 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)
+#' @export
+testServer <- function(app = NULL, expr, ...) {
+
+  require(shiny)
+
+  quosure <- rlang::enquo(expr)
+  args <- rlang::list2(...)
+  session <- getDefaultReactiveDomain()
+
+  if (inherits(session, "MockShinySession"))
+    stop("Test expressions may not call testServer()")
+  if (inherits(session, "session_proxy")
+      && inherits(get("parent", envir = session), "MockShinySession"))
+    stop("Modules may not call testServer()")
+
+  session <- MockShinySession$new()
+  on.exit(if (!session$isClosed()) session$close())
+
+  if (isModuleServer(app)) {
+    if (!("id" %in% names(args)))
+      args[["id"]] <- session$genId()
+    # app is presumed to be a module, and modules may take additional arguments,
+    # so splice in any args.
+    isolate(
+      withReactiveDomain(
+        session,
+        withr::with_options(list(`shiny.allowoutputreads` = TRUE), {
+          rlang::exec(app, !!!args)
+        })
+      )
+    )
+
+    # If app is a module, then we must use both the module function's immediate
+    # environment and also its enclosing environment to construct the mask.
+    parent_clone <- rlang::env_clone(parent.env(session$env))
+    clone <- rlang::env_clone(session$env, parent_clone)
+    mask <- rlang::new_data_mask(clone, parent_clone)
+
+    isolate(
+      withReactiveDomain(
+        session,
+        withr::with_options(list(`shiny.allowoutputreads` = TRUE), {
+          rlang::eval_tidy(quosure, mask, rlang::caller_env())
+        })
+      )
+    )
+  } else {
+    if (is.null(app)) {
+      app <- findEnclosingApp(".")
+    }
+
+    appobj <- as.shiny.appobj(app)
+    if (!is.null(appobj$onStart))
+      appobj$onStart()
+    # Ensure appobj$onStop() is called, and the current directory is restored,
+    # regardless of whether invoking the server function is successful.
+    tryCatch({
+      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$setEnv(base::environment())
+        !!!body(server)
+      })
+      if (length(args))
+        stop("Arguments were provided to a server function.")
+      isolate(
+        withReactiveDomain(
+          session,
+          withr::with_options(list(`shiny.allowoutputreads` = TRUE), {
+            server(input = session$input, output = session$output, session = session)
+          })
+        )
+      )
+    }, finally = {
+      if (!is.null(appobj$onStop))
+        appobj$onStop()
+    })
+
+    # If app is a server, we use only the server function's immediate
+    # environment to construct the mask.
+    mask <- rlang::new_data_mask(rlang::env_clone(session$env))
+
+    isolate(
+      withReactiveDomain(
+        session,
+        withr::with_options(list(`shiny.allowoutputreads` = TRUE), {
+          rlang::eval_tidy(quosure, mask, rlang::caller_env())
+        })
+      )
+    )
+  }
+}

R/test.R

@@ -1,11 +1,48 @@
-
-#' Check to see if the given text is a shinytest
-#' Scans for the magic string of `app <- ShinyDriver$new(` as an indicator that this is a shinytest.
-#' Brought in from shinytest to avoid having to export this function.
+#' Creates and returns run result data frame.
+#'
+#' @param file Name of the test runner file, a character vector of length 1.
+#' @param pass Whether or not the test passed, a logical vector of length 1.
+#' @param result Value (wrapped in a list) obtained by evaluating `file`.
+#'   This can also by any errors signaled when evaluating the `file`.
+#'
+#' @return A 1-row data frame representing a single test run. `result` and
+#'   is a "list column", or a column that contains list elements.
 #' @noRd
-isShinyTest <- function(text){
-  lines <- grepl("app\\s*<-\\s*ShinyDriver\\$new\\(", text, perl=TRUE)
-  any(lines)
+result_row <- function(file, pass, result) {
+  stopifnot(is.list(result))
+  df <- data.frame(
+    file = file,
+    pass = pass,
+    result = I(result),
+    stringsAsFactors = FALSE
+  )
+  class(df) <- c("shiny_runtests", class(df))
+  df
+}
+
+#' Check to see if the given directory contains at least one script, and that
+#' all scripts in the directory are shinytest scripts.
+#' Scans for the magic string of `app <- ShinyDriver$new(` as an indicator that
+#' this is a shinytest.
+#' @noRd
+is_legacy_shinytest_dir <- function(path){
+  is_shinytest_script <- function(file) {
+    if (!file.exists(file)) {
+      return(FALSE)
+    }
+
+    text <- readLines(file, warn = FALSE)
+    any(
+      grepl("app\\s*<-\\s*ShinyDriver\\$new\\(", text, perl=TRUE)
+    )
+  }
+
+  files <- dir(path, full.names = TRUE)
+  files <- files[!file.info(files)$isdir]
+  if (length(files) == 0) {
+    return(FALSE)
+  }
+  all(vapply(files, is_shinytest_script, logical(1)))
 }
 
 #' Runs the tests associated with this Shiny app
@@ -18,90 +55,210 @@ isShinyTest <- function(text){
 #' @param filter If not `NULL`, only tests with file names matching this regular
 #'   expression will be executed. Matching is performed on the file name
 #'   including the extension.
+#' @param assert Logical value which determines if an error should be thrown if any error is captured.
+#' @param envir Parent testing environment in which to base the individual testing environments.
+#'
+#' @return A data frame classed with the supplemental class `"shiny_runtests"`.
+#'   The data frame has the following columns:
+#'
+#' | **Name** | **Type** | **Meaning** |
+#' | :-- | :-- | :-- |
+#' | `file` | `character(1)` | File name of the runner script in `tests/` that was sourced. |
+#' | `pass` | `logical(1)` | Whether or not the runner script signaled an error when sourced. |
+#' | `result` | any or `NA` | The return value of the runner |
 #'
 #' @details Historically, [shinytest](https://rstudio.github.io/shinytest/)
-#'   recommended placing tests at the top-level of the `tests/` directory. In
-#'   order to support that model, `testApp` first checks to see if the `.R`
-#'   files in the `tests/` directory are all shinytests; if so, just calls out
-#'   to [shinytest::testApp()].
+#'   recommended placing tests at the top-level of the `tests/` directory.
+#'   This older folder structure is not supported by runTests.
+#'   Please see [shinyAppTemplate()] for more details.
 #' @export
-runTests <- function(appDir=".", filter=NULL){
+runTests <- function(
+  appDir = ".",
+  filter = NULL,
+  assert = TRUE,
+  envir = globalenv()
+) {
+  # similar to runApp()
+  # Allows shiny's functions to be available in the UI, server, and test code
   require(shiny)
 
   testsDir <- file.path(appDir, "tests")
-  if (!dirExists(testsDir)){
+  if (!dirExists(testsDir)) {
     stop("No tests directory found: ", testsDir)
   }
   runners <- list.files(testsDir, pattern="\\.r$", ignore.case = TRUE)
 
-  if (length(runners) == 0){
+  if (length(runners) == 0) {
     message("No test runners found in ", testsDir)
-    return(structure(list(result=NA, files=list()), class="shinytestrun"))
+    return(result_row(character(0), logical(0), list()))
   }
 
-  if (!is.null(filter)){
+  if (!is.null(filter)) {
     runners <- runners[grepl(filter, runners)]
   }
-  if (length(runners) == 0){
+  if (length(runners) == 0) {
     stop("No test runners matched the given filter: '", filter, "'")
   }
 
-  # Inspect each runner to see if it appears to be a shinytest
-  isST <- vapply(runners, function(r){
-    text <- readLines(file.path(testsDir, r), warn = FALSE)
-    isShinyTest(text)
-  }, logical(1))
-
-  if (all(isST)){
-    # just call out to shinytest
-    # We don't need to message/warn here since shinytest already does it.
-    if (!requireNamespace("shinytest", quietly=TRUE) ){
-      stop("It appears that the .R files in ", testsDir,
-           " are all shinytests, but shinytest is not installed.")
-    }
-
-    if (!getOption("shiny.autoload.r", TRUE)) {
-      warning("You've disabled `shiny.autoload.r` via an option but this is not passed through to shinytest. Consider using a _disable_autoload.R file as described at https://rstd.io/shiny-autoload")
-    }
-
-    sares <- shinytest::testApp(appDir)
-    res <- list()
-    lapply(sares$results, function(r){
-      e <- NA_character_
-      if (!r$pass){
-        e <- simpleError("Unknown shinytest error")
-      }
-      res[[r$name]] <<- e
-    })
-    return(structure(list(result=all(is.na(res)), files=res), class="shinytestrun"))
+  # See the @details section of the runTests() docs above for why this branch exists.
+  if (is_legacy_shinytest_dir(testsDir)) {
+    stop(
+      "It appears that the .R files in ", testsDir, " are all shinytests.",
+      " This is not supported by `shiny::runTests()`.",
+      "\nPlease see `?shiny::migrateLegacyShinytest` to migrate your shinytest file structure to the new format.",
+      "\nSee `?shiny::shinyAppTemplate` for an example of the new testing file structure."
+    )
   }
 
-  testenv <- new.env(parent=globalenv())
-  renv <- new.env(parent=testenv)
-  if (getOption("shiny.autoload.r", TRUE)) {
-    loadSupport(appDir, renv=renv, globalrenv=testenv)
-  } else if (file.exists.ci(file.path(appDir, "server.R"))){
-    # then check for global.R to load
-    if (file.exists(file.path.ci(appDir, "global.R"))){
-      sourceUTF8(file.path.ci(appDir, "global.R"))
-    }
-  }
-
-  oldwd <- getwd()
-  on.exit({
-    setwd(oldwd)
-  }, add=TRUE)
-
-  setwd(testsDir)
+  renv <- new.env(parent = envir)
 
   # Otherwise source all the runners -- each in their own environment.
-  fileResults <- list()
-  lapply(runners, function(r){
-    env <- new.env(parent=renv)
-    tryCatch({sourceUTF8(r, envir=env); fileResults[[r]] <<- NA_character_}, error=function(e){
-      fileResults[[r]] <<- e
-    })
-  })
+  ret <- do.call(rbind, lapply(runners, function(r) {
+    pass <- FALSE
+    result <-
+      tryCatch({
+        env <- new.env(parent = renv)
+        withr::with_dir(testsDir, {
+          ret <- sourceUTF8(r, envir = env)
+        })
+        pass <- TRUE
+        ret
+      }, error = function(err) {
+        message("Error in ", r, "\n", err)
+        err
+      })
+    result_row(file.path(testsDir, r), pass, list(result))
+  }))
 
-  return(structure(list(result=all(is.na(fileResults)), files=fileResults), class="shinytestrun"))
+  if (isTRUE(assert)) {
+    if (!all(ret$pass)) {
+      stop("Shiny App Test Failures detected in\n", paste0("* ", runtest_pretty_file(ret$file[!ret$pass]), collapse = "\n"), call. = FALSE)
+    }
+  }
+
+  ret
+}
+
+
+runtest_pretty_file <- function(f) {
+  test_folder <- dirname(f)
+  app_folder <- dirname(test_folder)
+  file.path(
+    basename(app_folder),
+    basename(test_folder),
+    basename(f)
+  )
+}
+
+
+print.shiny_runtests <- function(x, ..., reporter = "summary") {
+
+  cat("Shiny App Test Results\n")
+
+
+  if (any(x$pass)) {
+    # TODO in future... use clisymbols::symbol$tick and crayon green
+    cat("* Success\n")
+    mapply(
+      x$file,
+      x$pass,
+      x$result,
+      FUN = function(file, pass, result) {
+        if (!pass) return()
+        # print(result)
+        cat("  - ", runtest_pretty_file(file), "\n", sep = "")
+      }
+    )
+  }
+  if (any(!x$pass)) {
+    # TODO in future... use clisymbols::symbol$cross and crayon red
+    cat("* Failure\n")
+    mapply(
+      x$file,
+      x$pass,
+      x$result,
+      FUN = function(file, pass, result) {
+        if (pass) return()
+        cat("  - ", runtest_pretty_file(file), "\n", sep = "")
+      }
+    )
+  }
+
+  invisible(x)
+}
+
+
+#' Migrate legacy \pkg{shinytest} files to new test directory structure
+#'
+#' This function migrates the old-style directory structure used by
+#' \pkg{shinytest} to (versions 1.3.1 and below) new test directory structure
+#' used in Shiny 1.5.0 and above.
+#'
+#' In Shiny 1.5.0, the [runTests()] function was added, and it will run test
+#' scripts tests/ subdirectory of the application. The directory structure will
+#' look something like this:
+#'
+#' ```
+#' appdir/
+#'  |- R
+#'  |- tests
+#'      |- shinytest.R
+#'      |- shinytest
+#'      |   `- mytest.R
+#'      |- testthat.R
+#'      `- testthat
+#'          `- test-script.R
+#' ```
+#'
+#' This allows for tests using the \pkg{shinytest} package as well as other
+#' testing tools, such as the [testServer()] function, which can be used for
+#' testing module and server logic, and for unit tests of functions in an R/
+#' subdirectory.
+#'
+#'
+#' With the \pkg{shinytest} package, in versions 1.3.0 and below, the tests/
+#' subdirectory of the application was used specifically for \pkg{shinytest},
+#' and could not be used for other types of tests. So the directory structure
+#' would look like this:
+#'
+#' ```
+#' appdir/
+#'  `- tests
+#'      `- mytest.R
+#' ```
+#'
+#' In \pkg{shinytest} 1.4.0 and above, it defaults to the new directory
+#' structure.
+#'
+#' @param appdir A directory containing a Shiny application.
+#' @param prompt If \code{TRUE}, ask for confirmation when moving files.
+#'
+#' @export
+migrateLegacyShinytest <- function(appdir, prompt = interactive()) {
+  appdir <- findEnclosingApp(appdir)
+
+  test_dir <- file.path(appdir, "tests")
+  shinytest_dir <- file.path(test_dir, "shinytest")
+
+  if (!is_legacy_shinytest_dir(test_dir)) {
+    stop("The .R files in ", test_dir,
+         " must all be test scripts for the shinytest package.")
+  }
+
+  if (prompt) {
+    res <- readline(
+      paste0(
+        "Creating ", shinytest_dir, " and moving files from\n", test_dir,
+        " into it.\nAre you sure you want to do this? [y/n]\n"
+      )
+    )
+    if (!identical(tolower(res), "y")) {
+      return(invisible())
+    }
+  }
+
+  files <- dir(test_dir)
+  dir.create(shinytest_dir, showWarnings = FALSE)
+  file.rename(file.path(test_dir, files), file.path(shinytest_dir, files))
+  invisible()
 }

R/update-input.R

@@ -126,13 +126,15 @@ updateCheckboxInput <- function(session, inputId, label = NULL, value = NULL) {
 #' if (interactive()) {
 #'
 #' ui <- fluidPage(
-#'   actionButton("update", "Update other buttons"),
+#'   actionButton("update", "Update other buttons and link"),
 #'   br(),
 #'   actionButton("goButton", "Go"),
 #'   br(),
 #'   actionButton("goButton2", "Go 2", icon = icon("area-chart")),
 #'   br(),
-#'   actionButton("goButton3", "Go 3")
+#'   actionButton("goButton3", "Go 3"),
+#'   br(),
+#'   actionLink("goLink", "Go Link")
 #' )
 #'
 #' server <- function(input, output, session) {
@@ -153,17 +155,26 @@ updateCheckboxInput <- function(session, inputId, label = NULL, value = NULL) {
 #'     # unchaged and changes its label
 #'     updateActionButton(session, "goButton3",
 #'       label = "New label 3")
+#'
+#'     # Updates goLink's label and icon
+#'     updateActionButton(session, "goLink",
+#'       label = "New link label",
+#'       icon = icon("link"))
 #'   })
 #' }
 #'
 #' shinyApp(ui, server)
 #' }
+#' @rdname updateActionButton
 #' @export
 updateActionButton <- function(session, inputId, label = NULL, icon = NULL) {
   if (!is.null(icon)) icon <- as.character(validateIcon(icon))
   message <- dropNulls(list(label=label, icon=icon))
   session$sendInputMessage(inputId, message)
 }
+#' @rdname updateActionButton
+#' @export
+updateActionLink <- updateActionButton
 
 
 #' Change the value of a date input on the client

R/utils.R

@@ -316,6 +316,15 @@ resolve <- function(dir, relpath) {
   return(abs.path)
 }
 
+# Given a string, make sure it has a trailing slash.
+ensure_trailing_slash <- function(path) {
+  if (!grepl("/$", path)) {
+    path <- paste0(path, "/")
+  }
+  path
+}
+
+
 isWindows <- function() .Platform$OS.type == 'windows'
 
 # This is a wrapper for download.file and has the same interface.
@@ -1812,3 +1821,55 @@ cat_line <- function(...) {
   cat(paste(..., "\n", collapse = ""))
 }
 
+select_menu <- function(choices, title = NULL, msg = "Enter one or more numbers (with spaces), or an empty line to exit: \n")
+{
+  if (!is.null(title)) {
+    cat(title, "\n", sep = "")
+  }
+  nc <- length(choices)
+  op <- paste0(format(seq_len(nc)), ": ", choices)
+  fop <- format(op)
+  cat("", fop, "", sep = "\n")
+  repeat {
+    answer <- readline(msg)
+    answer <- strsplit(answer, "[ ,]+")[[1]]
+    if (all(answer %in% seq_along(choices))) {
+      return(choices[as.integer(answer)])
+    }
+  }
+}
+
+#' @noRd
+isAppDir <- function(path) {
+
+  if (file.exists(file.path.ci(path, "app.R")))
+    return(TRUE)
+
+  if (file.exists(file.path.ci(path, "server.R"))
+      && file.exists(file.path.ci(path, "ui.R")))
+    return(TRUE)
+
+  FALSE
+}
+
+# Borrowed from rprojroot which borrowed from devtools
+#' @noRd
+is_root <- function(path) {
+  identical(
+    normalizePath(path, winslash = "/"),
+    normalizePath(dirname(path), winslash = "/")
+  )
+}
+
+#' @noRd
+findEnclosingApp <- function(path = ".") {
+  orig_path <- path
+  path <- normalizePath(path, winslash = "/", mustWork = TRUE)
+  repeat {
+    if (isAppDir(path))
+      return(path)
+    if (is_root(path))
+      stop("Shiny app not found at ", orig_path, " or in any parent directory.")
+    path <- dirname(path)
+  }
+}

inst/app_template/R/my-module.R

@@ -0,0 +1,27 @@
+mymoduleUI <- function(id, label = "Counter") {
+  # Al uses of Shiny input/output IDs in the UI must be namespaced,
+  # as in ns("x").
+  ns <- NS(id)
+  tagList(
+    actionButton(ns("button"), label = label),
+    verbatimTextOutput(ns("out"))
+  )
+}
+
+mymoduleServer <- function(id) {
+  # moduleServer() wraps a function to create the server component of a
+  # module.
+  moduleServer(
+    id,
+    function(input, output, session) {
+      count <- reactiveVal(0)
+      observeEvent(input$button, {
+        count(count() + 1)
+      })
+      output$out <- renderText({
+        count()
+      })
+      count
+    }
+  )
+}

inst/app_template/R/sort.R

@@ -0,0 +1,5 @@
+# Given a numeric vector, convert to strings, sort, and convert back to
+# numeric.
+lexical_sort <- function(x) {
+  as.numeric(sort(as.character(x)))
+}

inst/app_template/app.R

@@ -0,0 +1,52 @@
+ui <- fluidPage(
+{{
+# These blocks of code are processed with htmlTemplate()
+if (isTRUE(module)) {
+'  # ======== Modules ========
+  # mymoduleUI is defined in R/my-module.R
+  mymoduleUI("mymodule1", "Click counter #1"),
+  mymoduleUI("mymodule2", "Click counter #2"),
+  # =========================
+'
+}
+}}
+  wellPanel(
+    sliderInput("size", "Data size", min = 5, max = 20, value = 10),
+{{
+if (isTRUE(rdir)) {
+  '    div("Lexically sorted sequence:"),'
+} else {
+  '    div("Sorted sequence:"),'
+}
+}}
+    verbatimTextOutput("sequence")
+  )
+)
+
+server <- function(input, output, session) {
+{{
+if (isTRUE(module)) {
+'  # ======== Modules ========
+  # mymoduleServer is defined in R/my-module.R
+  mymoduleServer("mymodule1")
+  mymoduleServer("mymodule2")
+  # =========================
+'
+}
+}}
+  data <- reactive({
+{{
+if (isTRUE(rdir)) {
+'    # lexical_sort from R/sort.R
+    lexical_sort(seq_len(input$size))'
+} else {
+'    sort(seq_len(input$size))'
+}
+}}
+  })
+  output$sequence <- renderText({
+    paste(data(), collapse = " ")
+  })
+}
+
+shinyApp(ui, server)

inst/app_template/tests/shinytest.R

@@ -0,0 +1,3 @@
+library(shinytest)
+shinytest::testApp("../")
+

inst/app_template/tests/shinytest/mytest.R

@@ -0,0 +1,12 @@
+app <- ShinyDriver$new("../../")
+app$snapshotInit("mytest")
+
+app$snapshot()
+{{
+if (isTRUE(module)) {
+'
+app$setInputs(`mymodule1-button` = "click")
+app$setInputs(`mymodule1-button` = "click")
+app$snapshot()'
+}
+}}

inst/app_template/tests/testthat.R

@@ -0,0 +1,9 @@
+library(testthat)
+
+test_dir(
+  "./testthat",
+  # Run in the app's environment containing all support methods.
+  env = shiny::loadSupport("../"),
+  # Display the regular progress output and throw an error if any test error is found
+  reporter = c("progress", "fail")
+)

inst/app_template/tests/testthat/test-mymodule.R

@@ -0,0 +1,18 @@
+context("mymoduleServer")
+
+# See ?testServer for more information
+testServer(mymoduleServer, {
+  # Set initial value of a button
+  session$setInputs(button = 0)
+
+  # Check the value of the reactiveVal `count()`
+  expect_equal(count(), 1)
+  # Check the value of the renderText()
+  expect_equal(output$out, "1")
+
+  # Simulate a click
+  session$setInputs(button = 1)
+
+  expect_equal(count(), 2)
+  expect_equal(output$out, "2")
+})

inst/app_template/tests/testthat/test-server.R

@@ -0,0 +1,20 @@
+context("app")
+
+testServer(expr = {
+  # Set the `size` slider and check the output
+  session$setInputs(size = 6)
+  expect_equal(output$sequence, "1 2 3 4 5 6")
+{{
+if (isTRUE(rdir)) {
+'
+  session$setInputs(size = 12)
+  expect_equal(output$sequence, "1 10 11 12 2 3 4 5 6 7 8 9")
+'
+} else {
+'
+  session$setInputs(size = 12)
+  expect_equal(output$sequence, "1 2 3 4 5 6 7 8 9 10 11 12")
+'
+}
+}}
+})

inst/app_template/tests/testthat/test-sort.R

@@ -0,0 +1,7 @@
+# Test the lexical_sort function from R/utils.R
+context("sort")
+
+test_that("Lexical sorting works", {
+  expect_equal(lexical_sort(c(1, 2, 3)), c(1, 2, 3))
+  expect_equal(lexical_sort(c(1, 2, 3, 13, 11, 21)), c(1, 11, 13, 2, 21, 3))
+})

man/HTML.Rd

@@ -1,29 +0,0 @@
-\name{HTML}
-\alias{HTML}
-\title{Mark Characters as HTML}
-\usage{
-HTML(text, ..., .noWS = NULL)
-}
-\arguments{
-\item{text}{The text value to mark with HTML}
-
-\item{...}{Any additional values to be converted to character and
-concatenated together}
-
-\item{.noWS}{Character vector used to omit some of the whitespace that would
-normally be written around this HTML. Valid options include \code{before},
-\code{after}, and \code{outside} (equivalent to \code{before} and
-\code{end}).}
-}
-\value{
-The same value, but marked as HTML.
-}
-\description{
-Marks the given text as HTML, which means the \link{tag} functions will know
-not to perform HTML escaping on it.
-}
-\examples{
-el <- div(HTML("I like <u>turtles</u>"))
-cat(as.character(el))
-
-}

man/MockShinySession.Rd

@@ -13,14 +13,25 @@ provided to Shiny server functions or modules.
 ## Method `MockShinySession$setInputs`
 ## ------------------------------------------------
 
-s <- MockShinySession$new()
-s$setInputs(x=1, y=2)
+\dontrun{
+session$setInputs(x=1, y=2)
+}
+
+## ------------------------------------------------
+## Method `MockShinySession$click`
+## ------------------------------------------------
+
+\dontrun{
+session$click("button1")
+}
 }
 \section{Public fields}{
 \if{html}{\out{<div class="r6-fields">}}
 \describe{
 \item{\code{env}}{The environment associated with the session.}
 
+\item{\code{returned}}{The value returned by the module.}
+
 \item{\code{singletons}}{Hardcoded as empty. Needed for rendering HTML (i.e. renderUI)}
 
 \item{\code{clientData}}{Mock client data that always returns a size for plots}
@@ -38,8 +49,6 @@ s$setInputs(x=1, y=2)
 \section{Active bindings}{
 \if{html}{\out{<div class="r6-active-bindings">}}
 \describe{
-\item{\code{returned}}{The value returned from the module}
-
 \item{\code{request}}{An empty environment where the request should be. The request isn't meaningfully mocked currently.}
 }
 \if{html}{\out{</div>}}
@@ -59,6 +68,7 @@ s$setInputs(x=1, y=2)
 \item \href{#method-cycleStartAction}{\code{MockShinySession$cycleStartAction()}}
 \item \href{#method-fileUrl}{\code{MockShinySession$fileUrl()}}
 \item \href{#method-setInputs}{\code{MockShinySession$setInputs()}}
+\item \href{#method-click}{\code{MockShinySession$click()}}
 \item \href{#method-.scheduleTask}{\code{MockShinySession$.scheduleTask()}}
 \item \href{#method-elapse}{\code{MockShinySession$elapse()}}
 \item \href{#method-.now}{\code{MockShinySession$.now()}}
@@ -83,11 +93,16 @@ s$setInputs(x=1, y=2)
 \item \href{#method-ns}{\code{MockShinySession$ns()}}
 \item \href{#method-flushReact}{\code{MockShinySession$flushReact()}}
 \item \href{#method-makeScope}{\code{MockShinySession$makeScope()}}
+\item \href{#method-setEnv}{\code{MockShinySession$setEnv()}}
+\item \href{#method-setReturned}{\code{MockShinySession$setReturned()}}
+\item \href{#method-getReturned}{\code{MockShinySession$getReturned()}}
+\item \href{#method-genId}{\code{MockShinySession$genId()}}
 \item \href{#method-clone}{\code{MockShinySession$clone()}}
 }
 }
 \if{html}{\out{<hr>}}
 \if{html}{\out{<a id="method-reactlog"></a>}}
+\if{latex}{\out{\hypertarget{method-reactlog}{}}}
 \subsection{Method \code{reactlog()}}{
 No-op
 \subsection{Usage}{
@@ -104,6 +119,7 @@ No-op
 }
 \if{html}{\out{<hr>}}
 \if{html}{\out{<a id="method-incrementBusyCount"></a>}}
+\if{latex}{\out{\hypertarget{method-incrementBusyCount}{}}}
 \subsection{Method \code{incrementBusyCount()}}{
 No-op
 \subsection{Usage}{
@@ -113,6 +129,7 @@ No-op
 }
 \if{html}{\out{<hr>}}
 \if{html}{\out{<a id="method-new"></a>}}
+\if{latex}{\out{\hypertarget{method-new}{}}}
 \subsection{Method \code{new()}}{
 Create a new MockShinySession
 \subsection{Usage}{
@@ -122,6 +139,7 @@ Create a new MockShinySession
 }
 \if{html}{\out{<hr>}}
 \if{html}{\out{<a id="method-onFlush"></a>}}
+\if{latex}{\out{\hypertarget{method-onFlush}{}}}
 \subsection{Method \code{onFlush()}}{
 Define a callback to be invoked before a reactive flush
 \subsection{Usage}{
@@ -140,6 +158,7 @@ Define a callback to be invoked before a reactive flush
 }
 \if{html}{\out{<hr>}}
 \if{html}{\out{<a id="method-onFlushed"></a>}}
+\if{latex}{\out{\hypertarget{method-onFlushed}{}}}
 \subsection{Method \code{onFlushed()}}{
 Define a callback to be invoked after a reactive flush
 \subsection{Usage}{
@@ -158,6 +177,7 @@ Define a callback to be invoked after a reactive flush
 }
 \if{html}{\out{<hr>}}
 \if{html}{\out{<a id="method-onEnded"></a>}}
+\if{latex}{\out{\hypertarget{method-onEnded}{}}}
 \subsection{Method \code{onEnded()}}{
 Define a callback to be invoked when the session ends
 \subsection{Usage}{
@@ -174,6 +194,7 @@ Define a callback to be invoked when the session ends
 }
 \if{html}{\out{<hr>}}
 \if{html}{\out{<a id="method-isEnded"></a>}}
+\if{latex}{\out{\hypertarget{method-isEnded}{}}}
 \subsection{Method \code{isEnded()}}{
 Returns \code{FALSE} if the session has not yet been closed
 \subsection{Usage}{
@@ -183,6 +204,7 @@ Returns \code{FALSE} if the session has not yet been closed
 }
 \if{html}{\out{<hr>}}
 \if{html}{\out{<a id="method-isClosed"></a>}}
+\if{latex}{\out{\hypertarget{method-isClosed}{}}}
 \subsection{Method \code{isClosed()}}{
 Returns \code{FALSE} if the session has not yet been closed
 \subsection{Usage}{
@@ -192,6 +214,7 @@ Returns \code{FALSE} if the session has not yet been closed
 }
 \if{html}{\out{<hr>}}
 \if{html}{\out{<a id="method-close"></a>}}
+\if{latex}{\out{\hypertarget{method-close}{}}}
 \subsection{Method \code{close()}}{
 Closes the session
 \subsection{Usage}{
@@ -201,6 +224,7 @@ Closes the session
 }
 \if{html}{\out{<hr>}}
 \if{html}{\out{<a id="method-cycleStartAction"></a>}}
+\if{latex}{\out{\hypertarget{method-cycleStartAction}{}}}
 \subsection{Method \code{cycleStartAction()}}{
 Unsophisticated mock implementation that merely invokes
 the given callback immediately.
@@ -218,6 +242,7 @@ the given callback immediately.
 }
 \if{html}{\out{<hr>}}
 \if{html}{\out{<a id="method-fileUrl"></a>}}
+\if{latex}{\out{\hypertarget{method-fileUrl}{}}}
 \subsection{Method \code{fileUrl()}}{
 Base64-encode the given file. Needed for image rendering.
 \subsection{Usage}{
@@ -238,9 +263,10 @@ Base64-encode the given file. Needed for image rendering.
 }
 \if{html}{\out{<hr>}}
 \if{html}{\out{<a id="method-setInputs"></a>}}
+\if{latex}{\out{\hypertarget{method-setInputs}{}}}
 \subsection{Method \code{setInputs()}}{
-Sets reactive values associated with the \code{session$inputs} object
-and flushes the reactives.
+Sets reactive values associated with the \code{session$inputs}
+object and flushes the reactives.
 \subsection{Usage}{
 \if{html}{\out{<div class="r">}}\preformatted{MockShinySession$setInputs(...)}\if{html}{\out{</div>}}
 }
@@ -248,14 +274,44 @@ and flushes the reactives.
 \subsection{Arguments}{
 \if{html}{\out{<div class="arguments">}}
 \describe{
-\item{\code{...}}{The inputs to set.}
+\item{\code{...}}{The inputs to set. These arguments are processed with
+\code{\link[rlang:list2]{rlang::list2()}} and so are \emph{\link[rlang:dyn-dots]{dynamic}}. Input names
+may not be duplicated.}
 }
 \if{html}{\out{</div>}}
 }
 \subsection{Examples}{
 \if{html}{\out{<div class="r example copy">}}
-\preformatted{s <- MockShinySession$new()
-s$setInputs(x=1, y=2)
+\preformatted{\dontrun{
+session$setInputs(x=1, y=2)
+}
+}
+\if{html}{\out{</div>}}
+
+}
+
+}
+\if{html}{\out{<hr>}}
+\if{html}{\out{<a id="method-click"></a>}}
+\if{latex}{\out{\hypertarget{method-click}{}}}
+\subsection{Method \code{click()}}{
+Simulates clicking an action button.
+\subsection{Usage}{
+\if{html}{\out{<div class="r">}}\preformatted{MockShinySession$click(id)}\if{html}{\out{</div>}}
+}
+
+\subsection{Arguments}{
+\if{html}{\out{<div class="arguments">}}
+\describe{
+\item{\code{id}}{The id of the button to click.}
+}
+\if{html}{\out{</div>}}
+}
+\subsection{Examples}{
+\if{html}{\out{<div class="r example copy">}}
+\preformatted{\dontrun{
+session$click("button1")
+}
 }
 \if{html}{\out{</div>}}
 
@@ -264,6 +320,7 @@ s$setInputs(x=1, y=2)
 }
 \if{html}{\out{<hr>}}
 \if{html}{\out{<a id="method-.scheduleTask"></a>}}
+\if{latex}{\out{\hypertarget{method-.scheduleTask}{}}}
 \subsection{Method \code{.scheduleTask()}}{
 An internal method which shouldn't be used by others.
 \subsection{Usage}{
@@ -282,6 +339,7 @@ An internal method which shouldn't be used by others.
 }
 \if{html}{\out{<hr>}}
 \if{html}{\out{<a id="method-elapse"></a>}}
+\if{latex}{\out{\hypertarget{method-elapse}{}}}
 \subsection{Method \code{elapse()}}{
 Simulate the passing of time by the given number of milliseconds.
 \subsection{Usage}{
@@ -298,6 +356,7 @@ Simulate the passing of time by the given number of milliseconds.
 }
 \if{html}{\out{<hr>}}
 \if{html}{\out{<a id="method-.now"></a>}}
+\if{latex}{\out{\hypertarget{method-.now}{}}}
 \subsection{Method \code{.now()}}{
 An internal method which shouldn't be used by others.
 \subsection{Usage}{
@@ -307,6 +366,7 @@ An internal method which shouldn't be used by others.
 }
 \if{html}{\out{<hr>}}
 \if{html}{\out{<a id="method-defineOutput"></a>}}
+\if{latex}{\out{\hypertarget{method-defineOutput}{}}}
 \subsection{Method \code{defineOutput()}}{
 An internal method which shouldn't be used by others.
 \subsection{Usage}{
@@ -327,6 +387,7 @@ An internal method which shouldn't be used by others.
 }
 \if{html}{\out{<hr>}}
 \if{html}{\out{<a id="method-getOutput"></a>}}
+\if{latex}{\out{\hypertarget{method-getOutput}{}}}
 \subsection{Method \code{getOutput()}}{
 An internal method which shouldn't be used by others.
 \subsection{Usage}{
@@ -343,6 +404,7 @@ An internal method which shouldn't be used by others.
 }
 \if{html}{\out{<hr>}}
 \if{html}{\out{<a id="method-registerDataObj"></a>}}
+\if{latex}{\out{\hypertarget{method-registerDataObj}{}}}
 \subsection{Method \code{registerDataObj()}}{
 No-op
 \subsection{Usage}{
@@ -363,6 +425,7 @@ No-op
 }
 \if{html}{\out{<hr>}}
 \if{html}{\out{<a id="method-allowReconnect"></a>}}
+\if{latex}{\out{\hypertarget{method-allowReconnect}{}}}
 \subsection{Method \code{allowReconnect()}}{
 No-op
 \subsection{Usage}{
@@ -379,6 +442,7 @@ No-op
 }
 \if{html}{\out{<hr>}}
 \if{html}{\out{<a id="method-reload"></a>}}
+\if{latex}{\out{\hypertarget{method-reload}{}}}
 \subsection{Method \code{reload()}}{
 No-op
 \subsection{Usage}{
@@ -388,6 +452,7 @@ No-op
 }
 \if{html}{\out{<hr>}}
 \if{html}{\out{<a id="method-resetBrush"></a>}}
+\if{latex}{\out{\hypertarget{method-resetBrush}{}}}
 \subsection{Method \code{resetBrush()}}{
 No-op
 \subsection{Usage}{
@@ -404,6 +469,7 @@ No-op
 }
 \if{html}{\out{<hr>}}
 \if{html}{\out{<a id="method-sendCustomMessage"></a>}}
+\if{latex}{\out{\hypertarget{method-sendCustomMessage}{}}}
 \subsection{Method \code{sendCustomMessage()}}{
 No-op
 \subsection{Usage}{
@@ -422,6 +488,7 @@ No-op
 }
 \if{html}{\out{<hr>}}
 \if{html}{\out{<a id="method-sendBinaryMessage"></a>}}
+\if{latex}{\out{\hypertarget{method-sendBinaryMessage}{}}}
 \subsection{Method \code{sendBinaryMessage()}}{
 No-op
 \subsection{Usage}{
@@ -440,6 +507,7 @@ No-op
 }
 \if{html}{\out{<hr>}}
 \if{html}{\out{<a id="method-sendInputMessage"></a>}}
+\if{latex}{\out{\hypertarget{method-sendInputMessage}{}}}
 \subsection{Method \code{sendInputMessage()}}{
 No-op
 \subsection{Usage}{
@@ -458,6 +526,7 @@ No-op
 }
 \if{html}{\out{<hr>}}
 \if{html}{\out{<a id="method-setBookmarkExclude"></a>}}
+\if{latex}{\out{\hypertarget{method-setBookmarkExclude}{}}}
 \subsection{Method \code{setBookmarkExclude()}}{
 No-op
 \subsection{Usage}{
@@ -474,6 +543,7 @@ No-op
 }
 \if{html}{\out{<hr>}}
 \if{html}{\out{<a id="method-getBookmarkExclude"></a>}}
+\if{latex}{\out{\hypertarget{method-getBookmarkExclude}{}}}
 \subsection{Method \code{getBookmarkExclude()}}{
 No-op
 \subsection{Usage}{
@@ -483,6 +553,7 @@ No-op
 }
 \if{html}{\out{<hr>}}
 \if{html}{\out{<a id="method-onBookmark"></a>}}
+\if{latex}{\out{\hypertarget{method-onBookmark}{}}}
 \subsection{Method \code{onBookmark()}}{
 No-op
 \subsection{Usage}{
@@ -499,6 +570,7 @@ No-op
 }
 \if{html}{\out{<hr>}}
 \if{html}{\out{<a id="method-onBookmarked"></a>}}
+\if{latex}{\out{\hypertarget{method-onBookmarked}{}}}
 \subsection{Method \code{onBookmarked()}}{
 No-op
 \subsection{Usage}{
@@ -515,6 +587,7 @@ No-op
 }
 \if{html}{\out{<hr>}}
 \if{html}{\out{<a id="method-doBookmark"></a>}}
+\if{latex}{\out{\hypertarget{method-doBookmark}{}}}
 \subsection{Method \code{doBookmark()}}{
 No-op
 \subsection{Usage}{
@@ -524,6 +597,7 @@ No-op
 }
 \if{html}{\out{<hr>}}
 \if{html}{\out{<a id="method-onRestore"></a>}}
+\if{latex}{\out{\hypertarget{method-onRestore}{}}}
 \subsection{Method \code{onRestore()}}{
 No-op
 \subsection{Usage}{
@@ -540,6 +614,7 @@ No-op
 }
 \if{html}{\out{<hr>}}
 \if{html}{\out{<a id="method-onRestored"></a>}}
+\if{latex}{\out{\hypertarget{method-onRestored}{}}}
 \subsection{Method \code{onRestored()}}{
 No-op
 \subsection{Usage}{
@@ -556,6 +631,7 @@ No-op
 }
 \if{html}{\out{<hr>}}
 \if{html}{\out{<a id="method-exportTestValues"></a>}}
+\if{latex}{\out{\hypertarget{method-exportTestValues}{}}}
 \subsection{Method \code{exportTestValues()}}{
 No-op
 \subsection{Usage}{
@@ -565,6 +641,7 @@ No-op
 }
 \if{html}{\out{<hr>}}
 \if{html}{\out{<a id="method-getTestSnapshotUrl"></a>}}
+\if{latex}{\out{\hypertarget{method-getTestSnapshotUrl}{}}}
 \subsection{Method \code{getTestSnapshotUrl()}}{
 No-op
 \subsection{Usage}{
@@ -592,8 +669,9 @@ No-op
 }
 \if{html}{\out{<hr>}}
 \if{html}{\out{<a id="method-ns"></a>}}
+\if{latex}{\out{\hypertarget{method-ns}{}}}
 \subsection{Method \code{ns()}}{
-Returns the given id prefixed by \verb{mock-session-}.
+Returns the given id prefixed by this namespace's id.
 \subsection{Usage}{
 \if{html}{\out{<div class="r">}}\preformatted{MockShinySession$ns(id)}\if{html}{\out{</div>}}
 }
@@ -608,6 +686,7 @@ Returns the given id prefixed by \verb{mock-session-}.
 }
 \if{html}{\out{<hr>}}
 \if{html}{\out{<a id="method-flushReact"></a>}}
+\if{latex}{\out{\hypertarget{method-flushReact}{}}}
 \subsection{Method \code{flushReact()}}{
 Trigger a reactive flush right now.
 \subsection{Usage}{
@@ -617,6 +696,7 @@ Trigger a reactive flush right now.
 }
 \if{html}{\out{<hr>}}
 \if{html}{\out{<a id="method-makeScope"></a>}}
+\if{latex}{\out{\hypertarget{method-makeScope}{}}}
 \subsection{Method \code{makeScope()}}{
 Create and return a namespace-specific session proxy.
 \subsection{Usage}{
@@ -630,9 +710,71 @@ Create and return a namespace-specific session proxy.
 }
 \if{html}{\out{</div>}}
 }
+}
+\if{html}{\out{<hr>}}
+\if{html}{\out{<a id="method-setEnv"></a>}}
+\if{latex}{\out{\hypertarget{method-setEnv}{}}}
+\subsection{Method \code{setEnv()}}{
+Set the environment associated with a testServer() call, but
+only if it has not previously been set. This ensures that only the
+environment of the outermost module under test is the one retained. In
+other words, the first assignment wins.
+\subsection{Usage}{
+\if{html}{\out{<div class="r">}}\preformatted{MockShinySession$setEnv(env)}\if{html}{\out{</div>}}
+}
+
+\subsection{Arguments}{
+\if{html}{\out{<div class="arguments">}}
+\describe{
+\item{\code{env}}{The environment to retain.}
+}
+\if{html}{\out{</div>}}
+}
+}
+\if{html}{\out{<hr>}}
+\if{html}{\out{<a id="method-setReturned"></a>}}
+\if{latex}{\out{\hypertarget{method-setReturned}{}}}
+\subsection{Method \code{setReturned()}}{
+Set the value returned by the module call and proactively
+flush. Note that this method may be called multiple times if modules
+are nested. The last assignment, corresponding to an invocation of
+setReturned() in the outermost module, wins.
+\subsection{Usage}{
+\if{html}{\out{<div class="r">}}\preformatted{MockShinySession$setReturned(value)}\if{html}{\out{</div>}}
+}
+
+\subsection{Arguments}{
+\if{html}{\out{<div class="arguments">}}
+\describe{
+\item{\code{value}}{The value returned from the module}
+}
+\if{html}{\out{</div>}}
+}
+}
+\if{html}{\out{<hr>}}
+\if{html}{\out{<a id="method-getReturned"></a>}}
+\if{latex}{\out{\hypertarget{method-getReturned}{}}}
+\subsection{Method \code{getReturned()}}{
+Get the value returned by the module call.
+\subsection{Usage}{
+\if{html}{\out{<div class="r">}}\preformatted{MockShinySession$getReturned()}\if{html}{\out{</div>}}
+}
+
+}
+\if{html}{\out{<hr>}}
+\if{html}{\out{<a id="method-genId"></a>}}
+\if{latex}{\out{\hypertarget{method-genId}{}}}
+\subsection{Method \code{genId()}}{
+Return a distinct character identifier for use as a proxy
+namespace.
+\subsection{Usage}{
+\if{html}{\out{<div class="r">}}\preformatted{MockShinySession$genId()}\if{html}{\out{</div>}}
+}
+
 }
 \if{html}{\out{<hr>}}
 \if{html}{\out{<a id="method-clone"></a>}}
+\if{latex}{\out{\hypertarget{method-clone}{}}}
 \subsection{Method \code{clone()}}{
 The objects of this class are cloneable with this method.
 \subsection{Usage}{

man/NS.Rd

@@ -5,7 +5,9 @@
 \alias{NS}
 \alias{ns.sep}
 \title{Namespaced IDs for inputs/outputs}
-\format{An object of class \code{character} of length 1.}
+\format{
+An object of class \code{character} of length 1.
+}
 \usage{
 NS(namespace, id = NULL)
 

man/Progress.Rd

@@ -74,6 +74,7 @@ shinyApp(ui, server)
 }
 \if{html}{\out{<hr>}}
 \if{html}{\out{<a id="method-new"></a>}}
+\if{latex}{\out{\hypertarget{method-new}{}}}
 \subsection{Method \code{new()}}{
 Creates a new progress panel (but does not display it).
 \subsection{Usage}{
@@ -107,6 +108,7 @@ is for backward-compatibility).}
 }
 \if{html}{\out{<hr>}}
 \if{html}{\out{<a id="method-set"></a>}}
+\if{latex}{\out{\hypertarget{method-set}{}}}
 \subsection{Method \code{set()}}{
 Updates the progress panel. When called the first time, the
 progress panel is displayed.
@@ -134,6 +136,7 @@ relative to \code{message}.}
 }
 \if{html}{\out{<hr>}}
 \if{html}{\out{<a id="method-inc"></a>}}
+\if{latex}{\out{\hypertarget{method-inc}{}}}
 \subsection{Method \code{inc()}}{
 Like \code{set}, this updates the progress panel. The difference
 is that \code{inc} increases the progress bar by \code{amount}, instead of
@@ -161,6 +164,7 @@ relative to \code{message}.}
 }
 \if{html}{\out{<hr>}}
 \if{html}{\out{<a id="method-getMin"></a>}}
+\if{latex}{\out{\hypertarget{method-getMin}{}}}
 \subsection{Method \code{getMin()}}{
 Returns the minimum value.
 \subsection{Usage}{
@@ -170,6 +174,7 @@ Returns the minimum value.
 }
 \if{html}{\out{<hr>}}
 \if{html}{\out{<a id="method-getMax"></a>}}
+\if{latex}{\out{\hypertarget{method-getMax}{}}}
 \subsection{Method \code{getMax()}}{
 Returns the maximum value.
 \subsection{Usage}{
@@ -179,6 +184,7 @@ Returns the maximum value.
 }
 \if{html}{\out{<hr>}}
 \if{html}{\out{<a id="method-getValue"></a>}}
+\if{latex}{\out{\hypertarget{method-getValue}{}}}
 \subsection{Method \code{getValue()}}{
 Returns the current value.
 \subsection{Usage}{
@@ -188,6 +194,7 @@ Returns the current value.
 }
 \if{html}{\out{<hr>}}
 \if{html}{\out{<a id="method-close"></a>}}
+\if{latex}{\out{\hypertarget{method-close}{}}}
 \subsection{Method \code{close()}}{
 Removes the progress panel. Future calls to \code{set} and
 \code{close} will be ignored.
@@ -198,6 +205,7 @@ Removes the progress panel. Future calls to \code{set} and
 }
 \if{html}{\out{<hr>}}
 \if{html}{\out{<a id="method-clone"></a>}}
+\if{latex}{\out{\hypertarget{method-clone}{}}}
 \subsection{Method \code{clone()}}{
 The objects of this class are cloneable with this method.
 \subsection{Usage}{

man/actionButton.Rd

@@ -43,7 +43,7 @@ if (interactive()) {
 
 ui <- fluidPage(
   sliderInput("obs", "Number of observations", 0, 1000, 500),
-  actionButton("goButton", "Go!"),
+  actionButton("goButton", "Go!", class = "btn-success"),
   plotOutput("distPlot")
 )
 
@@ -63,6 +63,10 @@ shinyApp(ui, server)
 
 }
 
+## Example of adding extra class values
+actionButton("largeButton", "Large Primary Button", class = "btn-primary btn-lg")
+actionLink("infoLink", "Information Link", class = "btn-info")
+
 }
 \seealso{
 \code{\link[=observeEvent]{observeEvent()}} and \code{\link[=eventReactive]{eventReactive()}}

man/brushOpts.Rd

@@ -5,7 +5,7 @@
 \title{Create an object representing brushing options}
 \usage{
 brushOpts(
-  id = NULL,
+  id,
   fill = "#9cf",
   stroke = "#036",
   opacity = 0.25,

man/builder.Rd

@@ -1,124 +0,0 @@
-\name{builder}
-\alias{builder}
-\alias{tags}
-\alias{p}
-\alias{h1}
-\alias{h2}
-\alias{h3}
-\alias{h4}
-\alias{h5}
-\alias{h6}
-\alias{a}
-\alias{br}
-\alias{div}
-\alias{span}
-\alias{pre}
-\alias{code}
-\alias{img}
-\alias{strong}
-\alias{em}
-\alias{hr}
-\title{HTML Builder Functions}
-\usage{
-tags
-
-p(..., .noWS = NULL)
-
-h1(..., .noWS = NULL)
-
-h2(..., .noWS = NULL)
-
-h3(..., .noWS = NULL)
-
-h4(..., .noWS = NULL)
-
-h5(..., .noWS = NULL)
-
-h6(..., .noWS = NULL)
-
-a(..., .noWS = NULL)
-
-br(..., .noWS = NULL)
-
-div(..., .noWS = NULL)
-
-span(..., .noWS = NULL)
-
-pre(..., .noWS = NULL)
-
-code(..., .noWS = NULL)
-
-img(..., .noWS = NULL)
-
-strong(..., .noWS = NULL)
-
-em(..., .noWS = NULL)
-
-hr(..., .noWS = NULL)
-}
-\arguments{
-\item{...}{Attributes and children of the element. Named arguments become
-attributes, and positional arguments become children. Valid children are
-tags, single-character character vectors (which become text nodes), raw
-HTML (see \code{\link{HTML}}), and \code{html_dependency} objects. You can
-also pass lists that contain tags, text nodes, or HTML. To use boolean
-attributes, use a named argument with a \code{NA} value. (see example)}
-
-\item{.noWS}{A character vector used to omit some of the whitespace that
-would normally be written around this tag. Valid options include
-\code{before}, \code{after}, \code{outside}, \code{after-begin}, and
-\code{before-end}. Any number of these options can be specified.}
-}
-\description{
-Simple functions for constructing HTML documents.
-}
-\details{
-The \code{tags} environment contains convenience functions for all valid
-HTML5 tags. To generate tags that are not part of the HTML5 specification,
-you can use the \code{\link{tag}()} function.
-
-Dedicated functions are available for the most common HTML tags that do not
-conflict with common R functions.
-
-The result from these functions is a tag object, which can be converted using
-\code{\link{as.character}()}.
-}
-\examples{
-doc <- tags$html(
-  tags$head(
-    tags$title('My first page')
-  ),
-  tags$body(
-    h1('My first heading'),
-    p('My first paragraph, with some ',
-      strong('bold'),
-      ' text.'),
-    div(id='myDiv', class='simpleDiv',
-        'Here is a div with some attributes.')
-  )
-)
-cat(as.character(doc))
-
-# create an html5 audio tag with controls.
-# controls is a boolean attributes
-audio_tag <- tags$audio(
-  controls = NA,
-  tags$source(
-    src = "myfile.wav",
-    type = "audio/wav"
-  )
-)
-cat(as.character(audio_tag))
-
-# suppress the whitespace between tags
-oneline <- tags$span(
-  tags$strong("I'm strong", .noWS="outside")
-)
-cat(as.character(oneline))
-}
-\references{
-\itemize{
-   \item W3C html specification about boolean attributes
-   \url{https://www.w3.org/TR/html5/infrastructure.html#sec-boolean-attributes}
- }
-}

man/clickOpts.Rd

@@ -4,7 +4,7 @@
 \alias{clickOpts}
 \title{Create an object representing click options}
 \usage{
-clickOpts(id = NULL, clip = TRUE)
+clickOpts(id, clip = TRUE)
 }
 \arguments{
 \item{id}{Input value name. For example, if the value is \code{"plot_click"},

man/dblclickOpts.Rd

@@ -4,7 +4,7 @@
 \alias{dblclickOpts}
 \title{Create an object representing double-click options}
 \usage{
-dblclickOpts(id = NULL, clip = TRUE, delay = 400)
+dblclickOpts(id, clip = TRUE, delay = 400)
 }
 \arguments{
 \item{id}{Input value name. For example, if the value is

man/hoverOpts.Rd

@@ -5,7 +5,7 @@
 \title{Create an object representing hover options}
 \usage{
 hoverOpts(
-  id = NULL,
+  id,
   delay = 300,
   delayType = c("debounce", "throttle"),
   clip = TRUE,

man/htmlTemplate.Rd

@@ -1,29 +0,0 @@
-\name{htmlTemplate}
-\alias{htmlTemplate}
-\title{Process an HTML template}
-\usage{
-htmlTemplate(filename = NULL, ..., text_ = NULL, document_ = "auto")
-}
-\arguments{
-\item{filename}{Path to an HTML template file. Incompatible with
-\code{text_}.}
-
-\item{...}{Variable values to use when processing the template.}
-
-\item{text_}{A string to use as the template, instead of a file. Incompatible
-with \code{filename}.}
-
-\item{document_}{Is this template a complete HTML document (\code{TRUE}), or
-a fragment of HTML that is to be inserted into an HTML document
-(\code{FALSE})? With \code{"auto"} (the default), auto-detect by searching
-for the string \code{"<HTML>"} within the template.}
-}
-\description{
-Process an HTML template and return a tagList object. If the template is a
-complete HTML document, then the returned object will also have class
-\code{html_document}, and can be passed to the function
-\code{\link{renderDocument}} to get the final HTML text.
-}
-\seealso{
-\code{\link{renderDocument}}
-}

man/include.Rd

@@ -1,44 +0,0 @@
-\name{include}
-\alias{include}
-\alias{includeHTML}
-\alias{includeText}
-\alias{includeMarkdown}
-\alias{includeCSS}
-\alias{includeScript}
-\title{Include Content From a File}
-\usage{
-includeHTML(path)
-
-includeText(path)
-
-includeMarkdown(path)
-
-includeCSS(path, ...)
-
-includeScript(path, ...)
-}
-\arguments{
-\item{path}{The path of the file to be included. It is highly recommended to
-use a relative path (the base path being the Shiny application directory),
-not an absolute path.}
-
-\item{...}{Any additional attributes to be applied to the generated tag.}
-}
-\description{
-Load HTML, text, or rendered Markdown from a file and turn into HTML.
-}
-\details{
-These functions provide a convenient way to include an extensive amount of
-HTML, textual, Markdown, CSS, or JavaScript content, rather than using a
-large literal R string.
-}
-\note{
-\code{includeText} escapes its contents, but does no other processing.
-  This means that hard breaks and multiple spaces will be rendered as they
-  usually are in HTML: as a single space character. If you are looking for
-  preformatted text, wrap the call with \code{\link{pre}}, or consider using
-  \code{includeMarkdown} instead.
-
-The \code{includeMarkdown} function requires the \code{markdown}
-  package.
-}

man/loadSupport.Rd

@@ -5,13 +5,15 @@
 \title{Load an app's supporting R files}
 \usage{
 loadSupport(
-  appDir,
+  appDir = NULL,
   renv = new.env(parent = globalenv()),
   globalrenv = globalenv()
 )
 }
 \arguments{
-\item{appDir}{The application directory}
+\item{appDir}{The application directory. If \code{appDir} is \code{NULL} or
+not supplied, the nearest enclosing directory that is a Shiny app, starting
+with the current directory, is used.}
 
 \item{renv}{The environmeny in which the files in the \verb{R/} directory should
 be evaluated.}

man/markdown.Rd

@@ -0,0 +1,62 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/shiny.R
+\name{markdown}
+\alias{markdown}
+\title{Insert inline Markdown}
+\usage{
+markdown(mds, extensions = TRUE, .noWS = NULL, ...)
+}
+\arguments{
+\item{mds}{A character vector of Markdown source to convert to HTML. If the
+vector has more than one element, a single-element character vector of
+concatenated HTML is returned.}
+
+\item{extensions}{Enable Github syntax extensions; defaults to \code{TRUE}.}
+
+\item{.noWS}{Character vector used to omit some of the whitespace that would
+normally be written around generated HTML. Valid options include \code{before},
+\code{after}, and \code{outside} (equivalent to \code{before} and \code{end}).}
+
+\item{...}{Additional arguments to pass to \code{\link[commonmark:markdown_html]{commonmark::markdown_html()}}.
+These arguments are \emph{\link[rlang:dyn-dots]{dynamic}}.}
+}
+\value{
+a character vector marked as HTML.
+}
+\description{
+This function accepts
+\href{https://en.wikipedia.org/wiki/Markdown}{Markdown}-syntax text and returns
+HTML that may be included in Shiny UIs.
+}
+\details{
+Leading whitespace is trimmed from Markdown text with \code{\link[glue:trim]{glue::trim()}}.
+Whitespace trimming ensures Markdown is processed correctly even when the
+call to \code{markdown()} is indented within surrounding R code.
+
+By default, \link[commonmark:extensions]{Github extensions} are enabled, but this
+can be disabled by passing \code{extensions = FALSE}.
+
+Markdown rendering is performed by \code{\link[commonmark:markdown_html]{commonmark::markdown_html()}}. Additional
+arguments to \code{markdown()} are passed as arguments to \code{markdown_html()}
+}
+\examples{
+ui <- fluidPage(
+  markdown("
+    # Markdown Example
+
+    This is a markdown paragraph, and will be contained within a `<p>` tag
+    in the UI.
+
+    The following is an unordered list, which will be represented in the UI as
+    a `<ul>` with `<li>` children:
+
+    * a bullet
+    * another
+
+    [Links](https://developer.mozilla.org/en-US/docs/Web/HTML/Element/a) work;
+    so does *emphasis*.
+
+    To see more of what's possible, check out [commonmark.org/help](https://commonmark.org/help).
+    ")
+)
+}

man/migrateLegacyShinytest.Rd

@@ -0,0 +1,48 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/test.R
+\name{migrateLegacyShinytest}
+\alias{migrateLegacyShinytest}
+\title{Migrate legacy \pkg{shinytest} files to new test directory structure}
+\usage{
+migrateLegacyShinytest(appdir, prompt = interactive())
+}
+\arguments{
+\item{appdir}{A directory containing a Shiny application.}
+
+\item{prompt}{If \code{TRUE}, ask for confirmation when moving files.}
+}
+\description{
+This function migrates the old-style directory structure used by
+\pkg{shinytest} to (versions 1.3.1 and below) new test directory structure
+used in Shiny 1.5.0 and above.
+}
+\details{
+In Shiny 1.5.0, the \code{\link[=runTests]{runTests()}} function was added, and it will run test
+scripts tests/ subdirectory of the application. The directory structure will
+look something like this:\preformatted{appdir/
+ |- R
+ |- tests
+     |- shinytest.R
+     |- shinytest
+     |   `- mytest.R
+     |- testthat.R
+     `- testthat
+         `- test-script.R
+}
+
+This allows for tests using the \pkg{shinytest} package as well as other
+testing tools, such as the \code{\link[=testServer]{testServer()}} function, which can be used for
+testing module and server logic, and for unit tests of functions in an R/
+subdirectory.
+
+With the \pkg{shinytest} package, in versions 1.3.0 and below, the tests/
+subdirectory of the application was used specifically for \pkg{shinytest},
+and could not be used for other types of tests. So the directory structure
+would look like this:\preformatted{appdir/
+ `- tests
+     `- mytest.R
+}
+
+In \pkg{shinytest} 1.4.0 and above, it defaults to the new directory
+structure.
+}

man/moduleServer.Rd

@@ -31,8 +31,9 @@ modules are easier to reuse and easier to reason about. See the article at
 \url{http://shiny.rstudio.com/articles/modules.html} to learn more.
 }
 \details{
-Starting in Shiny 1.5.0, we recommend using \code{moduleFunction} instead of
-\code{callModule}, because syntax is a little easier to understand.
+Starting in Shiny 1.5.0, we recommend using \code{moduleServer} instead of
+\code{callModule}, because the syntax is a little easier to understand, and
+modules created with \code{moduleServer} can be tested with \code{\link[=testServer]{testServer()}}.
 }
 \examples{
 # Define the UI for a module
@@ -46,16 +47,19 @@ counterUI <- function(id, label = "Counter") {
 
 # Define the server logic for a module
 counterServer <- function(id) {
-  moduleServer(id, function(input, output, session) {
-    count <- reactiveVal(0)
-    observeEvent(input$button, {
-      count(count() + 1)
-    })
-    output$out <- renderText({
-      count()
-    })
-    count
-  })
+  moduleServer(
+    id,
+    function(input, output, session) {
+      count <- reactiveVal(0)
+      observeEvent(input$button, {
+        count(count() + 1)
+      })
+      output$out <- renderText({
+        count()
+      })
+      count
+    }
+  )
 }
 
 # Use the module in an app
@@ -67,7 +71,9 @@ server <- function(input, output, session) {
   counterServer("counter1")
   counterServer("counter2")
 }
-shinyApp(ui, server)
+if (interactive()) {
+  shinyApp(ui, server)
+}
 
 
 
@@ -75,16 +81,19 @@ shinyApp(ui, server)
 # add them to your function. In this case `prefix` is text that will be
 # printed before the count.
 counterServer2 <- function(id, prefix = NULL) {
-  moduleServer(id, function(input, output, session) {
-    count <- reactiveVal(0)
-    observeEvent(input$button, {
-      count(count() + 1)
-    })
-    output$out <- renderText({
-      paste0(prefix, count())
-    })
-    count
-  })
+  moduleServer(
+    id,
+    function(input, output, session) {
+      count <- reactiveVal(0)
+      observeEvent(input$button, {
+        count(count() + 1)
+      })
+      output$out <- renderText({
+        paste0(prefix, count())
+      })
+      count
+    }
+  )
 }
 
 ui <- fluidPage(
@@ -93,7 +102,9 @@ ui <- fluidPage(
 server <- function(input, output, session) {
   counterServer2("counter", "The current count is: ")
 }
-shinyApp(ui, server)
+if (interactive()) {
+  shinyApp(ui, server)
+}
 
 }
 \seealso{

man/plotOutput.Rd

@@ -12,11 +12,7 @@ imageOutput(
   click = NULL,
   dblclick = NULL,
   hover = NULL,
-  hoverDelay = NULL,
-  hoverDelayType = NULL,
   brush = NULL,
-  clickId = NULL,
-  hoverId = NULL,
   inline = FALSE
 )
 
@@ -27,11 +23,7 @@ plotOutput(
   click = NULL,
   dblclick = NULL,
   hover = NULL,
-  hoverDelay = NULL,
-  hoverDelayType = NULL,
   brush = NULL,
-  clickId = NULL,
-  hoverId = NULL,
   inline = FALSE
 )
 }
@@ -67,12 +59,6 @@ named list with \code{x} and \code{y} elements indicating the mouse
 position. To control the hover time or hover delay type, you must use
 \code{\link[=hoverOpts]{hoverOpts()}}.}
 
-\item{hoverDelay}{Deprecated; use \code{hover} instead. Also see the
-\code{\link[=hoverOpts]{hoverOpts()}} function.}
-
-\item{hoverDelayType}{Deprecated; use \code{hover} instead. Also see the
-\code{\link[=hoverOpts]{hoverOpts()}} function.}
-
 \item{brush}{Similar to the \code{click} argument, this can be \code{NULL}
 (the default), a string, or an object created by the
 \code{\link[=brushOpts]{brushOpts()}} function. If you use a value like
@@ -88,12 +74,6 @@ behavior, use \code{\link[=brushOpts]{brushOpts()}}. Multiple
 value; brushing one image or plot will cause any other brushes with the
 same \code{id} to disappear.}
 
-\item{clickId}{Deprecated; use \code{click} instead. Also see the
-\code{\link[=clickOpts]{clickOpts()}} function.}
-
-\item{hoverId}{Deprecated; use \code{hover} instead. Also see the
-\code{\link[=hoverOpts]{hoverOpts()}} function.}
-
 \item{inline}{use an inline (\code{span()}) or block container (\code{div()})
 for the output}
 }

man/reexports.Rd

@@ -1,10 +1,48 @@
 % Generated by roxygen2: do not edit by hand
-% Please edit documentation in R/cache-utils.R
+% Please edit documentation in R/reexports.R
 \docType{import}
 \name{reexports}
 \alias{reexports}
 \alias{key_missing}
 \alias{is.key_missing}
+\alias{tags}
+\alias{p}
+\alias{h1}
+\alias{h2}
+\alias{h3}
+\alias{h4}
+\alias{h5}
+\alias{h6}
+\alias{a}
+\alias{br}
+\alias{div}
+\alias{span}
+\alias{pre}
+\alias{code}
+\alias{img}
+\alias{strong}
+\alias{em}
+\alias{hr}
+\alias{tag}
+\alias{tagList}
+\alias{tagAppendAttributes}
+\alias{tagHasAttribute}
+\alias{tagGetAttribute}
+\alias{tagAppendChild}
+\alias{tagAppendChildren}
+\alias{tagSetChildren}
+\alias{HTML}
+\alias{includeHTML}
+\alias{includeText}
+\alias{includeMarkdown}
+\alias{includeCSS}
+\alias{includeScript}
+\alias{singleton}
+\alias{is.singleton}
+\alias{validateCssUnit}
+\alias{htmlTemplate}
+\alias{suppressDependencies}
+\alias{withTags}
 \title{Objects exported from other packages}
 \keyword{internal}
 \description{
@@ -13,5 +51,7 @@ below to see their documentation.
 
 \describe{
   \item{fastmap}{\code{\link[fastmap]{is.key_missing}}, \code{\link[fastmap]{key_missing}}}
+
+  \item{htmltools}{\code{\link[htmltools]{a}}, \code{\link[htmltools]{br}}, \code{\link[htmltools]{code}}, \code{\link[htmltools]{div}}, \code{\link[htmltools]{em}}, \code{\link[htmltools]{h1}}, \code{\link[htmltools]{h2}}, \code{\link[htmltools]{h3}}, \code{\link[htmltools]{h4}}, \code{\link[htmltools]{h5}}, \code{\link[htmltools]{h6}}, \code{\link[htmltools]{hr}}, \code{\link[htmltools]{HTML}}, \code{\link[htmltools]{htmlTemplate}}, \code{\link[htmltools]{img}}, \code{\link[htmltools]{includeCSS}}, \code{\link[htmltools]{includeHTML}}, \code{\link[htmltools]{includeMarkdown}}, \code{\link[htmltools]{includeScript}}, \code{\link[htmltools]{includeText}}, \code{\link[htmltools]{is.singleton}}, \code{\link[htmltools]{p}}, \code{\link[htmltools]{pre}}, \code{\link[htmltools]{singleton}}, \code{\link[htmltools]{span}}, \code{\link[htmltools]{strong}}, \code{\link[htmltools]{suppressDependencies}}, \code{\link[htmltools]{tag}}, \code{\link[htmltools]{tagAppendAttributes}}, \code{\link[htmltools]{tagAppendChild}}, \code{\link[htmltools]{tagAppendChildren}}, \code{\link[htmltools]{tagGetAttribute}}, \code{\link[htmltools]{tagHasAttribute}}, \code{\link[htmltools]{tagList}}, \code{\link[htmltools]{tags}}, \code{\link[htmltools]{tagSetChildren}}, \code{\link[htmltools]{validateCssUnit}}, \code{\link[htmltools]{withTags}}}
 }}
 

man/runTests.Rd

@@ -4,7 +4,7 @@
 \alias{runTests}
 \title{Runs the tests associated with this Shiny app}
 \usage{
-runTests(appDir = ".", filter = NULL)
+runTests(appDir = ".", filter = NULL, assert = TRUE, envir = globalenv())
 }
 \arguments{
 \item{appDir}{The base directory for the application.}
@@ -12,6 +12,19 @@ runTests(appDir = ".", filter = NULL)
 \item{filter}{If not \code{NULL}, only tests with file names matching this regular
 expression will be executed. Matching is performed on the file name
 including the extension.}
+
+\item{assert}{Logical value which determines if an error should be thrown if any error is captured.}
+
+\item{envir}{Parent testing environment in which to base the individual testing environments.}
+}
+\value{
+A data frame classed with the supplemental class \code{"shiny_runtests"}.
+The data frame has the following columns:\tabular{lll}{
+   \strong{Name} \tab \strong{Type} \tab \strong{Meaning} \cr
+   \code{file} \tab \code{character(1)} \tab File name of the runner script in \verb{tests/} that was sourced. \cr
+   \code{pass} \tab \code{logical(1)} \tab Whether or not the runner script signaled an error when sourced. \cr
+   \code{result} \tab any or \code{NA} \tab The return value of the runner \cr
+}
 }
 \description{
 Sources the \code{.R} files in the top-level of \verb{tests/} much like \verb{R CMD check}.
@@ -20,8 +33,7 @@ directories under \verb{tests/}.
 }
 \details{
 Historically, \href{https://rstudio.github.io/shinytest/}{shinytest}
-recommended placing tests at the top-level of the \verb{tests/} directory. In
-order to support that model, \code{testApp} first checks to see if the \code{.R}
-files in the \verb{tests/} directory are all shinytests; if so, just calls out
-to \code{\link[shinytest:testApp]{shinytest::testApp()}}.
+recommended placing tests at the top-level of the \verb{tests/} directory.
+This older folder structure is not supported by runTests.
+Please see \code{\link[=shinyAppTemplate]{shinyAppTemplate()}} for more details.
 }

man/shinyAppTemplate.Rd

@@ -0,0 +1,70 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/app_template.R
+\name{shinyAppTemplate}
+\alias{shinyAppTemplate}
+\title{Generate a Shiny application from a template}
+\usage{
+shinyAppTemplate(path = NULL, examples = "default", dryrun = FALSE)
+}
+\arguments{
+\item{path}{Path to create new shiny application template.}
+
+\item{examples}{Either one of "default", "ask", "all", or any combination of
+"app", "rdir", "module", "shinytest", and "testthat". In an
+interactive session, "default" falls back to "ask"; in a non-interactive
+session, "default" falls back to "all". With "ask", this function will
+prompt the user to select which template items will be added to the new app
+directory. With "all", all template items will be added to the app
+directory.}
+
+\item{dryrun}{If \code{TRUE}, don't actually write any files; just print out what
+would be written.}
+}
+\description{
+This function populates a directory with files for a Shiny application.
+}
+\details{
+In an interactive R session, this function will, by default, prompt the user
+which components to add to the application.
+
+The full example application includes the following files and directories:\preformatted{appdir/
+|- app.R
+|- R
+|   |- my-module.R
+|   `- sort.R
+`- tests
+    |- shinytest.R
+    |- shinytest
+    |   `- mytest.R
+    |- testthat.R
+    `- testthat
+        |- helper-load.R
+        |- test-mymodule.R
+        |- test-server.R
+        `- test-sort.R
+}
+
+Some notes about these files:
+\itemize{
+\item \code{app.R} is the main application file.
+\item All files in the \verb{R/} subdirectory are automatically sourced when the
+application is run.
+\item \code{R/sort.R} and \code{R/my-module.R} are automatically sourced when
+the application is run. The first contains a function \code{lexical_sort()},
+and the second contains code for a \href{moduleServer()}{Shiny module} which
+is used in the application.
+\item \verb{tests/} contains various tests for the application. You may
+choose to use or remove any of them. They can be executed by the
+\code{\link[=runTests]{runTests()}} function.
+\item \code{tests/shinytest.R} is a test runner for test files in the
+\verb{tests/shinytest/} directory.
+\item \code{tests/shinytest/mytest.R} is a test that uses the
+\href{https://rstudio.github.io/shinytest/}{shinytest} package to do
+snapshot-based testing.
+\item \code{tests/testthat.R} is a test runner for test files in the
+\verb{tests/testthat/} directory using the \href{https://testthat.r-lib.org/}{testthat} package.
+\item \code{tests/testthat/test-mymodule.R} is a test for an application's module server function.
+\item \code{tests/testthat/test-server.R} is a test for the application's server code
+\item \code{tests/testthat/test-sort.R} is a test for a supporting function in the \verb{R/} directory.
+}
+}

man/singleton.Rd

@@ -1,20 +0,0 @@
-\name{singleton}
-\alias{singleton}
-\alias{is.singleton}
-\title{Include content only once}
-\usage{
-singleton(x, value = TRUE)
-
-is.singleton(x)
-}
-\arguments{
-\item{x}{A \code{\link{tag}}, text, \code{\link{HTML}}, or list.}
-
-\item{value}{Whether the object should be a singleton.}
-}
-\description{
-Use \code{singleton} to wrap contents (tag, text, HTML, or lists) that should
-be included in the generated document only once, yet may appear in the
-document-generating code more than once. Only the first appearance of the
-content (in document order) will be used.
-}

man/suppressDependencies.Rd

@@ -1,21 +0,0 @@
-\name{suppressDependencies}
-\alias{suppressDependencies}
-\title{Suppress web dependencies}
-\usage{
-suppressDependencies(...)
-}
-\arguments{
-\item{...}{Names of the dependencies to suppress. For example,
-\code{"jquery"} or \code{"bootstrap"}.}
-}
-\description{
-This suppresses one or more web dependencies. It is meant to be used when a
-dependency (like a JavaScript or CSS file) is declared in raw HTML, in an
-HTML template.
-}
-\seealso{
-\code{\link{htmlTemplate}} for more information about using HTML
-  templates.
-
-\code{\link[htmltools]{htmlDependency}}
-}

man/tag.Rd

@@ -1,82 +0,0 @@
-\name{tag}
-\alias{tag}
-\alias{tagList}
-\alias{tagAppendAttributes}
-\alias{tagHasAttribute}
-\alias{tagGetAttribute}
-\alias{tagAppendChild}
-\alias{tagAppendChildren}
-\alias{tagSetChildren}
-\title{HTML Tag Object}
-\usage{
-tagList(...)
-
-tagAppendAttributes(tag, ...)
-
-tagHasAttribute(tag, attr)
-
-tagGetAttribute(tag, attr)
-
-tagAppendChild(tag, child)
-
-tagAppendChildren(tag, ..., list = NULL)
-
-tagSetChildren(tag, ..., list = NULL)
-
-tag(`_tag_name`, varArgs, .noWS = NULL)
-}
-\arguments{
-\item{...}{Unnamed items that comprise this list of tags.}
-
-\item{tag}{A tag to append child elements to.}
-
-\item{attr}{The name of an attribute.}
-
-\item{child}{A child element to append to a parent tag.}
-
-\item{list}{An optional list of elements. Can be used with or instead of the
-\code{...} items.}
-
-\item{_tag_name}{HTML tag name}
-
-\item{varArgs}{List of attributes and children of the element. Named list
-items become attributes, and unnamed list items become children. Valid
-children are tags, single-character character vectors (which become text
-nodes), and raw HTML (see \code{\link{HTML}}). You can also pass lists that
-contain tags, text nodes, and HTML.}
-
-\item{.noWS}{Character vector used to omit some of the whitespace that would
-normally be written around this tag. Valid options include \code{before},
-\code{after}, \code{outside}, \code{after-begin}, and \code{before-end}.
-Any number of these options can be specified.}
-}
-\value{
-An HTML tag object that can be rendered as HTML using
-  \code{\link{as.character}()}.
-}
-\description{
-\code{tag()} creates an HTML tag definition. Note that all of the valid HTML5
-tags are already defined in the \code{\link{tags}} environment so these
-functions should only be used to generate additional tags.
-\code{tagAppendChild()} and \code{tagList()} are for supporting package
-authors who wish to create their own sets of tags; see the contents of
-bootstrap.R for examples.
-}
-\examples{
-tagList(tags$h1("Title"),
-        tags$h2("Header text"),
-        tags$p("Text here"))
-
-# Can also convert a regular list to a tagList (internal data structure isn't
-# exactly the same, but when rendered to HTML, the output is the same).
-x <- list(tags$h1("Title"),
-          tags$h2("Header text"),
-          tags$p("Text here"))
-tagList(x)
-
-# suppress the whitespace between tags
-oneline <- tag("span",
-  tag("strong", "Super strong", .noWS="outside")
-)
-cat(as.character(oneline))
-}

man/testModule.Rd

@@ -1,73 +0,0 @@
-% Generated by roxygen2: do not edit by hand
-% Please edit documentation in R/test-module.R
-\name{testModule}
-\alias{testModule}
-\alias{testServer}
-\title{Integration testing for Shiny modules or server functions}
-\usage{
-testModule(module, expr, ...)
-
-testServer(expr, appDir = NULL)
-}
-\arguments{
-\item{module}{The module to 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{...}{Additional arguments to pass to the module function. These
-arguments are processed with \code{\link[rlang:list2]{rlang::list2()}} and so are
-\emph{\link[rlang:dyn-dots]{dynamic}}.}
-
-\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.}
-}
-\value{
-The result of evaluating \code{expr}.
-}
-\description{
-Offer a way to test the reactive interactions in Shiny --- either in Shiny
-modules or in the server portion of a Shiny application. For more
-information, visit \href{https://shiny.rstudio.com/articles/integration-testing.html}{the Shiny Dev Center article on integration testing}.
-}
-\examples{
-module <- function(input, output, session, multiplier = 2, prefix = "I am ") {
-  myreactive <- reactive({
-    input$x * multiplier
-  })
-  output$txt <- renderText({
-    paste0(prefix, myreactive())
-  })
-}
-
-# Basic Usage
-# -----------
-testModule(module, {
-  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 ")
-testModule(module, {
-  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)
-}

man/testServer.Rd

@@ -0,0 +1,60 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/test-server.R
+\name{testServer}
+\alias{testServer}
+\title{Reactive testing for Shiny server functions and modules}
+\usage{
+testServer(app = NULL, expr, ...)
+}
+\arguments{
+\item{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 \code{appObj} by \code{as.shiny.appobj}. Application server functions must
+include a \code{session} argument in order to be tested. If \code{app} is \code{NULL} or
+not supplied, the nearest enclosing directory that is a Shiny app, starting
+with the current directory, is used.}
+
+\item{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. \code{input}, \code{output}, and \code{session}) will be available
+along with any other values created inside of the server function.}
+
+\item{...}{Additional arguments to pass to the module function. These
+arguments are processed with \code{\link[rlang:list2]{rlang::list2()}} and so are
+\emph{\link[rlang:dyn-dots]{dynamic}}. If \code{app} is a module, and no \code{id} argument is
+provided, one will be generated and supplied automatically.}
+}
+\value{
+The result of evaluating \code{expr}.
+}
+\description{
+A way to test the reactive interactions in Shiny applications. Reactive
+interactions are defined in the server function of applications and in
+modules.
+}
+\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())
+    })
+  })
+}
+
+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)
+}

man/updateActionButton.Rd

@@ -2,9 +2,12 @@
 % Please edit documentation in R/update-input.R
 \name{updateActionButton}
 \alias{updateActionButton}
+\alias{updateActionLink}
 \title{Change the label or icon of an action button on the client}
 \usage{
 updateActionButton(session, inputId, label = NULL, icon = NULL)
+
+updateActionLink(session, inputId, label = NULL, icon = NULL)
 }
 \arguments{
 \item{session}{The \code{session} object passed to function given to
@@ -42,13 +45,15 @@ can be cleared by using \code{selected=character(0)}.
 if (interactive()) {
 
 ui <- fluidPage(
-  actionButton("update", "Update other buttons"),
+  actionButton("update", "Update other buttons and link"),
   br(),
   actionButton("goButton", "Go"),
   br(),
   actionButton("goButton2", "Go 2", icon = icon("area-chart")),
   br(),
-  actionButton("goButton3", "Go 3")
+  actionButton("goButton3", "Go 3"),
+  br(),
+  actionLink("goLink", "Go Link")
 )
 
 server <- function(input, output, session) {
@@ -69,6 +74,11 @@ server <- function(input, output, session) {
     # unchaged and changes its label
     updateActionButton(session, "goButton3",
       label = "New label 3")
+
+    # Updates goLink's label and icon
+    updateActionButton(session, "goLink",
+      label = "New link label",
+      icon = icon("link"))
   })
 }
 

man/validateCssUnit.Rd

@@ -1,38 +0,0 @@
-\name{validateCssUnit}
-\alias{validateCssUnit}
-\title{Validate proper CSS formatting of a unit}
-\usage{
-validateCssUnit(x)
-}
-\arguments{
-\item{x}{The unit to validate. Will be treated as a number of pixels if a
-unit is not specified.}
-}
-\value{
-A properly formatted CSS unit of length, if possible. Otherwise, will
-  throw an error.
-}
-\description{
-Checks that the argument is valid for use as a CSS unit of length.
-}
-\details{
-\code{NULL} and \code{NA} are returned unchanged.
-
-Single element numeric vectors are returned as a character vector with the
-number plus a suffix of \code{"px"}.
-
-Single element character vectors must be \code{"auto"} or \code{"inherit"},
-a number, or a length calculated by the \code{"calc"} CSS function.
-If the number has a suffix, it must be valid: \code{px},
-\code{\%}, \code{ch}, \code{em}, \code{rem}, \code{pt}, \code{in}, \code{cm},
-\code{mm}, \code{ex}, \code{pc}, \code{vh}, \code{vw}, \code{vmin}, or
-\code{vmax}.
-If the number has no suffix, the suffix \code{"px"} is appended.
-
-
-Any other value will cause an error to be thrown.
-}
-\examples{
-validateCssUnit("10\%")
-validateCssUnit(400)  #treated as '400px'
-}

man/withTags.Rd

@@ -1,39 +0,0 @@
-\name{withTags}
-\alias{withTags}
-\title{Evaluate an expression using \code{tags}}
-\usage{
-withTags(code)
-}
-\arguments{
-\item{code}{A set of tags.}
-}
-\description{
-This function makes it simpler to write HTML-generating code. Instead of
-needing to specify \code{tags} each time a tag function is used, as in
-\code{tags$div()} and \code{tags$p()}, code inside \code{withTags} is
-evaluated with \code{tags} searched first, so you can simply use
-\code{div()} and \code{p()}.
-}
-\details{
-If your code uses an object which happens to have the same name as an
-HTML tag function, such as \code{source()} or \code{summary()}, it will call
-the tag function. To call the intended (non-tags function), specify the
-namespace, as in \code{base::source()} or \code{base::summary()}.
-}
-\examples{
-# Using tags$ each time
-tags$div(class = "myclass",
-  tags$h3("header"),
-  tags$p("text")
-)
-
-# Equivalent to above, but using withTags
-withTags(
-  div(class = "myclass",
-    h3("header"),
-    p("text")
-  )
-)
-
-
-}

revdep/.gitignore

@@ -0,0 +1,3 @@
+*.noindex*
+data.sqlite
+failures.md

revdep/README.md

@@ -0,0 +1,23 @@
+# Platform
+
+|field    |value                        |
+|:--------|:----------------------------|
+|version  |R version 3.6.1 (2019-07-05) |
+|os       |macOS Catalina 10.15.3       |
+|system   |x86_64, darwin15.6.0         |
+|ui       |X11                          |
+|language |(EN)                         |
+|collate  |en_US.UTF-8                  |
+|ctype    |en_US.UTF-8                  |
+|tz       |America/New_York             |
+|date     |2020-03-05                   |
+
+# Dependencies
+
+|package |old   |new     |Δ  |
+|:-------|:-----|:-------|:--|
+|shiny   |1.4.0 |1.4.0.1 |*  |
+|rlang   |NA    |0.4.5   |*  |
+
+# Revdeps
+

revdep/problems.md

@@ -0,0 +1 @@
+*Wow, no problems at all. :)*

revdep/revdep-cran-comments.md

@@ -0,0 +1,6 @@
+## revdepcheck results
+
+We checked 836 reverse dependencies (719 from CRAN + 117 from BioConductor), comparing R CMD check results across CRAN and dev versions of this package.
+
+ * We saw 0 new problems
+ * We failed to check 0 packages

tests/test-all.R

@@ -1,4 +1,8 @@
-library(testthat)
-library(shiny)
 
-test_check("shiny")
+# only test if testthat is available
+if (require(testthat)) {
+  library(testthat)
+  library(shiny)
+
+  test_check("shiny")
+}

tests/test-helpers/app1-standard/R/helperCap.R

@@ -1,2 +1,2 @@
-
+source_wd <- getwd()
 helper1 <- 123

tests/test-helpers/app1-standard/global.R

@@ -1 +1,2 @@
 global <- "ABC"
+global_wd <- getwd()

tests/test-helpers/app1-standard/tests/runner1.R

@@ -1,2 +1,2 @@
 
-a <- 1
+runner1_A <- 1

tests/test-helpers/app1-standard/tests/runner2.R

@@ -1,13 +1,19 @@
 
-b <- 2
-
 
-if (!identical(helper1, "abc")){
-  stop("Missing helper1")
-}
-if (!identical(helper2, 123)){
-  stop("Missing helper2")
-}
-if (exists("a")){
-  stop("a exists -- are we leaking in between test environments?")
-}
+
+withr::with_environment(
+  shiny::loadSupport("../"),
+  {
+    runner2_B <- 2
+
+    if (!identical(helper1, 123)){
+      stop("Missing helper1")
+    }
+    if (!identical(helper2, "abc")){
+      stop("Missing helper2")
+    }
+    if (exists("runner1_A")){
+      stop("runner1_A exists -- are we leaking in between test environments?")
+    }
+  }
+)

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

@@ -48,7 +48,7 @@ ui <- fluidPage(
 )
 
 # Define server logic for random distribution app ----
-server <- function(input, output) {
+server <- function(input, output, session) {
 
   # Reactive expression to generate the requested distribution ----
   # This is called whenever the inputs change. The output functions

tests/test-modules/107_scatterplot/R/linked-scatterplot-module.R

@@ -0,0 +1,37 @@
+
+
+
+
+
+linkedScatterUI <- function(id) {
+  ns <- NS(id)
+
+  fluidRow(
+    column(6, plotOutput(ns("plot1"), brush = ns("brush"))),
+    column(6, plotOutput(ns("plot2"), brush = ns("brush")))
+  )
+}
+
+linkedScatterServer <- function(id, data, left, right) {
+  moduleServer(
+    id,
+    function(input, output, session) {
+      # Yields the data frame with an additional column "selected_"
+      # that indicates whether that observation is brushed
+      dataWithSelection <- reactive({
+        # dput(input$brush)
+        brushedPoints(data(), input$brush, allRows = TRUE)
+      })
+
+      output$plot1 <- renderPlot({
+        scatterPlot(dataWithSelection(), left())
+      })
+
+      output$plot2 <- renderPlot({
+        scatterPlot(dataWithSelection(), right())
+      })
+
+      return(dataWithSelection)
+    }
+  )
+}

tests/test-modules/107_scatterplot/R/scatterplot.R

@@ -0,0 +1,7 @@
+alpha_val <- 0.2
+
+scatterPlot <- function(data, cols) {
+  ggplot(data, aes_string(x = cols[1], y = cols[2])) +
+    geom_point(aes(color = selected_), alpha = alpha_val) +
+    scale_color_manual(values = c("black", "#66D65C"), guide = FALSE)
+}

tests/test-modules/107_scatterplot/app.R

@@ -0,0 +1,24 @@
+library(shiny)
+library(ggplot2)
+
+
+ui <- fixedPage(
+  h2("Module example"),
+  linkedScatterUI("scatters"),
+  textOutput("summary")
+)
+
+server <- function(input, output, session) {
+  df <- linkedScatterServer(
+    "scatters",
+    reactive(mpg), # data
+    left = reactive(c("cty", "hwy")),
+    right = reactive(c("drv", "hwy"))
+  )
+
+  output$summary <- renderText({
+    sprintf("%d observation(s) selected", sum(df()$selected_))
+  })
+}
+
+shinyApp(ui, server)

tests/test-modules/107_scatterplot/tests/testthat.R

@@ -0,0 +1,7 @@
+library(testthat)
+
+test_dir(
+  "./testthat",
+  env = shiny::loadSupport("../"),
+  reporter = c("progress", "fail")
+)

tests/test-modules/107_scatterplot/tests/testthat/test-linked-scatterplot-module.R

@@ -0,0 +1,36 @@
+
+context("linkedScatterServer")
+
+testServer(
+  linkedScatterServer,
+  data = reactive(ggplot2::mpg),
+  left = reactive(c("cty", "hwy")),
+  right = reactive(c("drv", "hwy")),
+  {
+
+    # Init count... 0
+    expect_equal(sum(dataWithSelection()$selected_), 0)
+
+    # Select a region
+    session$setInputs(
+      brush =
+        list(xmin = 0.84909732337501, xmax = 1.289072630224, ymin = 23.228930276968,
+          ymax = 29.434482709514, coords_css = list(xmin = 105.5999755859,
+              xmax = 176.5999755859, ymin = 172.2000007629, ymax = 236.2000007629),
+          coords_img = list(xmin = 263.99993896475, xmax = 441.49993896475,
+              ymin = 430.50000190725, ymax = 590.50000190725), img_css_ratio = list(
+              x = 2.5, y = 2.5), mapping = list(colour = "selected_",
+              x = "drv", y = "hwy"), domain = list(left = 0.4, right = 3.6,
+              bottom = 10.4, top = 45.6, discrete_limits = list(x = list(
+                  "4", "f", "r"))), range = list(left = 82.8198280399793,
+              right = 1373.80136986301, bottom = 921.272945432678,
+              top = 13.6986301369863), log = list(x = NULL, y = NULL),
+          direction = "xy", brushId = "scatters-brush", outputId = "scatters-plot2"
+        )
+    )
+
+    # Check the value of the reactiveVal `count()`
+    expect_equal(sum(dataWithSelection()$selected_), 23)
+
+  }
+)

tests/test-modules/107_scatterplot/tests/testthat/test-plot.R

@@ -0,0 +1,7 @@
+
+context("plot")
+
+test_that("Value exists", {
+  expect_true(exists("alpha_val"))
+  expect_equal(alpha_val, 0.2)
+})

tests/test-modules/107_scatterplot/tests/testthat/test-server.R

@@ -0,0 +1,29 @@
+context("app")
+
+testServer(expr = {
+  # Init count... 0
+  expect_equal(sum(df()$selected_), 0)
+  expect_equal(output$summary, "0 observation(s) selected")
+
+  # Select a region
+  session$setInputs(
+    `scatters-brush` =
+      list(xmin = 0.84909732337501, xmax = 1.289072630224, ymin = 23.228930276968,
+        ymax = 29.434482709514, coords_css = list(xmin = 105.5999755859,
+            xmax = 176.5999755859, ymin = 172.2000007629, ymax = 236.2000007629),
+        coords_img = list(xmin = 263.99993896475, xmax = 441.49993896475,
+            ymin = 430.50000190725, ymax = 590.50000190725), img_css_ratio = list(
+            x = 2.5, y = 2.5), mapping = list(colour = "selected_",
+            x = "drv", y = "hwy"), domain = list(left = 0.4, right = 3.6,
+            bottom = 10.4, top = 45.6, discrete_limits = list(x = list(
+                "4", "f", "r"))), range = list(left = 82.8198280399793,
+            right = 1373.80136986301, bottom = 921.272945432678,
+            top = 13.6986301369863), log = list(x = NULL, y = NULL),
+        direction = "xy", brushId = "scatters-brush", outputId = "scatters-plot2"
+      )
+  )
+
+  # Check the value of the reactiveVal `count()`
+  expect_equal(sum(df()$selected_), 23)
+  expect_equal(output$summary, "23 observation(s) selected")
+})

tests/test-modules/12_counter/R/my-module.R

@@ -0,0 +1,23 @@
+mymoduleUI <- function(id, label = "Counter") {
+  ns <- NS(id)
+  tagList(
+    actionButton(ns("button"), label = label),
+    verbatimTextOutput(ns("out"))
+  )
+}
+
+mymoduleServer <- function(id) {
+  moduleServer(
+    id,
+    function(input, output, session) {
+      count <- reactiveVal(0)
+      observeEvent(input$button, {
+        count(count() + 1)
+      })
+      output$out <- renderText({
+        count()
+      })
+      count
+    }
+  )
+}

tests/test-modules/12_counter/R/utils.R

@@ -0,0 +1,5 @@
+# Given a numeric vector, convert to strings, sort, and convert back to
+# numeric.
+lexical_sort <- function(x) {
+  as.numeric(sort(as.character(x)))
+}

tests/test-modules/12_counter/app.R

@@ -0,0 +1,32 @@
+library(shiny)
+
+ui <- fluidPage(
+  # ======== Modules ========
+  # mymoduleUI is defined in R/my-module.R
+  mymoduleUI("mymodule1", "Click counter #1"),
+  mymoduleUI("mymodule2", "Click counter #2"),
+  # =========================
+  wellPanel(
+    sliderInput("size", "Data size", min = 5, max = 20, value = 10),
+    div("Lexically sorted sequence:"),
+    verbatimTextOutput("sequence")
+  )
+)
+
+server <- function(input, output, session) {
+  # ======== Modules ========
+  # mymoduleServer is defined in R/my-module.R
+  mymoduleServer("mymodule1")
+  mymoduleServer("mymodule2")
+  # =========================
+
+  data <- reactive({
+    # lexical_sort from R/utils.R
+    lexical_sort(seq_len(input$size))
+  })
+  output$sequence <- renderText({
+    paste(data(), collapse = " ")
+  })
+}
+
+shinyApp(ui, server)

tests/test-modules/12_counter/tests/testthat.R

@@ -0,0 +1,10 @@
+library(testthat)
+
+# Run in the "current" environment, because shiny::runTests() is going to
+# provision a new environment that's just for our test. And we'll want access to
+# the supporting files that were already loaded into that env.
+testthat::test_dir(
+  "./testthat",
+  env = shiny::loadSupport("../"),
+  reporter = c("summary", "fail")
+)

tests/test-modules/12_counter/tests/testthat/test-mymodule.R

@@ -0,0 +1,18 @@
+
+context("mymoduleServer")
+
+testServer(mymoduleServer, {
+  # Set initial value of a button
+  session$setInputs(button = 0)
+
+  # Check the value of the reactiveVal `count()`
+  expect_equal(count(), 1)
+  # Check the value of the renderText()
+  expect_equal(output$out, "1")
+
+  # Simulate a click
+  session$setInputs(button = 1)
+
+  expect_equal(count(), 2)
+  expect_equal(output$out, "2")
+})

tests/test-modules/12_counter/tests/testthat/test-server.R

@@ -0,0 +1,11 @@
+# Use testthat just for expectations
+context("App")
+
+testServer(expr = {
+  # Set the `size` slider and check the output
+  session$setInputs(size = 6)
+  expect_equal(output$sequence, "1 2 3 4 5 6")
+
+  session$setInputs(size = 12)
+  expect_equal(output$sequence, paste0(lexical_sort(1:12), collapse = " "))
+})

tests/test-modules/12_counter/tests/testthat/test-utils.R

@@ -0,0 +1,7 @@
+context("utils")
+
+# Test the lexical_sort function from R/utils.R
+test_that("Lexical sorting works", {
+  expect_equal(lexical_sort(c(1, 2, 3)), c(1, 2, 3))
+  expect_equal(lexical_sort(c(1, 2, 3, 13, 11, 21)), c(1, 11, 13, 2, 21, 3))
+})

tests/test-modules/server_r/server.R

@@ -1,7 +1,7 @@
 library(shiny)
 
 # Define server logic for random distribution app ----
-function(input, output) {
+function(input, output, session) {
 
   # Reactive expression to generate the requested distribution ----
   # This is called whenever the inputs change. The output functions

tests/testthat/test-actionButton.R

@@ -0,0 +1,59 @@
+context("actionButton")
+
+test_that("Action button accepts class arguments", {
+  make_button <- function(class) {
+    if (missing(class)) {
+      actionButton("id", "label")
+    } else {
+      actionButton("id", "label", class = class)
+    }
+  }
+  act <- make_button()
+  get_class <- function(act) {
+    act_html <- format(act)
+    regmatches(act_html, regexec("class=\"[^\"]\"", act_html))[[1]]
+  }
+  act_class <- get_class(act)
+  expect_equal(
+    get_class(make_button(NULL)), act_class
+  )
+  expect_equal(
+    get_class(make_button(NA)), act_class
+  )
+  expect_equal(
+    get_class(make_button("extra")), sub("\"$", " extra\"", act_class)
+  )
+  expect_equal(
+    get_class(make_button("extra extra2")), sub("\"$", " extra extra2\"", act_class)
+  )
+})
+
+
+
+test_that("Action link accepts class arguments", {
+  make_link <- function(class) {
+    if (missing(class)) {
+      actionLink("id", "label")
+    } else {
+      actionLink("id", "label", class = class)
+    }
+  }
+  act <- make_link()
+  get_class <- function(act) {
+    act_html <- format(act)
+    regmatches(act_html, regexec("class=\"[^\"]\"", act_html))[[1]]
+  }
+  act_class <- get_class(act)
+  expect_equal(
+    get_class(make_link(NULL)), act_class
+  )
+  expect_equal(
+    get_class(make_link(NA)), act_class
+  )
+  expect_equal(
+    get_class(make_link("extra")), sub("\"$", " extra\"", act_class)
+  )
+  expect_equal(
+    get_class(make_link("extra extra2")), sub("\"$", " extra extra2\"", act_class)
+  )
+})

tests/testthat/test-app.R

@@ -12,24 +12,6 @@ test_that("files are loaded into the right env", {
   expect_equal(get("global", genv, inherits=FALSE), "ABC")
 })
 
-test_that("loadSupport messages to inform about loading", {
-  renv <- new.env(parent=environment())
-  genv <- new.env(parent=environment())
-
-  # Plural
-  expect_message(loadSupport(test_path("../test-helpers/app1-standard"), renv=renv, globalrenv=genv),
-                 "Automatically loading 2 .R files")
-  # Singular
-  expect_message(loadSupport(test_path("../test-helpers/app2-nested"), renv=renv, globalrenv=NULL),
-                 "Automatically loading 1 .R file")
-})
-
-test_that("loadSupport skips if _disable_autoload.R found", {
-  expect_message(loadSupport(test_path("../test-helpers/app6-disabled"), renv=environment(), globalrenv=NULL),
-                 "disable_autoload.R detected; not loading")
-  expect_false(exists("helper1"))
-})
-
 test_that("Can suppress sourcing global.R", {
   # Confirm that things blow up if we source global.R
   expect_error(loadSupport(test_path("../test-helpers/app3-badglobal")))
@@ -89,7 +71,7 @@ test_that("With ui/server.R, global.R is loaded before R/ helpers and into the r
 
   # Should have seen three calls -- first to global then to the helpers
   expect_length(calls, 3)
-  expect_match(calls[[1]][[1]], "/global\\.R$", perl=TRUE)
+  expect_match(calls[[1]][[1]], "global\\.R$", perl=TRUE)
   expect_match(calls[[2]][[1]], "/helperCap\\.R$", perl=TRUE)
   expect_match(calls[[3]][[1]], "/helperLower\\.r$", perl=TRUE)
 
@@ -147,7 +129,7 @@ test_that("Loading supporting R files is opt-out", {
 
   # Should have seen three calls from global.R -- helpers are enabled
   expect_length(calls, 3)
-  expect_match(calls[[1]][[1]], "/global\\.R$", perl=TRUE)
+  expect_match(calls[[1]][[1]], "global\\.R$", perl=TRUE)
 })
 
 
@@ -187,7 +169,7 @@ test_that("app.R is loaded after R/ helpers and into the right envs", {
   }
 
   # Temporarily opt-in to R/ file autoloading
-  orig <- getOption("shiny.autoload.r", FALSE)
+  orig <- getOption("shiny.autoload.r", NULL)
   options(shiny.autoload.r=TRUE)
   on.exit({options(shiny.autoload.r=orig)}, add=TRUE)
 
@@ -215,3 +197,16 @@ test_that("app.R is loaded after R/ helpers and into the right envs", {
   # app.R is sourced into a child environment of the helpers
   expect_identical(parent.env(calls[[2]]$envir), helperEnv1)
 })
+
+test_that("global.R and sources in R/ are sourced in the app directory", {
+  appDir <- test_path("../test-helpers/app1-standard")
+  appGlobalEnv <- new.env(parent = globalenv())
+  appEnv <- new.env(parent = appGlobalEnv)
+  loadSupport(appDir, renv = appEnv, globalrenv = appGlobalEnv)
+
+  # Set by ../test-helpers/app1-standard/global.R
+  expect_equal(appGlobalEnv$global_wd, normalizePath(appDir))
+
+  # Set by ../test-helpers/app1-standard/R/helperCap.R
+  expect_equal(appEnv$source_wd, normalizePath(appDir))
+})

tests/testthat/test-inline-markdown.R

@@ -0,0 +1,69 @@
+context("inline-markdown")
+
+test_that("Markdown without newlines translates", {
+  expect_equivalent(markdown("# a top level"), HTML("<h1>a top level</h1>\n"))
+  expect_equivalent(markdown("## a subheading"), HTML("<h2>a subheading</h2>\n"))
+  expect_equivalent(markdown("[rstudio](https://rstudio.com)"), HTML("<p><a href=\"https://rstudio.com\">rstudio</a></p>\n"))
+})
+
+test_that("HTML has correct attributes", {
+  html <- markdown("a paragraph", .noWS = "outside")
+  expect_is(html, "html")
+  expect_equal(attr(html, "noWS"), "outside")
+})
+
+test_that("Github extensions are on by default", {
+  html <- markdown("a ~paragraph~ with a link: https://example.com")
+  expect_equivalent(html, HTML("<p>a <del>paragraph</del> with a link: <a href=\"https://example.com\">https://example.com</a></p>\n"))
+})
+
+test_that("Github extensions can be disabled", {
+  html <- markdown("a ~paragraph~", extensions = FALSE)
+  expect_equivalent(html, HTML("<p>a ~paragraph~</p>\n"))
+})
+
+test_that("Additional options are respected", {
+  html <- markdown("a ~paragraph~", extensions = FALSE, sourcepos = TRUE)
+  expect_equivalent(html, HTML("<p data-sourcepos=\"1:1-1:13\">a ~paragraph~</p>\n"))
+})
+
+test_that("Multiline markdown works properly", {
+  essay <- "
+   # The [Louisiana Purchase](https://en.wikipedia.org/wiki/Louisiana_Purchase)
+   
+   Larry Sellers
+   Mrs. Jamtoss
+   History Period 4
+
+   ## Introduction
+
+   The most important purchase in history is the Lousiana
+   Purchase. It was also the most important evente. It
+   happened in President Jeffersons 1st administration.
+   Its when the United States bought 827,987 square miles
+   of lande from the French guys.
+
+   The end."
+
+  # Ensure markdown string contains leading whitespace, which might be removed
+  # by some editors. We care about it here to ensure blank are ignored in the
+  # conversion to markdown. The line being tested here is the one after the one
+  # that starts with "   # The [Louis...". It should contain three spaces.
+  expect_equal(strsplit(essay, "\n")[[1]][[3]], "   ")
+
+  expected <- HTML(paste0(c(
+    "<h1>The <a href=\"https://en.wikipedia.org/wiki/Louisiana_Purchase\">Louisiana Purchase</a></h1>",
+    "<p>Larry Sellers",
+    "Mrs. Jamtoss",
+    "History Period 4</p>",
+    "<h2>Introduction</h2>",
+    "<p>The most important purchase in history is the Lousiana",
+    "Purchase. It was also the most important evente. It",
+    "happened in President Jeffersons 1st administration.",
+    "Its when the United States bought 827,987 square miles",
+    "of lande from the French guys.</p>",
+    "<p>The end.</p>",
+    ""
+  ), collapse = "\n"))
+  expect_equivalent(markdown(essay), expected)
+})

tests/testthat/test-pkgdown.R

@@ -1,40 +1,17 @@
+
 context("pkgdown")
 
-get_exported <- function() {
-  if (all(file.exists(c('../../inst/_pkgdown.yml', '../../man')))) {
-    # We're running tests on a source tree, likely by devtools::test()
-    sub("\\.Rd", "", list.files("../../man", pattern = "*.Rd"))
-  } else {
-    # We're testing an installed package, possibly for R CMD check
-    unique(unname(readRDS("../../shiny/help/aliases.rds")))
-  }
-}
 
-get_indexed <- function(f = system.file('_pkgdown.yml', package = 'shiny')) {
-  unlist(lapply(yaml::yaml.load_file(f)$reference, function(x) x$contents))
-}
-
-test_that("All man pages have an entry in _pkgdown.yml", {
+test_that("pkgdown works", {
   skip_on_cran()
-  indexed_topics <- get_indexed()
-  all_topics     <- get_exported()
 
-  ## Known not to be indexed
-  known_unindexed <- c("shiny-package", "stacktrace", "knitr_methods",
-                       "pageWithSidebar", "headerPanel", "shiny.appobj",
-                       "deprecatedReactives")
+  # only test pkgdown from within `devtools::test()`
+  ## `./tools` will not exist when shiny is installed
+  pkgdown_file <- "../../tools/documentation/checkPkgdown.R"
+  if (file.exists(pkgdown_file)) {
+    source(pkgdown_file)
+  }
+
+  expect_true(TRUE)
 
-  ## This test ensures that every documented topic is included in
-  ## staticdocs/index.r, unless explicitly waived by specifying it
-  ## in the known_unindexed variable above.
-  missing <- setdiff(all_topics, c(known_unindexed, indexed_topics))
-  unknown <- setdiff(c(known_unindexed, indexed_topics), all_topics)
-  expect_equal(length(missing), 0,
-    info = paste("Functions missing from _pkgdown.yml:\n",
-      paste("  ", missing, sep = "", collapse = "\n"),
-      sep = ""))
-  expect_equal(length(unknown), 0,
-    info = paste("Unrecognized functions in _pkgdown.yml:\n",
-      paste("  ", unknown, sep = "", collapse = "\n"),
-      sep = ""))
 })

tests/testthat/test-reactivity.r

@@ -1,5 +1,11 @@
 context("reactivity")
 
+test_that("reactive and reactiveVal are functions", {
+  expect_s3_class(reactive({1}), "function")
+  expect_s3_class(reactiveVal(1), "function")
+})
+
+
 
 test_that("ReactiveVal", {
   val <- reactiveVal()
@@ -1097,6 +1103,10 @@ test_that("event handling helpers take correct dependencies", {
 })
 
 run_debounce_throttle <- function(do_priming) {
+  # Some of the CRAN test machines are heavily loaded and so the timing for
+  # these tests isn't reliable. https://github.com/rstudio/shiny/pull/2789
+  skip_on_cran()
+
   # The changing of rv$a will be the (chatty) source of reactivity.
   rv <- reactiveValues(a = 0)
 

tests/testthat/test-test-module.R

@@ -1,738 +0,0 @@
-context("testModule")
-
-library(promises)
-library(future)
-plan(multisession)
-
-test_that("testModule passes dots", {
-  module <- function(input, output, session, someArg) {
-    expect_false(missing(someArg))
-    expect_equal(someArg, 123)
-  }
-  testModule(module, {}, someArg = 123)
-})
-
-test_that("testModule passes dynamic dots", {
-  module <- function(input, output, session, someArg) {
-    expect_false(missing(someArg))
-    expect_equal(someArg, 123)
-  }
-
-  # Test with !!! to splice in a whole named list constructed with base::list()
-  moreArgs <- list(someArg = 123)
-  testModule(module, {}, !!!moreArgs)
-
-  # Test with !!/:= to splice in an argument name
-  argName <- "someArg"
-  testModule(module, {}, !!argName := 123)
-})
-
-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(){ rnorm(1) }, function(){
-      isolate(rv$x <- rv$x + 1)
-      rnorm(1)
-    })
-
-    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("testModule works with nested modules", {
-  outerModule <- function(input, output, session) {
-    r1 <- reactive({ input$x + 1})
-    r2 <- callModule(innerModule, "innerModule", r1)
-    output$someVar <- renderText(r2())
-  }
-
-  innerModule <- function(input, output, session, r) {
-    reactive(paste("a value:", r()))
-  }
-
-  testModule(outerModule, {
-    session$setInputs(x = 1)
-    expect_equal(output$someVar, "a value: 2")
-  })
-})
-
-test_that("testModule calls can be nested", {
-  outerModule <- function(input, output, session) {
-    doubled <- reactive({ input$x * 2 })
-    innerModule <- function(input, output, session) {
-      quadrupled <- reactive({ doubled() * 2 })
-    }
-  }
-
-  testModule(outerModule, {
-    session$setInputs(x = 1)
-    expect_equal(doubled(), 2)
-    testModule(innerModule, {
-      expect_equal(quadrupled(), 4)
-    })
-  })
-})
-
-test_that("testModule returns a meaningful result", {
-  result <- testModule(function(input, output, session) {
-    reactive({ input$x * 2 })
-  }, {
-    session$setInputs(x = 2)
-    session$returned()
-  })
-  expect_equal(result, 4)
-})
-
-test_that("assigning an output in a module function with a non-function errors", {
-  module <- function(input, output, session) {
-    output$someVar <- 123
-  }
-
-  expect_error(testModule(module, {}), "^Unexpected")
-})
-
-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("..", "test-modules", "06_tabsets"))
-
-  # server.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("..", "test-modules", "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.
-  testServer({
-    expect_equal(get("global", session$env), 123)
-  }, appDir=test_path("..", "test-modules", "06_tabsets"))
-})
-
-test_that("testModule allows lexical environment access through session$env", {
-  m <- local({
-    a_var <- 123
-    function(input, output, session) {
-      b_var <- 321
-    }
-  })
-  expect_false(exists("a_var", inherits = FALSE))
-  testModule(m, {
-    expect_equal(b_var, 321)
-    expect_equal(get("a_var", session$env), 123)
-  })
-})
-
-test_that("Module shadowing can be mitigated with unquote", {
-  i <- 0
-  inc <- function() i <<- i+1
-
-  m <- local({
-    function(input, output, session) {
-      inc <- function() stop("I should never be called")
-    }
-  })
-
-  testModule(m, {
-    expect_is(inc, "function")
-    expect_false(identical(inc, !!inc))
-    !!inc()
-  })
-
-  expect_equal(i, 1)
-})
-
-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
-
-    path <- normalizePath(path, mustWork = FALSE)
-
-    appPath <- normalizePath(file.path(cd, "app.R"), mustWork = FALSE)
-    serverPath <- normalizePath(file.path(cd, "server.R"), mustWork = FALSE)
-    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.
-  f <- fa()
-  expect_equal(normalizePath(f, mustWork = FALSE), cd)
-  expect_equal(calls, 3) # Two for current dir and hit on the first in the parent
-})

tests/testthat/test-test-moduleServer.R

@@ -1,23 +0,0 @@
-context("testModule-moduleServer")
-
-test_that("New-style modules work", {
-  counterServer <- local({
-    function(id) {
-      moduleServer(id, function(input, output, session) {
-        count <- reactiveVal(0)
-        observeEvent(input$button, {
-          count(count() + 1)
-        })
-        output$out <- renderText({
-          count()
-        })
-        count
-      })
-    }
-  })
-  testModule(counterServer, {
-    input$setInputs(button = 0)
-    input$setInputs(button = 1)
-    expect_equal(count(), 1)
-  }, id = "foob")
-})

tests/testthat/test-test-server-app.R

@@ -0,0 +1,108 @@
+context("testServer app")
+
+library(shiny)
+library(testthat)
+
+test_that("testServer works with dir app", {
+  # app.R
+  testServer(test_path("..", "test-modules", "06_tabsets"), {
+    session$setInputs(dist="norm", n=5)
+    expect_length(d(), 5)
+
+    session$setInputs(dist="unif", n=6)
+    expect_length(d(), 6)
+  })
+
+  # server.R
+  testServer(test_path("..", "test-modules", "server_r"), {
+    session$setInputs(dist="norm", n=5)
+    expect_length(d(), 5)
+
+    session$setInputs(dist="unif", n=6)
+    expect_length(d(), 6)
+  })
+})
+
+test_that("testServer works when referencing external globals", {
+  # If global is defined at the top of app.R outside of the server function.
+  testServer(test_path("..", "test-modules", "06_tabsets"), {
+    expect_equal(get("global", session$env), 123)
+  })
+})
+
+test_that("testServer defaults to the app at .", {
+  curwd <- getwd()
+  on.exit(setwd(curwd))
+  setwd(test_path("..", "test-modules", "06_tabsets"))
+  testServer(expr = {
+    expect_equal(get("global", session$env), 123)
+  })
+})
+
+test_that("runTests works with a dir app that calls modules and uses testServer", {
+  app <- test_path("..", "test-modules", "12_counter")
+  run <- testthat::expect_output(
+    print(runTests(app)),
+    "Shiny App Test Results\\n\\* Success\\n  - 12_counter/tests/testthat\\.R"
+  )
+  expect_true(all(run$pass))
+})
+
+test_that("runTests works with a dir app that calls modules that return reactives and use brushing", {
+  app <- test_path("..", "test-modules", "107_scatterplot")
+  run <- testthat::expect_output(
+    print(runTests(app)),
+    "Shiny App Test Results\\n\\* Success\\n  - 107_scatterplot/tests/testthat\\.R"
+  )
+  expect_true(all(run$pass))
+})
+
+test_that("a Shiny app object with a module inside can be tested", {
+
+  counterUI <- function(id, label = "Counter") {
+    ns <- NS(id)
+    tagList(
+      actionButton(ns("button"), label = label),
+      verbatimTextOutput(ns("out"))
+    )
+  }
+
+  counterServer <- function(id) {
+    moduleServer(
+      id,
+      function(input, output, session) {
+        count <- reactiveVal(0)
+        observeEvent(input$button, {
+          count(count() + 1)
+        })
+        output$out <- renderText({
+          count()
+        })
+        count
+      }
+    )
+  }
+
+  ui <- fluidPage(
+    textInput("number", "A number"),
+    textOutput("numberDoubled"),
+    counterUI("counter1", "Counter #1"),
+    counterUI("counter2", "Counter #2")
+  )
+  server <- function(input, output, session) {
+    counterServer("counter1")
+    counterServer("counter2")
+    doubled <- reactive( { as.integer(input$number) * 2 })
+    output$numberDoubled <- renderText({ doubled() })
+  }
+  app <- shinyApp(ui, server)
+
+  testServer(app, {
+    session$setInputs(number = "42")
+    expect_equal(doubled(), 84)
+  })
+})
+
+test_that("It's an error to pass arguments to a server", {
+  expect_error(testServer(test_path("..", "test-modules", "06_tabsets"), {}, an_arg = 123))
+})

tests/testthat/test-test-server-nesting.R

@@ -0,0 +1,89 @@
+context("testServer nesting")
+
+library(shiny)
+library(testthat)
+
+test_that("Nested modules", {
+  child <- function(id) {
+    moduleServer(id, function(input, output, session) {
+      output$txt <- renderText("bar")
+    })
+  }
+
+  parent <- function(id) {
+    moduleServer(id, function(input, output, session) {
+      output$txt <- renderText("foo")
+      child("child-id")
+    })
+  }
+
+  testServer(parent, {
+    expect_equal(output$txt, "foo")
+  }, id = "parent-id")
+
+})
+
+test_that("Lack of ID", {
+  module <- function(id) {
+    moduleServer(id, function(input, output, session) {
+      output$txt <- renderText(session$ns("x"))
+    })
+  }
+
+  testServer(module, {
+    expect_equal(output$txt, "foo-x")
+  }, id = "foo")
+})
+
+test_that("testServer works with nested module servers", {
+  outerModule <- function(id) {
+    moduleServer(id, function(input, output, session) {
+      r1 <- reactive({ input$x + 1})
+      r2 <- innerModule("inner", r1)
+      output$someVar <- renderText(r2())
+    })
+  }
+
+  innerModule <- function(id, r) {
+    moduleServer(id, function(input, output, session) {
+      reactive(paste("a value:", r()))
+    })
+  }
+
+  testServer(outerModule, {
+    session$setInputs(x = 1)
+    expect_equal(output$someVar, "a value: 2")
+  }, id = "foo")
+})
+
+test_that("testServer calls do not nest in module functions", {
+  module <- function(id) {
+    moduleServer(id, function(input, output, session) {
+      x <- 1
+      testServer(function(id) {
+        moduleServer(id, function(input, output, session) {
+          y <- x + 1
+        })
+      })
+    })
+  }
+
+  expect_error(testServer(module, {}), regexp = "Modules may not call testServer()")
+})
+
+test_that("testServer calls do not nest in test exprs", {
+  module <- function(id) {
+    x <- 1
+    moduleServer(id, function(input, output, session) {
+      inner <- function(id) {
+        moduleServer(id, function(input, output, session) {
+          y <- x + 1
+        })
+      }
+    })
+  }
+
+  expect_error(testServer(module, {
+    testServer(inner, {})
+  }), regexp = "Test expressions may not call testServer()")
+})

tests/testthat/test-test-server-scope.R

@@ -0,0 +1,82 @@
+context("testServer scope")
+
+library(shiny)
+library(testthat)
+
+test_that("Variables outside of the module are inaccessible", {
+  module <- local({
+    outside <- 123
+    function(id, x) {
+      y <- x+1
+      moduleServer(id, function(input, output, session) {
+        z <- y+1
+      })
+    }
+  }, envir = new.env(parent = globalenv()))
+
+  testServer(module, {
+    expect_equal(x, 0)
+    expect_equal(y, 1)
+    expect_equal(z, 2)
+    expect_equal(exists("outside"), FALSE)
+  }, x = 0)
+})
+
+test_that("Variables outside the testServer() have correct visibility", {
+  module <- local({
+    function(id, x) {
+      moduleServer(id, function(input, output, session) {
+        y <- 1
+      })
+    }
+  }, envir = new.env(parent = globalenv()))
+
+  x <- 99
+  z <- 123
+
+  testServer(module, {
+    expect_equal(x, 0)
+    expect_equal(y, 1)
+    expect_equal(z, 123)
+  }, x = 0)
+})
+
+test_that("testServer allows lexical environment access through session$env", {
+  module <- local({
+    a_var <- 123
+    function(id) {
+      moduleServer(id, function(input, output, session) {
+        b_var <- 321
+      })
+    }
+  })
+
+  expect_false(exists("a_var", inherits = FALSE))
+
+  testServer(module, {
+    expect_equal(b_var, 321)
+    expect_equal(get("a_var", session$env, inherits = TRUE), 123)
+    expect_false(exists("a_var", inherits = FALSE))
+  })
+})
+
+test_that("Shadowing can be mitigated with unquote", {
+  i <- 0
+  inc <- function() i <<- i+1
+
+  module <- local({
+    function(id) {
+      moduleServer(id, function(input, output, session) {
+        inc <- function() stop("I should never be called")
+      })
+    }
+  }, envir = globalenv())
+
+  testServer(module, {
+    expect_is(inc, "function")
+    expect_false(identical(inc, !!inc))
+    !!inc()
+  })
+
+  expect_equal(i, 1)
+})