testServer(): Properly capture module return values

* MockShinySession: add $click()

* Fix return value of MockShinySession$click()

* session$click() test w/ observeEvent

* session$click() test w/ observeEvent

* $click() examples

* $click, $setInputs: add \\dontrun

* $setInputs(): make dots dynamic

* document

* rm $click()

DESCRIPTION

@@ -97,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'

NAMESPACE

@@ -145,6 +145,7 @@ export(markRenderFunction)
 export(markdown)
 export(maskReactiveContext)
 export(memoryCache)
+export(migrateLegacyShinytest)
 export(modalButton)
 export(modalDialog)
 export(moduleServer)
@@ -230,6 +231,7 @@ export(setSerializer)
 export(shinyApp)
 export(shinyAppDir)
 export(shinyAppFile)
+export(shinyAppTemplate)
 export(shinyOptions)
 export(shinyServer)
 export(shinyUI)
@@ -253,6 +255,7 @@ export(strong)
 export(submitButton)
 export(suppressDependencies)
 export(tabPanel)
+export(tabPanelBody)
 export(tableOutput)
 export(tabsetPanel)
 export(tag)
@@ -272,6 +275,7 @@ export(throttle)
 export(titlePanel)
 export(uiOutput)
 export(updateActionButton)
+export(updateActionLink)
 export(updateCheckboxGroupInput)
 export(updateCheckboxInput)
 export(updateDateInput)

NEWS.md

@@ -7,6 +7,8 @@ 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 kinds 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))
@@ -27,6 +29,10 @@ shiny 1.4.0.9001
 
 * Added a `'function'` class to `reactive()` and `reactiveVal()` objects. ([#2793](https://github.com/rstudio/shiny/pull/2793))
 
+* Added a new option (`type = "hidden"`) to `tabsetPanel()`, making it easier to set the active tab via other input controls (e.g., `radioButtons()`) rather than tabs or pills. Use this option in conjunction with `updateTabsetPanel()` and the new `tabsetPanelBody()` function (see `help(tabsetPanel)` for an example and more details).  ([#2814](https://github.com/rstudio/shiny/pull/2814))
+
+* 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))

R/app.R

@@ -227,7 +227,6 @@ shinyAppDir_serverR <- function(appDir, options=list()) {
   onStart <- function() {
     oldwd <<- getwd()
     setwd(appDir)
-    monitorHandle <<- initAutoReloadMonitor(appDir)
     # TODO: we should support hot reloading on global.R and R/*.R changes.
     if (getOption("shiny.autoload.r", TRUE)) {
       loadSupport(appDir, renv=sharedEnv, globalrenv=globalenv())
@@ -235,11 +234,17 @@ shinyAppDir_serverR <- function(appDir, options=list()) {
       if (file.exists(file.path.ci(appDir, "global.R")))
         sourceUTF8(file.path.ci(appDir, "global.R"))
     }
+    monitorHandle <<- initAutoReloadMonitor(appDir)
   }
   onStop <- function() {
     setwd(oldwd)
-    monitorHandle()
-    monitorHandle <<- NULL
+    # It is possible that while calling appObj()$onStart() or loadingSupport, an error occured
+    # This will cause `onStop` to be called.
+    #   The `oldwd` will exist, but `monitorHandle` is not a function yet.
+    if (is.function(monitorHandle)) {
+      monitorHandle()
+      monitorHandle <<- NULL
+    }
   }
 
   structure(
@@ -297,14 +302,14 @@ initAutoReloadMonitor <- function(dir) {
     } else if (!identical(lastValue, times)) {
       # We've changed!
       lastValue <<- times
-      for (session in appsByToken$values()) {
-        session$reload()
-      }
+      autoReloadCallbacks$invoke()
     }
 
     invalidateLater(getOption("shiny.autoreload.interval", 500))
   })
 
+  onStop(obs$destroy)
+
   obs$destroy
 }
 
@@ -325,37 +330,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)
 }
@@ -429,13 +446,19 @@ shinyAppDir_appR <- function(fileName, appDir, options=list())
     if (getOption("shiny.autoload.r", TRUE)) {
       loadSupport(appDir, renv=sharedEnv, globalrenv=NULL)
     }
-    monitorHandle <<- initAutoReloadMonitor(appDir)
     if (!is.null(appObj()$onStart)) appObj()$onStart()
