#' Launch test event recorder for a Shiny app
#'
#' @param app A [ShinyDriver()] object, or path to a Shiny
#' application.
#' @param save_dir A directory to save stuff.
#' @param load_mode A boolean that determines whether or not the resulting test
#' script should be appropriate for load testing.
#' @param seed A random seed to set before running the app. This seed will also
#' be used in the test script.
#' @param loadTimeout Maximum time to wait for the Shiny application to load, in
#' milliseconds. If a value is provided, it will be saved in the test script.
#' @param debug start the underlying [ShinyDriver()] in `debug`
#' mode and print those debug logs to the R console once recording is
#' finished. The default, `'shiny_console'`, captures and prints R
#' console output from the recorded R shiny process. Any value that the
#' `debug` argument in [ShinyDriver()] accepts may be used
#' (e.g., `'none'` may be used to completely suppress the driver logs).
#' @param shinyOptions A list of options to pass to `runApp()`. If a value
#' is provided, it will be saved in the test script.
#' @export
recordTest <- function(app = ".", save_dir = NULL, load_mode = FALSE, seed = NULL,
loadTimeout = 10000, debug = "shiny_console", shinyOptions = list()) {
# Get the URL for the app. Depending on what type of object `app` is, it may
# require starting an app.
if (inherits(app, "ShinyDriver")) {
url <- app$getUrl()
} else if (is.character(app)) {
if (grepl("^http(s?)://", app)) {
abort("Recording tests for remote apps is not yet supported.")
} else {
path <- app_path(app, "app")$app
# Rmds need a random seed
if (is_rmd(path) && is.null(seed)) {
seed <- floor(stats::runif(1, min = 0, max = 1e5))
}
app <- ShinyDriver$new(path, seed = seed, loadTimeout = loadTimeout, shinyOptions = shinyOptions)
on.exit({
rm(app)
gc()
})
url <- app$getUrl()
}
} else if (inherits(app, "shiny.appobj")) {
abort("Recording tests for shiny.appobj objects is not supported.")
} else {
abort("Unknown object type to record tests for.")
}
# Create directory if needed
if (is.null(save_dir)) {
save_dir <- findTestsDir(app$getAppDir(), mustExist=FALSE, quiet=FALSE)
if (!dir_exists(save_dir)) {
dir.create(save_dir, recursive=TRUE)
# findTestsDir would return the nested shinytest/ directory if the dir didn't exist,
# so since we're creating the nested structure, we should leave behind the top-
# level runner, too.
runner <- paste0("library(shinytest)\nshinytest::testApp(\"../\")\n")
writeLines(runner, file.path(save_dir, "..", "shinytest.R"))
}
save_dir <- normalizePath(save_dir)
}
# Are we running in RStudio? If so, we might need to fix up the URL so that
# it's externally accessible.
if (rstudioapi::isAvailable()) {
if (rstudioapi::hasFun("translateLocalUrl")) {
# If the RStudio API knows how to translate URLs, call it.
url <- rstudioapi::translateLocalUrl(url, absolute = TRUE)
} else if (identical(rstudioapi::versionInfo()$mode, "server")) {
# Older versions of the RStudio API don't know how to translate URLs, so
# we'll need to do it ourselves if we're in server mode. For example,
# http://localhost:1234/ is translated to ../../p/1234/.
url <- paste0("../../p/", gsub(".*:([0-9]+)\\/?", "\\1", url), "/")
}
}
# Use options to pass value to recorder app
withr::with_options(
list(
shinytest.recorder.url = url,
shinytest.app = app,
shinytest.debug = debug,
shinytest.load.mode = load_mode,
shinytest.load.timeout = if (!missing(loadTimeout)) loadTimeout,
shinytest.seed = seed,
shinytest.shiny.options = shinyOptions
),
res <- shiny::runApp(system.file("recorder", package = "shinytest"))
)
if (is.null(res$appDir)) {
# Quit without saving
} else if (isTRUE(res$run)) {
# Before running the test, sometimes we need to make sure the previous run
# of the app is shut down. For example, if a port is specified in
# shinyOptions, it needs to be freed up before starting the app again.
gc()
# Run the test script
testApp(rel_path(res$appDir), res$file)
} else {
if (length(res$dont_run_reasons) > 0) {
inform(c("Not running test script because", res$dont_run_reasons))
}
inform(sprintf(
'After making changes to the test script, run it with:\n testApp("%s", "%s")',
rel_path(res$appDir), res$file
))
}
invisible(res$file)
}
#' Register an input processor for the test recorder
#'
#' @description
#' `registerInputProcessor()` registers an input processor which will be used by
#' the test recorder. The input processor function should take one parameter,
#' `value`, and return a string of R code which returns the desired value.
#'
#' `getInputProcessors()` returns a named list of all registered input processor
#' functions.
#'
#' @param inputType The name of an input type, for example,
#' `"mypkg.numberinput"`.
#' @param processor An input processor function.
#' @export
#' @keywords internal
registerInputProcessor <- function(inputType, processor) {
if (!is.function(processor) || !identical(names(formals(processor)), "value")) {
abort("`processor` must be a function that takes one parameter, `value`")
}
recorder_input_processors[[inputType]] <- processor
}
#' @rdname registerInputProcessor
#' @export
getInputProcessors <- function() {
as.list(recorder_input_processors)
}
# This environment holds input processors registered by other packages on load.
recorder_input_processors <- new.env(parent = emptyenv())
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.