+    monitorHandle <<- initAutoReloadMonitor(appDir)
+    invisible()
   }
   onStop <- function() {
     setwd(oldwd)
-    monitorHandle()
-    monitorHandle <<- NULL
+    # It is possible that while calling appObj()$onStart() or loadingSupport, an error occured
+    # This will cause `onStop` to be called.
+    #   The `oldwd` will exist, but `monitorHandle` is not a function yet.
+    if (is.function(monitorHandle)) {
+      monitorHandle()
+      monitorHandle <<- NULL
+    }
   }
 
   structure(

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 which
+#'   files 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

@@ -464,8 +464,6 @@ helpText <- function(...) {
 
 #' Create a tab panel
 #'
-#' Create a tab panel that can be included within a [tabsetPanel()] or
-#' a [navbarPage()].
 #'
 #' @param title Display title for tab
 #' @param ... UI elements to include within the tab
@@ -489,12 +487,21 @@ helpText <- function(...) {
 #'   )
 #' )
 #' @export
+#' @describeIn tabPanel Create a tab panel that can be included within a [tabsetPanel()] or a [navbarPage()].
 tabPanel <- function(title, ..., value = title, icon = NULL) {
-  divTag <- div(class="tab-pane",
-                title=title,
-                `data-value`=value,
-                `data-icon-class` = iconClass(icon),
-                ...)
+  div(
+    class = "tab-pane",
+    title = title,
+    `data-value` = value,
+    `data-icon-class` = iconClass(icon),
+    ...
+  )
+}
+#' @export
+#' @describeIn tabPanel Create a tab panel that drops the title argument.
+#'   This function should be used within `tabsetPanel(type = "hidden")`. See [tabsetPanel()] for example usage.
+tabPanelBody <- function(..., value = NULL, icon = NULL) {
+  tabPanel(title = NULL, ..., value = value, icon = icon)
 }
 
 #' Create a tabset panel
@@ -510,8 +517,13 @@ tabPanel <- function(title, ..., value = title, icon = NULL) {
 #' @param selected The `value` (or, if none was supplied, the `title`)
 #'   of the tab that should be selected by default. If `NULL`, the first
 #'   tab will be selected.
-#' @param type Use "tabs" for the standard look; Use "pills" for a more plain
-#'   look where tabs are selected using a background fill color.
+#' @param type  \describe{
+#'   \item{`"tabs"`}{Standard tab look}
+#'   \item{`"pills"`}{Selected tabs use the background fill color}
+#'   \item{`"hidden"`}{Hides the selectable tabs. Use `type = "hidden"` in
+#'   conjunction with [tabPanelBody()] and [updateTabsetPanel()] to control the
+#'   active tab via other input controls. (See example below)}
+#' }
 #' @param position This argument is deprecated; it has been discontinued in
 #'   Bootstrap 3.
 #' @return A tabset that can be passed to [mainPanel()]
@@ -529,11 +541,40 @@ tabPanel <- function(title, ..., value = title, icon = NULL) {
 #'     tabPanel("Table", tableOutput("table"))
 #'   )
 #' )
+#'
+#' ui <- fluidPage(
+#'   sidebarLayout(
+#'     sidebarPanel(
+#'       radioButtons("controller", "Controller", 1:3, 1)
+#'     ),
+#'     mainPanel(
+#'       tabsetPanel(
+#'         id = "hidden_tabs",
+#'         # Hide the tab values.
+#'         # Can only switch tabs by using `updateTabsetPanel()`
+#'         type = "hidden",
+#'         tabPanelBody(value = "panel1", "Panel 1 content"),
+#'         tabPanelBody(value = "panel2", "Panel 2 content"),
+#'         tabPanelBody(value = "panel3", "Panel 3 content")
+#'       )
+#'     )
+#'   )
+#' )
+#'
+#' server <- function(input, output, session) {
+#'   observeEvent(input$controller, {
+#'     updateTabsetPanel(session, "hidden_tabs", selected = paste0("panel", input$controller))
+#'   })
+#' }
+#'
+#' if (interactive()) {
+#'   shinyApp(ui, server)
+#' }
 #' @export
 tabsetPanel <- function(...,
                         id = NULL,
                         selected = NULL,
-                        type = c("tabs", "pills"),
+                        type = c("tabs", "pills", "hidden"),
                         position = NULL) {
   if (!is.null(position)) {
     shinyDeprecated(msg = paste("tabsetPanel: argument 'position' is deprecated;",
@@ -842,42 +883,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 +992,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 +1175,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/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/image-interact.R

@@ -1,59 +1,76 @@
-#' Find rows of data that are selected by a brush
+#' Find rows of data selected on an interactive plot.
 #'
-#' This function returns rows from a data frame which are under a brush used
-#' with [plotOutput()].
+#' @description
+#' `brushedPoints()` returns rows from a data frame which are under a brush.
+#' `nearPoints()` returns rows from a data frame which are near a click, hover,
+#' or double-click. Alternatively, set `allRows = TRUE` to return all rows from
+#' the input data with an additional column `selected_` that indicates which
+#' rows of the would be selected.
 #'
-#' It is also possible for this function to return all rows from the input data
-#' frame, but with an additional column `selected_`, which indicates which
-#' rows of the input data frame are selected by the brush (`TRUE` for
-#' selected, `FALSE` for not-selected). This is enabled by setting
-#' `allRows=TRUE` option.
+#' @section ggplot2:
+#' For plots created with ggplot2, it is not necessary to specify the
+#' column names to `xvar`, `yvar`, `panelvar1`, and `panelvar2` as that
+#' information can be automatically derived from the plot specification.
 #'
-#' The `xvar`, `yvar`, `panelvar1`, and `panelvar2`
-#' arguments specify which columns in the data correspond to the x variable, y
-#' variable, and panel variables of the plot. For example, if your plot is
-#' `plot(x=cars$speed, y=cars$dist)`, and your brush is named
-#' `"cars_brush"`, then you would use `brushedPoints(cars,
-#' input$cars_brush, "speed", "dist")`.
-#'
-#' For plots created with ggplot2, it should not be necessary to specify the
-#' column names; that information will already be contained in the brush,
-#' provided that variables are in the original data, and not computed. For
-#' example, with `ggplot(cars, aes(x=speed, y=dist)) + geom_point()`, you
-#' could use `brushedPoints(cars, input$cars_brush)`. If, however, you use
-#' a computed column, like `ggplot(cars, aes(x=speed/2, y=dist)) +
-#' geom_point()`, then it will not be able to automatically extract column names
-#' and filter on them. If you want to use this function to filter data, it is
-#' recommended that you not use computed columns; instead, modify the data
+#' Note, however, that this will not work if you use a computed column, like
+#' `aes(speed/2, dist))`. Instead, we recommend that you modify the data
 #' first, and then make the plot with "raw" columns in the modified data.
 #'
-#' If a specified x or y column is a factor, then it will be coerced to an
-#' integer vector. If it is a character vector, then it will be coerced to a
-#' factor and then integer vector. This means that the brush will be considered
-#' to cover a given character/factor value when it covers the center value.
+#' @section Brushing:
+#' If x or y column is a factor, then it will be coerced to an integer vector.
+#' If it is a character vector, then it will be coerced to a factor and then
+#' integer vector. This means that the brush will be considered to cover a
+#' given character/factor value when it covers the center value.
 #'
 #' If the brush is operating in just the x or y directions (e.g., with
 #' `brushOpts(direction = "x")`, then this function will filter out points
 #' using just the x or y variable, whichever is appropriate.
 #'
-#' @param brush The data from a brush, such as `input$plot_brush`.
+#' @returns
+#' A data frame based on `df`, containing the observations selected by the
+#' brush or near the click event. For `nearPoints()`, the rows will be sorted
+#' by distance to the event.
+#'
+#' If `allRows = TRUE`, then all rows will returned, along with a new
+#' `selected_` column that indicates whether or not the point was selected.
+#' The output from `nearPoints()` will no longer be sorted, but you can
+#' set `addDist = TRUE` to get an additional column that gives the pixel
+#' distance to the pointer.
+#'
 #' @param df A data frame from which to select rows.
-#' @param xvar,yvar A string with the name of the variable on the x or y axis.
-#'   This must also be the name of a column in `df`. If absent, then this
-#'   function will try to infer the variable from the brush (only works for
-#'   ggplot2).
-#' @param panelvar1,panelvar2 Each of these is a string with the name of a panel
-#'   variable. For example, if with ggplot2, you facet on a variable called
-#'   `cyl`, then you can use `"cyl"` here. However, specifying the
-#'   panel variable should not be necessary with ggplot2; Shiny should be able
-#'   to auto-detect the panel variable.
+#' @param brush,coordinfo The data from a brush or click/dblclick/hover event
+#'   e.g. `input$plot_brush`, `input$plot_click`.
+#' @param xvar,yvar A string giving the name of the variable on the x or y axis.
+#'   These are only required for base graphics, and must be the name of
+#'   a column in `df`.
+#' @param panelvar1,panelvar2 A string giving the name of a panel variable.
+#'   For expert use only; in most cases these will be automatically
+#'   derived from the ggplot2 spec.
 #' @param allRows If `FALSE` (the default) return a data frame containing
 #'   the selected rows. If `TRUE`, the input data frame will have a new
-#'   column, `selected_`, which indicates whether the row was inside the
-#'   brush (`TRUE`) or outside the brush (`FALSE`).
-#'
+#'   column, `selected_`, which indicates whether the row was selected or not.
+#' @param threshold A maximum distance (in pixels) to the pointer location.
+#'   Rows in the data frame will be selected if the distance to the pointer is
+#'   less than `threshold`.
+#' @param maxpoints Maximum number of rows to return. If `NULL` (the default),
+#'   will return all rows within the threshold distance.
+#' @param addDist If TRUE, add a column named `dist_` that contains the
+#'   distance from the coordinate to the point, in pixels. When no pointer
+#'   event has yet occurred, the value of `dist_` will be `NA`.
 #' @seealso [plotOutput()] for example usage.
 #' @export
+#' @examples
+#' \dontrun{
+#' # Note that in practice, these examples would need to go in reactives
+#' # or observers.
+#'
+#' # This would select all points within 5 pixels of the click
+#' nearPoints(mtcars, input$plot_click)
+#'
+#' # Select just the nearest point within 10 pixels of the click
+#' nearPoints(mtcars, input$plot_click, threshold = 10, maxpoints = 1)
+#'
+#' }
 brushedPoints <- function(df, brush, xvar = NULL, yvar = NULL,
                           panelvar1 = NULL, panelvar2 = NULL,
                           allRows = FALSE) {
@@ -191,56 +208,8 @@ brushedPoints <- function(df, brush, xvar = NULL, yvar = NULL,
 #  $ direction: chr "y"
 
 
-#'Find rows of data that are near a click/hover/double-click
-#'
-#'This function returns rows from a data frame which are near a click, hover, or
-#'double-click, when used with [plotOutput()]. The rows will be sorted
-#'by their distance to the mouse event.
-#'
-#'It is also possible for this function to return all rows from the input data
-#'frame, but with an additional column `selected_`, which indicates which
-#'rows of the input data frame are selected by the brush (`TRUE` for
-#'selected, `FALSE` for not-selected). This is enabled by setting
-#'`allRows=TRUE` option. If this is used, the resulting data frame will not
-#'be sorted by distance to the mouse event.
-#'
-#'The `xvar`, `yvar`, `panelvar1`, and `panelvar2` arguments
-#'specify which columns in the data correspond to the x variable, y variable,
-#'and panel variables of the plot. For example, if your plot is
-#'`plot(x=cars$speed, y=cars$dist)`, and your click variable is named
-#'`"cars_click"`, then you would use `nearPoints(cars,
-#'input$cars_brush, "speed", "dist")`.
-#'
-#'@inheritParams brushedPoints
-#'@param coordinfo The data from a mouse event, such as `input$plot_click`.
-#'@param threshold A maxmimum distance to the click point; rows in the data
-#'  frame where the distance to the click is less than `threshold` will be
-#'  returned.
-#'@param maxpoints Maximum number of rows to return. If NULL (the default),
-#'  return all rows that are within the threshold distance.
-#'@param addDist If TRUE, add a column named `dist_` that contains the
-#'  distance from the coordinate to the point, in pixels. When no mouse event
-#'  has yet occured, the value of `dist_` will be `NA`.
-#'@param allRows If `FALSE` (the default) return a data frame containing
-#'  the selected rows. If `TRUE`, the input data frame will have a new
-#'  column, `selected_`, which indicates whether the row was inside the
-#'  selected by the mouse event (`TRUE`) or not (`FALSE`).
-#'
-#'@seealso [plotOutput()] for more examples.
-#'
-#' @examples
-#' \dontrun{
-#' # Note that in practice, these examples would need to go in reactives
-#' # or observers.
-#'
-#' # This would select all points within 5 pixels of the click
-#' nearPoints(mtcars, input$plot_click)
-#'
-#' # Select just the nearest point within 10 pixels of the click
-#' nearPoints(mtcars, input$plot_click, threshold = 10, maxpoints = 1)
-#'
-#' }
-#'@export
+#' @export
+#' @rdname brushedPoints
 nearPoints <- function(df, coordinfo, xvar = NULL, yvar = NULL,
                        panelvar1 = NULL, panelvar2 = NULL,
                        threshold = 5, maxpoints = NULL, addDist = FALSE,

R/middleware.R

@@ -311,16 +311,32 @@ HandlerManager <- R6Class("HandlerManager",
         },
         call = .httpServer(
           function (req) {
-            withCallingHandlers(withLogErrors(handlers$invoke(req)),
-              error = function(cond) {
-                sanitizeErrors <- getOption('shiny.sanitize.errors', FALSE)
-                if (inherits(cond, 'shiny.custom.error') || !sanitizeErrors) {
-                  stop(cond$message, call. = FALSE)
-                } else {
-                  stop(paste("An error has occurred. Check your logs or",
-                             "contact the app author for clarification."),
-                       call. = FALSE)
+            hybrid_chain(
+              hybrid_chain(
+                withCallingHandlers(withLogErrors(handlers$invoke(req)),
+                  error = function(cond) {
+                    sanitizeErrors <- getOption('shiny.sanitize.errors', FALSE)
+                    if (inherits(cond, 'shiny.custom.error') || !sanitizeErrors) {
+                      stop(cond$message, call. = FALSE)
+                    } else {
+                      stop(paste("An error has occurred. Check your logs or",
+                                 "contact the app author for clarification."),
+                           call. = FALSE)
+                    }
+                  }
+                ),
+                catch = function(err) {
+                  httpResponse(status = 500L,
+                    content_type = "text/html",
+                    content = as.character(htmltools::htmlTemplate(
+                      system.file("template", "error.html", package = "shiny"),
+                      message = conditionMessage(err)
+                    ))
+                  )
                 }
+              ),
+              function(resp) {
+                maybeInjectAutoreload(resp)
               }
             )
           },
@@ -390,6 +406,22 @@ HandlerManager <- R6Class("HandlerManager",
   )
 )
 
+maybeInjectAutoreload <- function(resp) {
+  if (getOption("shiny.autoreload", FALSE) &&
+      isTRUE(grepl("^text/html($|;)", resp$content_type)) &&
+      is.character(resp$content)) {
+
+    resp$content <- gsub(
+      "</head>",
+      "<script src=\"shared/shiny-autoreload.js\"></script>\n</head>",
+      resp$content,
+      fixed = TRUE
+    )
+  }
+
+  resp
+}
+
 # Safely get the Content-Length of a Rook response, or NULL if the length cannot
 # be determined for whatever reason (probably malformed response$content).
 # If deleteOwnedContent is TRUE, then the function should delete response

R/mock-session.R

@@ -70,8 +70,7 @@ extract <- function(promise) {
 }
 
 #' @noRd
-mapNames <- function(func, ...) {
-  vals <- list(...)
+mapNames <- function(func, vals) {
   names(vals) <- vapply(names(vals), func, character(1))
   vals
 }
@@ -190,14 +189,17 @@ 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)
       })
@@ -399,19 +401,29 @@ MockShinySession <- R6Class(
         output = structure(.createOutputWriter(self, ns = ns), class = "shinyoutput"),
         makeScope = function(namespace) self$makeScope(ns(namespace)),
         ns = function(namespace) ns(namespace),
-        setInputs = function(...) do.call(self$setInputs, mapNames(ns, ...))
+        setInputs = function(...) {
+          self$setInputs(!!!mapNames(ns, rlang::dots_list(..., .homonyms = "error")))
+        }
       )
     },
-    #' @description Set the environment associated with a testServer() call.
+    #' @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) {
-      self$env <- 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.
+    #' @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
-      private$flush()
       value
     },
     #' @description Get the value returned by the module call.
@@ -452,4 +464,3 @@ MockShinySession <- R6Class(
     }
   )
 )
-

R/modules.R

@@ -134,10 +134,12 @@ moduleServer <- function(id, module, session = getDefaultReactiveDomain()) {
   if (inherits(session, "MockShinySession")) {
     body(module) <- rlang::expr({
       session$setEnv(base::environment())
-      session$setReturned({ !!!body(module) })
+      !!body(module)
     })
+    session$setReturned(callModule(module, id, session = session))
+  } else {
+    callModule(module, id, session = session)
   }
-  callModule(module, id, session = session)
 }
 
 

R/server.R

@@ -279,6 +279,8 @@ decodeMessage <- function(data) {
   return(mainMessage)
 }
 
+autoReloadCallbacks <- Callbacks$new()
+
 createAppHandlers <- function(httpHandlers, serverFuncSource) {
   appvars <- new.env()
   appvars$server <- NULL
@@ -304,6 +306,22 @@ createAppHandlers <- function(httpHandlers, serverFuncSource) {
         return(TRUE)
       }
 
+      if (identical(ws$request$PATH_INFO, "/autoreload/")) {
+        if (!getOption("shiny.autoreload", FALSE)) {
+          ws$close()
+          return(TRUE)
+        }
+
+        callbackHandle <- autoReloadCallbacks$register(function() {
+          ws$send("autoreload")
+          ws$close()
+        })
+        ws$onClose(function() {
+          callbackHandle()
+        })
+        return(TRUE)
+      }
+
       if (!is.null(getOption("shiny.observer.error", NULL))) {
         warning(
           call. = FALSE,

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-server.R

@@ -1,15 +1,3 @@
-# Create a "data mask" suitable for passing to rlang::eval_tidy. Bindings in
-# `env` and bindings in the parent of `env` are merged into a single named list.
-# Bindings in `env` take precedence over bindings in the parent of `env`.
-#' @noRd
-makeMask <- function(env) {
-  stopifnot(length(rlang::env_parents(env)) > 1)
-  child <- as.list(env)
-  parent <- as.list(rlang::env_parent(env))
-  parent_only <- setdiff(names(parent), names(child))
-  append(child, parent[parent_only])
-}
-
 #' @noRd
 isModuleServer <- function(x) {
   is.function(x) && names(formals(x))[1] == "id"
@@ -23,15 +11,16 @@ isModuleServer <- function(x) {
 #' @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.
+#'   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.
+#' @param args Additional arguments to pass to the module function.
+#'   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
@@ -47,7 +36,7 @@ isModuleServer <- function(x) {
 #'   })
 #' }
 #'
-#' testServer(server, {
+#' testServer(server, args = list(multiplier = 2), {
 #'   session$setInputs(x = 1)
 #'   # You're also free to use third-party
 #'   # testing packages like testthat:
@@ -59,12 +48,13 @@ isModuleServer <- function(x) {
 #'   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, expr, ...) {
+testServer <- function(app = NULL, expr, args = list()) {
 
-  args <- rlang::list2(...)
+  require(shiny)
 
+  quosure <- rlang::enquo(expr)
   session <- getDefaultReactiveDomain()
 
   if (inherits(session, "MockShinySession"))
@@ -79,41 +69,77 @@ testServer <- function(app, expr, ...) {
   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 {
-    appobj <- as.shiny.appobj(app)
-    server <- appobj$serverFuncSource()
-    if (! "session" %in% names(formals(server)))
-      stop("Tested application server functions must declare input, output, and session arguments.")
-    body(server) <- rlang::expr({
-      session$setEnv(base::environment())
-      !!!body(server)
-    })
-    app <- function() {
-      session$setReturned(server(input = session$input, output = session$output, session = session))
+    if (is.null(app)) {
+      app <- findEnclosingApp(".")
     }
-    if (length(args))
-      message("Discarding unused arguments to server function")
+
+    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())
+        })
+      )
+    )
   }
 
-  isolate(
-    withReactiveDomain(
-      session,
-      withr::with_options(list(`shiny.allowoutputreads` = TRUE), {
-        rlang::exec(app, !!!args)
-      })
-    )
-  )
-
-  stopifnot(all(c("input", "output", "session") %in% ls(session$env)))
-
-  quosure <- rlang::enquo(expr)
-
-  isolate(
-    withReactiveDomain(
-      session,
-      withr::with_options(list(`shiny.allowoutputreads` = TRUE), {
-        rlang::eval_tidy(quosure, makeMask(session$env), rlang::caller_env())
-      })
-    )
-  )
+  invisible()
 }

R/test.R

@@ -2,35 +2,47 @@
 #'
 #' @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` or `NA`
-#'   if no value was obtained, such as with `shinytest`.
-#' @param error Error, if any, (and wrapped in a list) that was signaled during
-#'   evaluation of `file`.
+#' @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
-#'   `error` are "list columns", or columns that may contain list elements.
+#'   is a "list column", or a column that contains list elements.
 #' @noRd
-result_row <- function(file, pass, result, error) {
+result_row <- function(file, pass, result) {
   stopifnot(is.list(result))
-  stopifnot(is.list(error))
   df <- data.frame(
     file = file,
     pass = pass,
     result = I(result),
-    error = I(error),
     stringsAsFactors = FALSE
   )
-  class(df) <- c("shinytestrun", class(df))
+  class(df) <- c("shiny_runtests", class(df))
   df
 }
 
-#' 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.
+#' 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
-isShinyTest <- function(text){
-  lines <- grepl("app\\s*<-\\s*ShinyDriver\\$new\\(", text, perl=TRUE)
-  any(lines)
+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
@@ -43,99 +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 `"shinytestrun"`.
+#' @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, or `NA` if `pass == FALSE`. |
-#' | `error` | any or `NA` | The error signaled by the runner, or `NA` if `pass == TRUE`. |
+#' | `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(result_row(character(0), logical(0), list(), list()))
+    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))
-
   # See the @details section of the runTests() docs above for why this branch exists.
-  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")
-    }
-
-    return(do.call(rbind, lapply(shinytest::testApp(appDir)[["results"]], function(r) {
-      error <- if (r[["pass"]]) NA else simpleError("Unknown shinytest error")
-      result_row(r[["name"]], r[["pass"]], list(NA), list(error))
-    })))
+  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.
-  return(do.call(rbind, lapply(runners, function(r) {
-    result <- NA
-    error <- NA
+  ret <- do.call(rbind, lapply(runners, function(r) {
     pass <- FALSE
-    tryCatch({
-      env <- new.env(parent = renv)
-      result <- sourceUTF8(r, envir = env)
-      pass <- TRUE
-    }, error = function(e) {
-      error <<- e
-    })
-    result_row(r, pass, list(result), list(error))
-  })))
+    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))
+  }))
+
+  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))
+})

inst/template/error.html

@@ -0,0 +1,13 @@
+<html>
+
+<head>
+  <title>An error has occurred</title>
+</head>
+
+<body>
+
+<h1>An error has occurred!</h1>
+<p>{{message}}</p>
+
+</body>
+</html>

inst/www/shared/shiny-autoreload.js

@@ -0,0 +1,17 @@
+(function() {
+  var protocol = 'ws:';
+  if (window.location.protocol === 'https:')
+    protocol = 'wss:';
+
+  var defaultPath = window.location.pathname;
+  if (!/\/$/.test(defaultPath))
+    defaultPath += '/';
+  defaultPath += 'autoreload/';
+
+  var ws = new WebSocket(protocol + '//' + window.location.host + defaultPath);
+  ws.onmessage = function(event) {
+    if (event.data === "autoreload") {
+      window.location.reload()
+    }
+  }
+})();

inst/www/shared/shiny.css

@@ -407,3 +407,10 @@ pre.shiny-text-output {
   color: #aaa;
   cursor: not-allowed;
 }
+
+
+/* Hidden tabPanels */
+.nav-hidden {
+  /* override anything bootstrap sets for `.nav` */
+  display: none !important;
+}

man/MockShinySession.Rd

@@ -13,8 +13,9 @@ 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)
+}
 }
 \section{Public fields}{
 \if{html}{\out{<div class="r6-fields">}}
@@ -255,8 +256,8 @@ Base64-encode the given file. Needed for image rendering.
 \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>}}
 }
@@ -264,14 +265,17 @@ 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>}}
 
@@ -675,7 +679,10 @@ Create and return a namespace-specific session proxy.
 \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.
+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>}}
 }
@@ -692,7 +699,10 @@ Set the environment associated with a testServer() call.
 \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.
+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>}}
 }

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/brushedPoints.Rd

@@ -2,7 +2,8 @@
 % Please edit documentation in R/image-interact.R
 \name{brushedPoints}
 \alias{brushedPoints}
-\title{Find rows of data that are selected by a brush}
+\alias{nearPoints}
+\title{Find rows of data selected on an interactive plot.}
 \usage{
 brushedPoints(
   df,
@@ -13,64 +14,103 @@ brushedPoints(
   panelvar2 = NULL,
   allRows = FALSE
 )
+
+nearPoints(
+  df,
+  coordinfo,
+  xvar = NULL,
+  yvar = NULL,
+  panelvar1 = NULL,
+  panelvar2 = NULL,
+  threshold = 5,
+  maxpoints = NULL,
+  addDist = FALSE,
+  allRows = FALSE
+)
 }
 \arguments{
 \item{df}{A data frame from which to select rows.}
 
-\item{brush}{The data from a brush, such as \code{input$plot_brush}.}
+\item{brush, coordinfo}{The data from a brush or click/dblclick/hover event
+e.g. \code{input$plot_brush}, \code{input$plot_click}.}
 
-\item{xvar, yvar}{A string with the name of the variable on the x or y axis.
-This must also be the name of a column in \code{df}. If absent, then this
-function will try to infer the variable from the brush (only works for
-ggplot2).}
+\item{xvar, yvar}{A string giving the name of the variable on the x or y axis.
+These are only required for base graphics, and must be the name of
+a column in \code{df}.}
 
-\item{panelvar1, panelvar2}{Each of these is a string with the name of a panel
-variable. For example, if with ggplot2, you facet on a variable called
-\code{cyl}, then you can use \code{"cyl"} here. However, specifying the
-panel variable should not be necessary with ggplot2; Shiny should be able
-to auto-detect the panel variable.}
+\item{panelvar1, panelvar2}{A string giving the name of a panel variable.
+For expert use only; in most cases these will be automatically
+derived from the ggplot2 spec.}
 
 \item{allRows}{If \code{FALSE} (the default) return a data frame containing
 the selected rows. If \code{TRUE}, the input data frame will have a new
-column, \code{selected_}, which indicates whether the row was inside the
-brush (\code{TRUE}) or outside the brush (\code{FALSE}).}
+column, \code{selected_}, which indicates whether the row was selected or not.}
+
+\item{threshold}{A maximum distance (in pixels) to the pointer location.
+Rows in the data frame will be selected if the distance to the pointer is
+less than \code{threshold}.}
+
+\item{maxpoints}{Maximum number of rows to return. If \code{NULL} (the default),
+will return all rows within the threshold distance.}
+
+\item{addDist}{If TRUE, add a column named \code{dist_} that contains the
+distance from the coordinate to the point, in pixels. When no pointer
+event has yet occurred, the value of \code{dist_} will be \code{NA}.}
+}
+\value{
+A data frame based on \code{df}, containing the observations selected by the
+brush or near the click event. For \code{nearPoints()}, the rows will be sorted
+by distance to the event.
+
+If \code{allRows = TRUE}, then all rows will returned, along with a new
+\code{selected_} column that indicates whether or not the point was selected.
+The output from \code{nearPoints()} will no longer be sorted, but you can
+set \code{addDist = TRUE} to get an additional column that gives the pixel
+distance to the pointer.
 }
 \description{
-This function returns rows from a data frame which are under a brush used
-with \code{\link[=plotOutput]{plotOutput()}}.
+\code{brushedPoints()} returns rows from a data frame which are under a brush.
+\code{nearPoints()} returns rows from a data frame which are near a click, hover,
+or double-click. Alternatively, set \code{allRows = TRUE} to return all rows from
+the input data with an additional column \code{selected_} that indicates which
+rows of the would be selected.
 }
-\details{
-It is also possible for this function to return all rows from the input data
-frame, but with an additional column \code{selected_}, which indicates which
-rows of the input data frame are selected by the brush (\code{TRUE} for
-selected, \code{FALSE} for not-selected). This is enabled by setting
-\code{allRows=TRUE} option.
+\section{ggplot2}{
 
-The \code{xvar}, \code{yvar}, \code{panelvar1}, and \code{panelvar2}
-arguments specify which columns in the data correspond to the x variable, y
-variable, and panel variables of the plot. For example, if your plot is
-\code{plot(x=cars$speed, y=cars$dist)}, and your brush is named
-\code{"cars_brush"}, then you would use \code{brushedPoints(cars, input$cars_brush, "speed", "dist")}.
+For plots created with ggplot2, it is not necessary to specify the
+column names to \code{xvar}, \code{yvar}, \code{panelvar1}, and \code{panelvar2} as that
+information can be automatically derived from the plot specification.
 
-For plots created with ggplot2, it should not be necessary to specify the
-column names; that information will already be contained in the brush,
-provided that variables are in the original data, and not computed. For
-example, with \code{ggplot(cars, aes(x=speed, y=dist)) + geom_point()}, you
-could use \code{brushedPoints(cars, input$cars_brush)}. If, however, you use
-a computed column, like \code{ggplot(cars, aes(x=speed/2, y=dist)) + geom_point()}, then it will not be able to automatically extract column names
-and filter on them. If you want to use this function to filter data, it is
-recommended that you not use computed columns; instead, modify the data
+Note, however, that this will not work if you use a computed column, like
+\verb{aes(speed/2, dist))}. Instead, we recommend that you modify the data
 first, and then make the plot with "raw" columns in the modified data.
+}
 
-If a specified x or y column is a factor, then it will be coerced to an
-integer vector. If it is a character vector, then it will be coerced to a
-factor and then integer vector. This means that the brush will be considered
-to cover a given character/factor value when it covers the center value.
+\section{Brushing}{
+
+If x or y column is a factor, then it will be coerced to an integer vector.
+If it is a character vector, then it will be coerced to a factor and then
+integer vector. This means that the brush will be considered to cover a
+given character/factor value when it covers the center value.
 
 If the brush is operating in just the x or y directions (e.g., with
 \code{brushOpts(direction = "x")}, then this function will filter out points
 using just the x or y variable, whichever is appropriate.
 }
+
+\examples{
+\dontrun{
+# Note that in practice, these examples would need to go in reactives
+# or observers.
+
+# This would select all points within 5 pixels of the click
+nearPoints(mtcars, input$plot_click)
+
+# Select just the nearest point within 10 pixels of the click
+nearPoints(mtcars, input$plot_click, threshold = 10, maxpoints = 1)
+
+}
+}
 \seealso{
 \code{\link[=plotOutput]{plotOutput()}} for example usage.
 }

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/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

@@ -4,29 +4,34 @@
 \alias{markdown}
 \title{Insert inline Markdown}
 \usage{
-markdown(mds, extensions = TRUE, ...)
+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, resulting HTML is concatenated.}
+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{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{
-an \code{html}-classed character vector of rendered HTML
+a character vector marked as HTML.
 }
 \description{
-This function accepts a character vector of
-\href{https://en.wikipedia.org/wiki/Markdown}{Markdown}-syntax text and renders
-it to HTML that may be included in a UI.
+This function accepts
+\href{https://en.wikipedia.org/wiki/Markdown}{Markdown}-syntax text and returns
+HTML that may be included in Shiny UIs.
 }
 \details{
-Prior to interpretation as Markdown, leading whitespace is trimmed from text
-with \code{\link[glue:trim]{glue::trim()}}. This makes it possible to insert Markdown and for it to
-be processed correctly even when the call to \code{markdown()} is indented.
+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}.

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/nearPoints.Rd

@@ -1,97 +0,0 @@
-% Generated by roxygen2: do not edit by hand
-% Please edit documentation in R/image-interact.R
-\name{nearPoints}
-\alias{nearPoints}
-\title{Find rows of data that are near a click/hover/double-click}
-\usage{
-nearPoints(
-  df,
-  coordinfo,
-  xvar = NULL,
-  yvar = NULL,
-  panelvar1 = NULL,
-  panelvar2 = NULL,
-  threshold = 5,
-  maxpoints = NULL,
-  addDist = FALSE,
-  allRows = FALSE
-)
-}
-\arguments{
-\item{df}{A data frame from which to select rows.}
-
-\item{coordinfo}{The data from a mouse event, such as \code{input$plot_click}.}
-
-\item{xvar}{A string with the name of the variable on the x or y axis.
-This must also be the name of a column in \code{df}. If absent, then this
-function will try to infer the variable from the brush (only works for
-ggplot2).}
-
-\item{yvar}{A string with the name of the variable on the x or y axis.
-This must also be the name of a column in \code{df}. If absent, then this
-function will try to infer the variable from the brush (only works for
-ggplot2).}
-
-\item{panelvar1}{Each of these is a string with the name of a panel
-variable. For example, if with ggplot2, you facet on a variable called
-\code{cyl}, then you can use \code{"cyl"} here. However, specifying the
-panel variable should not be necessary with ggplot2; Shiny should be able
-to auto-detect the panel variable.}
-
-\item{panelvar2}{Each of these is a string with the name of a panel
-variable. For example, if with ggplot2, you facet on a variable called
-\code{cyl}, then you can use \code{"cyl"} here. However, specifying the
-panel variable should not be necessary with ggplot2; Shiny should be able
-to auto-detect the panel variable.}
-
-\item{threshold}{A maxmimum distance to the click point; rows in the data
-frame where the distance to the click is less than \code{threshold} will be
-returned.}
-
-\item{maxpoints}{Maximum number of rows to return. If NULL (the default),
-return all rows that are within the threshold distance.}
-
-\item{addDist}{If TRUE, add a column named \code{dist_} that contains the
-distance from the coordinate to the point, in pixels. When no mouse event
-has yet occured, the value of \code{dist_} will be \code{NA}.}
-
-\item{allRows}{If \code{FALSE} (the default) return a data frame containing
-the selected rows. If \code{TRUE}, the input data frame will have a new
-column, \code{selected_}, which indicates whether the row was inside the
-selected by the mouse event (\code{TRUE}) or not (\code{FALSE}).}
-}
-\description{
-This function returns rows from a data frame which are near a click, hover, or
-double-click, when used with \code{\link[=plotOutput]{plotOutput()}}. The rows will be sorted
-by their distance to the mouse event.
-}
-\details{
-It is also possible for this function to return all rows from the input data
-frame, but with an additional column \code{selected_}, which indicates which
-rows of the input data frame are selected by the brush (\code{TRUE} for
-selected, \code{FALSE} for not-selected). This is enabled by setting
-\code{allRows=TRUE} option. If this is used, the resulting data frame will not
-be sorted by distance to the mouse event.
-
-The \code{xvar}, \code{yvar}, \code{panelvar1}, and \code{panelvar2} arguments
-specify which columns in the data correspond to the x variable, y variable,
-and panel variables of the plot. For example, if your plot is
-\code{plot(x=cars$speed, y=cars$dist)}, and your click variable is named
-\code{"cars_click"}, then you would use \code{nearPoints(cars, input$cars_brush, "speed", "dist")}.
-}
-\examples{
-\dontrun{
-# Note that in practice, these examples would need to go in reactives
-# or observers.
-
-# This would select all points within 5 pixels of the click
-nearPoints(mtcars, input$plot_click)
-
-# Select just the nearest point within 10 pixels of the click
-nearPoints(mtcars, input$plot_click, threshold = 10, maxpoints = 1)
-
-}
-}
-\seealso{
-\code{\link[=plotOutput]{plotOutput()}} for more examples.
-}

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/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,15 +12,18 @@ 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{"shinytestrun"}.
+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, or \code{NA} if \code{pass == FALSE}. \cr
-   \code{error} \tab any or \code{NA} \tab The error signaled by the runner, or \code{NA} if \code{pass == TRUE}. \cr
+   \code{result} \tab any or \code{NA} \tab The return value of the runner \cr
 }
 }
 \description{
@@ -30,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 which
+files 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/tabPanel.Rd

@@ -2,9 +2,12 @@
 % Please edit documentation in R/bootstrap.R
 \name{tabPanel}
 \alias{tabPanel}
+\alias{tabPanelBody}
 \title{Create a tab panel}
 \usage{
 tabPanel(title, ..., value = title, icon = NULL)
+
+tabPanelBody(..., value = NULL, icon = NULL)
 }
 \arguments{
 \item{title}{Display title for tab}
@@ -22,9 +25,16 @@ valid when using a \code{tabPanel} within a \code{\link[=navbarPage]{navbarPage(
 A tab that can be passed to \code{\link[=tabsetPanel]{tabsetPanel()}}
 }
 \description{
-Create a tab panel that can be included within a \code{\link[=tabsetPanel]{tabsetPanel()}} or
-a \code{\link[=navbarPage]{navbarPage()}}.
+Create a tab panel
 }
+\section{Functions}{
+\itemize{
+\item \code{tabPanel}: Create a tab panel that can be included within a \code{\link[=tabsetPanel]{tabsetPanel()}} or a \code{\link[=navbarPage]{navbarPage()}}.
+
+\item \code{tabPanelBody}: Create a tab panel that drops the title argument.
+This function should be used within \code{tabsetPanel(type = "hidden")}. See \code{\link[=tabsetPanel]{tabsetPanel()}} for example usage.
+}}
+
 \examples{
 # Show a tabset that includes a plot, summary, and
 # table view of the generated distribution

man/tabsetPanel.Rd

@@ -8,7 +8,7 @@ tabsetPanel(
   ...,
   id = NULL,
   selected = NULL,
-  type = c("tabs", "pills"),
+  type = c("tabs", "pills", "hidden"),
   position = NULL
 )
 }
@@ -24,8 +24,13 @@ will correspond to the \code{value} argument that is passed to
 of the tab that should be selected by default. If \code{NULL}, the first
 tab will be selected.}
 
-\item{type}{Use "tabs" for the standard look; Use "pills" for a more plain
-look where tabs are selected using a background fill color.}
+\item{type}{\describe{
+\item{\code{"tabs"}}{Standard tab look}
+\item{\code{"pills"}}{Selected tabs use the background fill color}
+\item{\code{"hidden"}}{Hides the selectable tabs. Use \code{type = "hidden"} in
+conjunction with \code{\link[=tabPanelBody]{tabPanelBody()}} and \code{\link[=updateTabsetPanel]{updateTabsetPanel()}} to control the
+active tab via other input controls. (See example below)}
+}}
 
 \item{position}{This argument is deprecated; it has been discontinued in
 Bootstrap 3.}
@@ -47,6 +52,35 @@ mainPanel(
     tabPanel("Table", tableOutput("table"))
   )
 )
+
+ui <- fluidPage(
+  sidebarLayout(
+    sidebarPanel(
+      radioButtons("controller", "Controller", 1:3, 1)
+    ),
+    mainPanel(
+      tabsetPanel(
+        id = "hidden_tabs",
+        # Hide the tab values.
+        # Can only switch tabs by using `updateTabsetPanel()`
+        type = "hidden",
+        tabPanelBody(value = "panel1", "Panel 1 content"),
+        tabPanelBody(value = "panel2", "Panel 2 content"),
+        tabPanelBody(value = "panel3", "Panel 3 content")
+      )
+    )
+  )
+)
+
+server <- function(input, output, session) {
+  observeEvent(input$controller, {
+    updateTabsetPanel(session, "hidden_tabs", selected = paste0("panel", input$controller))
+  })
+}
+
+if (interactive()) {
+  shinyApp(ui, server)
+}
 }
 \seealso{
 \code{\link[=tabPanel]{tabPanel()}}, \code{\link[=updateTabsetPanel]{updateTabsetPanel()}},

man/testServer.Rd

@@ -4,23 +4,24 @@
 \alias{testServer}
 \title{Reactive testing for Shiny server functions and modules}
 \usage{
-testServer(app, expr, ...)
+testServer(app = NULL, expr, args = list())
 }
 \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.}
+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.}
+\item{args}{Additional arguments to pass to the module function.
+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}.
@@ -42,7 +43,7 @@ server <- function(id, multiplier = 2, prefix = "I am ") {
   })
 }
 
-testServer(server, {
+testServer(server, args = list(multiplier = 2), {
   session$setInputs(x = 1)
   # You're also free to use third-party
   # testing packages like testthat:
@@ -54,5 +55,5 @@ testServer(server, {
   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"))
   })
 }
 

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,12 +1,19 @@
 
-b <- 2
 
-if (!identical(helper1, 123)){
-  stop("Missing helper1")
-}
-if (!identical(helper2, "abc")){
-  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/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,38 @@
+
+context("linkedScatterServer")
+
+testServer(
+  linkedScatterServer,
+  args = list(
+    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/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-test-server-app.R

@@ -29,3 +29,80 @@ test_that("testServer works when referencing external globals", {
     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"), {}, args = list(an_arg = 123)))
+})

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

@@ -17,9 +17,9 @@ test_that("Nested modules", {
     })
   }
 
-  testServer(parent, {
+  testServer(parent, args = list(id = "parent-id"), {
     expect_equal(output$txt, "foo")
-  }, id = "parent-id")
+  })
 
 })
 
@@ -30,9 +30,9 @@ test_that("Lack of ID", {
     })
   }
 
-  testServer(module, {
+  testServer(module, args = list(id = "foo"), {
     expect_equal(output$txt, "foo-x")
-  }, id = "foo")
+  })
 })
 
 test_that("testServer works with nested module servers", {
@@ -50,10 +50,10 @@ test_that("testServer works with nested module servers", {
     })
   }
 
-  testServer(outerModule, {
+  testServer(outerModule, args = list(id = "foo"), {
     session$setInputs(x = 1)
     expect_equal(output$someVar, "a value: 2")
-  }, id = "foo")
+  })
 })
 
 test_that("testServer calls do not nest in module functions", {

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

@@ -14,12 +14,12 @@ test_that("Variables outside of the module are inaccessible", {
     }
   }, envir = new.env(parent = globalenv()))
 
-  testServer(module, {
+  testServer(module, args = list(x = 0), {
     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", {
@@ -34,11 +34,11 @@ test_that("Variables outside the testServer() have correct visibility", {
   x <- 99
   z <- 123
 
-  testServer(module, {
+  testServer(module, args = list(x = 0), {
     expect_equal(x, 0)
     expect_equal(y, 1)
     expect_equal(z, 123)
-  }, x = 0)
+  })
 })
 
 test_that("testServer allows lexical environment access through session$env", {

tests/testthat/test-test-server.R

@@ -11,24 +11,7 @@ test_that("testServer passes dots", {
       expect_equal(someArg, 123)
     })
   }
-  testServer(module, {}, someArg = 123)
-})
-
-test_that("testServer passes dynamic dots", {
-  module <- function(id, someArg) {
-    expect_false(missing(someArg))
-    moduleServer(id, function(input, output, session) {
-      expect_equal(someArg, 123)
-    })
-  }
-
-  # Test with !!! to splice in a whole named list constructed with base::list()
-  moreArgs <- list(someArg = 123)
-  testServer(module, {}, !!!moreArgs)
-
-  # Test with !!/:= to splice in an argument name
-  argName <- "someArg"
-  testServer(module, {}, !!argName := 123)
+  testServer(module, {}, args = list(someArg = 123))
 })
 
 test_that("testServer handles observers", {
@@ -61,10 +44,7 @@ test_that("testServer handles observers", {
 })
 
 test_that("inputs aren't directly assignable", {
-  module <- function(id) {
-    moduleServer(id, function(input, output, session) {
-    })
-  }
+  module <- function(id) moduleServer(id, function(input, output, session) {})
 
   testServer(module, {
     session$setInputs(x = 0)
@@ -73,6 +53,24 @@ test_that("inputs aren't directly assignable", {
   })
 })
 
+test_that("setInputs dots are dynamic", {
+  module <- function(id) moduleServer(id, function(input, output, session) {})
+
+  inputs_initial <- list(x=1, y=2)
+  input_y <- "y"
+
+  testServer(module, {
+    session$setInputs(!!!inputs_initial)
+    expect_equal(input$x, 1)
+    expect_equal(input$y, 2)
+    session$setInputs(!!input_y := 3)
+    expect_equal(input$y, 3)
+
+    # Duplicate names are an error
+    expect_error(session$setInputs(x = 1, x = 2))
+  })
+})
+
 test_that("testServer handles more complex expressions", {
   module <- function(id) {
     moduleServer(id, function(input, output, session){
@@ -165,6 +163,7 @@ test_that("testServer handles reactivePoll", {
   }
 
   testServer(module, {
+    session$flushReact()
     expect_equal(rv$x, 1)
 
     for (i in 1:4){
@@ -189,6 +188,7 @@ test_that("testServer handles reactiveTimer", {
   }
 
   testServer(module, {
+    session$flushReact()
     expect_equal(rv$x, 1)
 
     session$elapse(200)
@@ -397,7 +397,7 @@ test_that("testServer handles modules with additional arguments", {
   testServer(module, {
     expect_equal(output$txt1, "val1")
     expect_equal(output$txt2, "val2")
-  }, arg1="val1", arg2="val2")
+  }, list(arg1="val1", arg2="val2"))
 })
 
 test_that("testServer captures htmlwidgets", {
@@ -548,25 +548,13 @@ test_that("accessing a non-existent output gives an informative message", {
 
   testServer(module, {
     expect_error(output$dontexist, "hasn't been defined yet: output\\$server1-dontexist")
-  }, id = "server1")
+  }, list(id = "server1"))
 
   testServer(module, {
     expect_error(output$dontexist, "hasn't been defined yet: output\\$.*-dontexist")
   })
 })
 
-test_that("testServer returns a meaningful result", {
-  result <- testServer(function(id) {
-    moduleServer(id, function(input, output, session) {
-      reactive({ input$x * 2 })
-    })
-  }, {
-    session$setInputs(x = 2)
-    session$getReturned()()
-  })
-  expect_equal(result, 4)
-})
-
 test_that("assigning an output in a module function with a non-function errors", {
   module <- function(id) {
     moduleServer(id, function(input, output, session) {
@@ -593,6 +581,7 @@ test_that("testServer handles invalidateLater", {
   }
 
   testServer(module, {
+    session$flushReact()
     # Should have run once
     expect_equal(rv$x, 1)
 
@@ -662,3 +651,42 @@ test_that("session flush handlers work", {
 
   })
 })
+
+test_that("module return value captured", {
+  module_implicit_return <- function(id) {
+    moduleServer(id, function(input, output, session) {
+      123
+    })
+  }
+
+  testServer(module_implicit_return, {
+    expect_equal(session$returned, 123)
+  })
+
+  module_early_returns <- function(id, n) {
+    retval <<- NULL
+    moduleServer(id, function(input, output, session) {
+      if (n == 0) return(n)
+      if (n %% 2 == 0) {
+        retval <<- "even"
+      } else {
+        return(FALSE)
+      }
+      retval
+    })
+  }
+
+  testServer(module_early_returns, {
+    expect_equal(session$returned, 0)
+  }, args = list(n = 0))
+
+  testServer(module_early_returns, {
+    expect_equal(session$returned, FALSE)
+  }, args = list(n = 1))
+
+  testServer(module_early_returns, {
+    expect_equal(session$returned, "even")
+  }, args = list(n = 2))
+})
+
+#test_that("server return value captured", {})

tests/testthat/test-test.R

@@ -26,14 +26,9 @@ test_that("runTests works", {
     NULL
   }
 
-  # Temporarily opt-in to R/ file autoloading
-  orig <- getOption("shiny.autoload.r", NULL)
-  options(shiny.autoload.r=TRUE)
-  on.exit({options(shiny.autoload.r=orig)}, add=TRUE)
-
   runTestsSpy <- rewire(runTests, sourceUTF8 = sourceStub, loadSupport=loadSupportStub)
 
-  res <- runTestsSpy(test_path("../test-helpers/app1-standard"))
+  res <- runTestsSpy(test_path("../test-helpers/app1-standard"), assert = FALSE)
 
   # Should have seen two calls to each test runner
   expect_length(calls, 2)
@@ -54,82 +49,43 @@ test_that("runTests works", {
   # Check the results
   expect_equal(all(res$pass), FALSE)
   expect_length(res$file, 2)
-  expect_equal(res$file[1], "runner1.R")
-  expect_equal(res[2,]$error[[1]]$message, "I was told to throw an error")
-  expect_s3_class(res, "shinytestrun")
+  expect_equal(basename(res$file[1]), "runner1.R")
+  expect_equal(res[2,]$result[[1]]$message, "I was told to throw an error")
+  expect_s3_class(res, "shiny_runtests")
 
-  # Check that supporting files were loaded
-  expect_length(loadCalls, 1)
-  # global should be a child of emptyenv
-  ge <- loadCalls[[1]]$globalrenv
-  expect_identical(parent.env(ge), globalenv())
-  # renv should be a child of our globalrenv
-  expect_identical(parent.env(loadCalls[[1]]$renv), ge)
+  # Check that supporting files were NOT loaded using Spy Functions
+  expect_length(loadCalls, 0)
 
   # Clear out err'ing files and rerun
   filesToError <- character(0)
 
+  calls <- list()
   res <- runTestsSpy(test_path("../test-helpers/app1-standard"))
   expect_equal(all(res$pass), TRUE)
-  expect_equal(res$file, c("runner1.R", "runner2.R"))
+  expect_equal(basename(res$file), c("runner1.R", "runner2.R"))
+  expect_length(calls, 2)
+  expect_match(calls[[1]][[1]], "runner1\\.R", perl=TRUE)
+  expect_match(calls[[2]][[1]], "runner2\\.R", perl=TRUE)
 
-  # If autoload is false, it should still load global.R. Because this load happens in the top-level of the function,
-  # our spy will catch it.
-  calls <- list()
-
-  # Temporarily opt-out of R/ file autoloading
-  orig <- getOption("shiny.autoload.r", NULL)
-  options(shiny.autoload.r=FALSE)
-  on.exit({options(shiny.autoload.r=orig)}, add=TRUE)
-
-  res <- runTestsSpy(test_path("../test-helpers/app1-standard"))
-  expect_length(calls, 3)
-  expect_match(calls[[1]][[1]], "/global\\.R", perl=TRUE)
 })
 
 test_that("calls out to shinytest when appropriate", {
-  isShinyTest <- TRUE
-  isShinyTestStub <- function(...){
-    isShinyTest
+  is_legacy_shinytest_val <- TRUE
+  is_legacy_shinytest_dir_stub <- function(...){
+    is_legacy_shinytest_val
   }
 
-  shinytestInstalled <- FALSE
-  requireNamespaceStub <- function(...){
-    shinytestInstalled
-  }
-
-  # All are shinytests but shinytest isn't installed
-  runTestsSpy <- rewire(runTests,
-                    isShinyTest = isShinyTestStub,
-                    requireNamespace = requireNamespaceStub)
-  expect_error(runTestsSpy(test_path("../test-helpers/app1-standard")), "but shinytest is not installed")
-
-  # All are shinytests and shinytest is installed
-  shinytestInstalled <- TRUE
-  sares <- list()
-  sares[[1]] <- list(name = "test1", pass=TRUE)
-  sares[[2]] <- list(name = "test2", pass=FALSE)
-  overloadShinyTest <- rewire_namespace_handler("shinytest", "testApp",
-                                                function(...){ list(results=sares) })
-  runTestsSpy <- rewire(runTests, isShinyTest = isShinyTestStub, requireNamespace = requireNamespaceStub, `::` = overloadShinyTest)
-
-  # Run shinytest with a failure
-  res2 <- runTestsSpy(test_path("../test-helpers/app1-standard"))
-  expect_false(all(res2$pass))
-  expect_equivalent(res2$error, list(NA, simpleError("Unknown shinytest error")))
-  expect_s3_class(res2, "shinytestrun")
-
-  # Run shinytest with all passing
-  sares[[2]]$pass <- TRUE
-  res2 <- runTestsSpy(test_path("../test-helpers/app1-standard"))
-  expect_true(all(res2$pass))
-  expect_equivalent(res2$file, c("test1", "test2"))
-  expect_s3_class(res2, "shinytestrun")
+  # All are shinytests
+  runTestsSpy <- rewire(runTests, is_legacy_shinytest_dir = is_legacy_shinytest_dir_stub)
+  expect_error(
+    runTestsSpy(test_path("../test-helpers/app1-standard"), assert = FALSE),
+    "not supported"
+  )
 
   # Not shinytests
-  isShinyTest <- FALSE
+  is_legacy_shinytest_val <- FALSE
   res <- runTestsSpy(test_path("../test-helpers/app1-standard"))
-  expect_s3_class(res, "shinytestrun")
+  expect_s3_class(res, "shiny_runtests")
 })
 
 test_that("runTests filters", {
@@ -160,18 +116,74 @@ test_that("runTests handles the absence of tests", {
   expect_equal(res$file, character(0))
   expect_equal(res$pass, logical(0))
   expect_equivalent(res$result, list())
-  expect_equivalent(res$error, list())
-  expect_s3_class(res, "shinytestrun")
+  expect_s3_class(res, "shiny_runtests")
 })
 
 test_that("runTests runs as expected without rewiring", {
-  df <- runTests(appDir = "../test-helpers/app1-standard")
+  appDir <- file.path("..", "test-helpers", "app1-standard")
+  df <- testthat::expect_output(
+    print(runTests(appDir = appDir, assert = FALSE)),
+    "Shiny App Test Results\\n\\* Success\\n  - app1-standard/tests/runner1\\.R\\n  - app1-standard/tests/runner2\\.R"
+  )
+
   expect_equivalent(df, data.frame(
-    file = c("runner1.R", "runner2.R"),
+    file = file.path(appDir, "tests", c("runner1.R", "runner2.R")),
     pass = c(TRUE, TRUE),
     result = I(list(1, NULL)),
-    error = I(list(NA, NA)),
     stringsAsFactors = FALSE
   ))
-  expect_s3_class(df, "shinytestrun")
+  expect_s3_class(df, "shiny_runtests")
+})
+
+
+context("shinyAppTemplate + runTests")
+test_that("app template works with runTests", {
+
+  testthat::skip_on_cran()
+  testthat::skip_if_not_installed("shinytest", "1.3.1.9000")
+
+  # test all combos
+  make_combos <- function(...) {
+    args <- list(...)
+    combo_dt <- do.call(expand.grid, args)
+    lapply(apply(combo_dt, 1, unlist), unname)
+  }
+
+  combos <- unique(unlist(
+    recursive = FALSE,
+    list(
+      "all",
+      # only test cases for shinytest where appropriate, shinytest is "slow"
+      make_combos("app", list(NULL, "module"), "shinytest"),
+      # expand.grid on all combos
+      make_combos("app", list(NULL, "module"), list(NULL, "rdir"), list(NULL, "testthat"))
+    )
+  ))
+
+  lapply(combos, function(combo) {
+    random_folder <- paste0("shinyAppTemplate-", paste0(combo, collapse = "_"))
+    tempTemplateDir <- file.path(tempdir(), random_folder)
+    shinyAppTemplate(tempTemplateDir, combo)
+    on.exit(unlink(tempTemplateDir, recursive = TRUE))
+
+    if (any(c("all", "shinytest", "testthat") %in% combo)) {
+      expect_output(
+        print(runTests(tempTemplateDir)),
+        paste0(
+          "Shiny App Test Results\\n\\* Success",
+          if (any(c("all", "shinytest") %in% combo))
+            paste0("\\n  - ", file.path(random_folder, "tests", "shinytest\\.R")),
+          if (any(c("all", "testthat") %in% combo))
+            paste0("\\n  - ", file.path(random_folder, "tests", "testthat\\.R"))
+        )
+      )
+
+    } else {
+      expect_error(
+        runTests(tempTemplateDir)
+      )
+    }
+
+  })
+
 })

tests/testthat/test-utils.R

@@ -191,3 +191,17 @@ test_that("Callbacks fire in predictable order", {
   cb$invoke()
   expect_equal(x, c(1, 2, 3))
 })
+
+test_that("Application directories are identified", {
+  tests <- test_path("..", "test-modules", "12_counter", "tests")
+  expect_false(isAppDir(tests), "tests directory not an app")
+  expect_true(isAppDir(dirname(tests)), "tests parent directory is an app")
+  expect_equal(
+    findEnclosingApp(tests),
+    normalizePath(dirname(tests), winslash = "/")
+  )
+  expect_equal(
+    findEnclosingApp(dirname(tests)),
+    normalizePath(dirname(tests), winslash = "/")
+  )
+})

tools/documentation/pkgdown.yml

@@ -168,6 +168,8 @@ reference:
   - title: Utility functions
     desc: Miscellaneous utilities that may be useful to advanced users or when extending Shiny.
     contents:
+      - shinyAppTemplate
+      - migrateLegacyShinytest
       - req
       - validate
       - session
@@ -203,7 +205,6 @@ reference:
       - clickOpts
       - dblclickOpts
       - hoverOpts
-      - nearPoints
   - title: Modules
     desc: Functions for modularizing Shiny apps
     contents: