inst/recorder/app.R
In rstudio/shinytest: Test Shiny Apps
library(promises)
target_url <- getOption("shinytest.recorder.url")
app <- getOption("shinytest.app")
debug <- getOption("shinytest.debug")
load_mode <- getOption("shinytest.load.mode")
load_timeout <- getOption("shinytest.load.timeout")
start_seed <- getOption("shinytest.seed")
shiny_options<- getOption("shinytest.shiny.options")
# If there are any reasons to not run a test, a message should be appended to
# this vector.
dont_run_reasons <- character(0)
add_dont_run_reason <- function(reason) {
dont_run_reasons <<- c(dont_run_reasons, reason)
}
if (is.null(target_url) || is.null(app$getAppDir())) {
stop("Test recorder requires the 'shinytest.recorder.url' and ",
"'shinytest.app.dir' options to be set.")
}
# Can't register more than once, so remove existing one just in case.
removeInputHandler("shinytest.testevents")
# Need to avoid Shiny's default recursive unlisting
registerInputHandler("shinytest.testevents", function(val, shinysession, name) {
val
})
escapeString <- function(s) {
# escape \ as well as "
s <- gsub('\\', '\\\\', s, fixed = TRUE)
gsub('"', '\\"', s, fixed = TRUE)
}
# A replacement for deparse() that's a little less verbose for named lists.
deparse2 <- function(x) {
expr <- deparse(x)
expr <- paste(expr, collapse = "")
# If the deparsed expression is something like:
# "structure(list(a = 1, b = 2), .Names = c(\"a\", \"b\"))"
# simplify it to "list(a = 1, b = 2)".
expr <- sub("^structure\\((list.*), \\.Names = c\\([^(]+\\)\\)$", "\\1", expr)
# Same as above, but for single item in .Names, like:
# "structure(list(a = 1), .Names = \"a\")"
expr <- sub('^structure\\((list.*), \\.Names = \\"[^\\"]*\\"\\)$', "\\1", expr)
expr
}
# A modified version of shiny::numericInput but with a placholder
numericInput <- function(..., placeholder = NULL) {
res <- shiny::numericInput(...)
res$children[[2]]$attribs$placeholder <- placeholder
res
}
# Create a question mark icon that displays a tooltip when hovered over.
tooltip <- function(text, placement = "top") {
a(href = "#",
`data-toggle` = "tooltip",
title = text,
icon("question-sign", lib = "glyphicon"),
`data-placement` = placement,
`data-html` = "true"
)
}
enable_tooltip_script <- function() {
tags$script("$('a[data-toggle=\"tooltip\"]').tooltip({ delay: 250 });")
}
# Given a vector/list, return TRUE if any elements are unnamed, FALSE otherwise.
anyUnnamed <- function(x) {
# Zero-length vector
if (length(x) == 0) return(FALSE)
nms <- names(x)
# List with no name attribute
if (is.null(nms)) return(TRUE)
# List with name attribute; check for any ""
any(!nzchar(nms))
}
# Given two named vectors, join them together, and keep only the last element
# with a given name in the resulting vector. If b has any elements with the same
# name as elements in a, the element in a is dropped. Also, if there are any
# duplicated names in a or b, only the last one with that name is kept.
mergeVectors <- function(a, b) {
if (anyUnnamed(a) || anyUnnamed(b)) {
stop("Vectors must be either NULL or have names for all elements")
}
x <- c(a, b)
drop_idx <- duplicated(names(x), fromLast = TRUE)
x[!drop_idx]
}
inputProcessors <- list(
default = function(value) {
# This function is designed to operate on atomic vectors (not lists), so if
# this is a list, we need to unlist it.
if (is.list(value))
value <- unlist(value, recursive = FALSE)
if (length(value) > 1) {
# If it's an array, recurse
vals <- vapply(value, inputProcessors$default, "")
return(paste0(
"c(",
paste0(vals, collapse = ", "),
")"
))
}
if (length(value) == 0) {
return("character(0)")
}
if (is.character(value)) {
return(paste0('"', escapeString(value), '"'))
} else {
return(as.character(value))
}
},
shiny.action = function(value) {
'"click"'
},
shiny.fileupload = function(value) {
# Extract filenames, then send to default processor
value <- vapply(value, function(file) file$name, character(1))
inputProcessors$default(value)
}
)
# Add in input processors registered by other packages.
inputProcessors <- mergeVectors(inputProcessors, shinytest::getInputProcessors())
# Given an input value taken from the client, return the value that would need
# to be passed to app$set_input() to set the input to that value.
processInputValue <- function(value, inputType) {
if (is.null(inputProcessors[[inputType]])) {
# For input with type "mypkg.foo", get "mypkg", and then try to load it.
# This is helpful in cases where the R session running `recordTest()` has
# not loaded the package with the input type. (There's a separate R session
# running the Shiny app.) See https://github.com/rstudio/learnr/pull/407 for
# more info.
pkg <- strsplit(inputType, ".", fixed = TRUE)[[1]][1]
if (tryLoadPackage(pkg)) {
# The set of inputProcessors may have changed by loading the package, so
# re-merge the registered input processors.
inputProcessors <<- mergeVectors(inputProcessors, shinytest::getInputProcessors())
}
}
# Check again if the input type is now registered.
if (is.null(inputProcessors[[inputType]])) {
inputType <- "default"
}
inputProcessors[[inputType]](value)
}
# Try to load a package, but only once; subsequent calls with the same value of
# `pkg` will do nothing. Returns TRUE if the package is successfully loaded,
# FALSE otherwise.
triedPackages <- character()
tryLoadPackage <- function(pkg) {
if (pkg %in% triedPackages) {
return(FALSE)
}
triedPackages <<- c(triedPackages, pkg)
requireNamespace(pkg, quietly = TRUE)
}
# Quote variable/argument names. Normal names like x, x1, or x_y will not be changed, but
# if there are any strange characters, it will be quoted; x-1 will return `x-1`.
quoteName <- function(name) {
if (!grepl("^[a-zA-Z0-9_]*$", name)) {
paste0("`", name, "`")
} else {
name
}
}
codeGenerators <- list(
initialize = function(event, nextEvent = NULL, useTimes = FALSE, ...) {
NA_character_
},
input = function(event, nextEvent = NULL, useTimes = FALSE, allowInputNoBinding = FALSE, ...) {
# Extra arguments when using times
args <- ""
if (useTimes && !is.null(nextEvent)) {
if (nextEvent$type == "input") {
# When using timings, don't wait when next event is also setting an input.
args <- ", values_ = FALSE, wait_ = FALSE"
} else if (nextEvent$type == "outputEvent") {
# When the next event is an output event, use 3 * the timediff value
# (rounded to the nearest whole number) for the timeout, or 3 seconds,
# whichever is larger.
args <- paste0(", timeout_ = ",
max(3000, round(nextEvent$timediff * 3, -3))
)
}
}
if (event$inputType == "shiny.fileupload") {
filename <- processInputValue(event$value, event$inputType)
code <- paste0(
"app$uploadFile(",
quoteName(event$name), " = ", filename,
args,
")"
)
# Get unescaped filenames in a char vector, with full path
filepaths <- vapply(event$value, `[[`, "name", FUN.VALUE = "")
filepaths <- file.path(app$getTestsDir(), filepaths)
# Check that all files exist. If not, add a message and don't run test
# automatically on exit.
if (!all(file.exists(filepaths))) {
add_dont_run_reason("An uploadFile() must be updated: use the correct path relative to the app's tests/shinytest directory, or copy the file to the app's tests/shinytest directory.")
code <- paste0(code,
" # <-- This should be the path to the file, relative to the app's tests/shinytest directory"
)
}
code
} else if (event$hasBinding) {
paste0(
"app$setInputs(",
quoteName(event$name), " = ",
processInputValue(event$value, event$inputType),
args,
")"
)
} else {
if (allowInputNoBinding) {
args <- paste0(args, ", allowInputNoBinding_ = TRUE")
if (identical(event$priority, "event")) args <- paste0(args, ', priority_ = "event"')
paste0(
"app$setInputs(",
quoteName(event$name), " = ",
processInputValue(event$value, inputType = "default"),
args,
")"
)
} else {
paste0(
"# Input '", quoteName(event$name),
"' was set, but doesn't have an input binding."
)
}
}
},
fileDownload = function(event, nextEvent = NULL, useTimes = FALSE, ...) {
paste0('app$snapshotDownload("', event$name, '")')
},
outputEvent = function(event, nextEvent = NULL, useTimes = FALSE, ...) {
NA_character_
},
outputSnapshot = function(event, nextEvent = NULL, useTimes = FALSE, ...) {
paste0('app$snapshot(list(output = "', event$name, '"))')
},
snapshot = function(event, nextEvent = NULL, useTimes = FALSE, ...) {
"app$snapshot()"
}
)
generateTestCode <- function(events, name, seed, useTimes = FALSE,
allowInputNoBinding = FALSE)
{
if (useTimes) {
# Convert from absolute to relative times; first event has time 0.
startTime <- NA
if (length(events) != 0) {
events[[1]]$timediff <- 0
for (i in seq_len(length(events)-1)) {
events[[i+1]]$timediff <- events[[i+1]]$time - events[[i]]$time
}
}
}
# Generate code for each input and output event
eventCode <- mapply(
function(event, nextEvent, useTimes) {
codeGenerators[[event$type]](event, nextEvent, useTimes,
allowInputNoBinding = allowInputNoBinding)
},
events,
c(events[-1], list(NULL)),
useTimes
)
# Find the indices of the initialize event and output events. The code lines
# and (optional) Sys.sleep() calls for these events will be removed later.
# We need the output events for now in order to calculate times.
removeEvents <- vapply(events, function(event) {
event$type %in% c("initialize", "outputEvent")
}, logical(1))
if (length(eventCode) != 0) {
if (useTimes) {
timingCode <- vapply(events, function(event) {
sprintf("Sys.sleep(%0.1f)", event$timediff / 1000)
}, "")
# Remove unwanted events
eventCode <- eventCode[!removeEvents]
timingCode <- timingCode[!removeEvents]
# Interleave events and times with c(rbind()) trick
eventCode <- c(rbind(timingCode, eventCode))
} else {
# Remove unwanted events
eventCode <- eventCode[!removeEvents]
}
eventCode <- paste(eventCode, collapse = "\n")
}
paste(
if (load_mode) {
'app <- ShinyLoadDriver$new()'
} else {
paste0(
# Need paste instead of file.path because app$getAppFileName() can be NULL which makes file.path grumpy.
'app <- ShinyDriver$new("', paste(app$getRelativePathToApp(), app$getAppFilename(), sep="/"), '"',
if (!is.null(seed)) sprintf(", seed = %s", seed),
if (!is.null(load_timeout)) paste0(", loadTimeout = ", load_timeout),
if (length(shiny_options) > 0) paste0(", shinyOptions = ", deparse2(shiny_options)),
')'
)
},
paste0('app$snapshotInit("', name, '")'),
'',
eventCode,
if (load_mode) {
'\napp$snapshot()\napp$stop()\napp$getEventLog()\n'
},
sep = "\n"
)
}
hasInputsWithoutBinding <- function(events) {
any(vapply(events, function(event) {
return(event$type == "input" && !event$hasBinding)
}, TRUE))
}
shinyApp(
ui = fluidPage(
tags$head(
tags$link(rel = "stylesheet", type = "text/css", href = "recorder.css"),
tags$script(src = "inject-recorder.js")
),
div(id = "app-iframe-container",
tags$iframe(id = "app-iframe", src = target_url)
),
div(id = "shiny-recorder",
div(class = "shiny-recorder-header", "Test event recorder"),
div(class = "shiny-recorder-controls",
if (!load_mode) {
span(
actionLink("snapshot",
span(
img(src = "snapshot.png", class = "shiny-recorder-icon"),
"Take snapshot"
),
style = "display: inline;"
),
tooltip(
HTML("You can also Ctrl-click or ⌘-click on an output to snapshot just that one output.<br> To trigger a snapshot via the keyboard, press Ctrl-shift-S or ⌘-shift-S"),
placement = "bottom"
),
hr()
)
},
actionLink("exit_save",
span(
img(src = "exit-save.png", class = "shiny-recorder-icon"),
"Save script and exit test event recorder"
)
),
actionLink("exit_nosave",
span(
img(src = "exit-nosave.png", class = "shiny-recorder-icon"),
"Quit without saving"
)
),
textInput("testname", label = "On exit, save test script as:",
value = if (load_mode) "myloadtest" else "mytest"),
checkboxInput("editSaveFile", "Open script in editor on exit", value = TRUE),
if (!load_mode) checkboxInput("runScript", "Run test script on exit", value = TRUE),
checkboxInput(
"allowInputNoBinding",
tagList("Save inputs that do not have a binding",
tooltip(
paste(
"This enables recording inputs that do not have a binding, which is common in htmlwidgets",
"like DT and plotly. Note that playback support is limited: shinytest will set the input",
"value so that R gets the input value, but the htmlwidget itself will not be aware of the value."
),
placement = "bottom"
)
),
value = FALSE
),
numericInput("seed",
label = tagList("Random seed:",
tooltip("A seed is recommended if your application uses any randomness. This includes all Shiny Rmd documents.")
),
value = start_seed,
placeholder = "(None)"
)
),
div(class = "shiny-recorder-header", "Recorded events"),
div(id = "recorded-events",
tableOutput("recordedEvents")
),
enable_tooltip_script()
)
),
server = function(input, output) {
# Read the recorder.js file for injection into iframe
output$recorder_js <- renderText({
file <- "recorder.js"
readChar(file, file.info(file)$size, useBytes = TRUE)
})
outputOptions(output, "recorder_js", suspendWhenHidden = FALSE)
# echo console output from the driver object (in real-time)
if (!identical(debug, "none")) {
nConsoleLines <- 0
observe({
invalidateLater(500)
logs <- app$getDebugLog(debug)
n <- nrow(logs)
if (n > nConsoleLines) {
newLines <- seq.int(nConsoleLines + 1, n)
print(logs[newLines, ], short = TRUE)
cat("\n")
}
nConsoleLines <<- n
})
}
saveFile <- reactive({
file.path(app$getTestsDir(), paste0(input$testname, ".R"))
})
# Number of snapshot or fileDownload events in input$testevents
numSnapshots <- reactive({
snapshots <- vapply(input$testevents, function(event) {
return(event$type %in% c("snapshot", "outputSnapshot", "fileDownload"))
}, logical(1))
sum(snapshots)
})
output$recordedEvents <- renderTable(
{
# Genereate list of lists from all events. Inner lists have 'type' and
# 'name' fields.
events <- lapply(input$testevents, function(event) {
type <- event$type
if (type == "initialize") {
NULL
} else if (type == "outputSnapshot") {
list(type = "snapshot-output", name = event$name)
} else if (type == "snapshot") {
list(type = "snapshot", name = "<all>")
} else if (type == "input") {
if (event$inputType == "shiny.fileupload") {
# File uploads are a special case of inputs
list(type = "file-upload", name = event$name)
} else if (!event$hasBinding) {
list(type = "input *", name = event$name)
} else {
list(type = "input", name = event$name)
}
} else if (type == "fileDownload") {
list(type = "file-download", name = event$name)
} else if (type == "outputEvent") {
list(type = "output-event", name = "--")
}
})
events <- events[!vapply(events, is.null, logical(1))]
# Transpose list of lists into data frame
data.frame(
`Event type` = vapply(events, `[[`, character(1), "type"),
Name = vapply(events, `[[`, character(1), "name"),
stringsAsFactors = FALSE,
check.names = FALSE
)
},
width = "100%",
rownames = TRUE
)
saveAndExit <- function() {
stopApp({
# If no snapshot events occurred, don't write file. However, in load
# testing mode, we don't expect snapshots (except one at the end).
if (!load_mode && numSnapshots() == 0) {
message("No snapshot or download events occurred; not saving test code.")
invisible(list(
appDir = NULL,
file = NULL,
run = FALSE
))
} else {
seed <- as.integer(input$seed)
if (is.null(seed) || is.na(seed))
seed <- NULL
code <- generateTestCode(input$testevents, input$testname,
seed = seed, useTimes = load_mode,
allowInputNoBinding = input$allowInputNoBinding)
cat(code, file = saveFile())
message("Saved test code to ", saveFile())
if (input$editSaveFile)
file.edit(saveFile())
invisible(list(
appDir = app$getAppDir(),
file = paste0(input$testname, ".R"),
run = input$runScript && (length(dont_run_reasons) == 0),
dont_run_reasons = dont_run_reasons
))
}
})
}
presentModal <- function(modalDialog, cancel, ok) {
promise(function(resolve, reject) {
cancelObs <- observeEvent(input[[cancel]],
{
okObs$destroy()
cancelObs$destroy()
reject("cancelObs")
},
ignoreInit = TRUE
)
okObs <- observeEvent(input[[ok]],
{
okObs$destroy()
cancelObs$destroy()
resolve(TRUE)
},
ignoreInit = TRUE
)
showModal(modalDialog)
})
}
observeEvent(input$exit_save, {
if (!load_mode && numSnapshots() == 0) {
showModal(
modalDialog("Must have at least one snapshot to save and exit.")
)
return()
}
p <- promise_resolve(TRUE)
if (hasInputsWithoutBinding(input$testevents) && !input$allowInputNoBinding) {
p <- p %...>% {
presentModal(
modalDialog(
tagList(
"There are some input events (marked with a *) that do not have a corresponding input binding.",
"If you want them to be saved in the test script, press Cancel, then check ",
tags$b("Save inputs that do not have a binding."),
"If you don't want to save them, press Continue."
),
footer = tagList(
actionButton("inputs_no_binding_cancel", "Cancel", `data-dismiss` = "modal"),
actionButton("inputs_no_binding_continue", "Continue", `data-dismiss` = "modal")
)
),
"inputs_no_binding_cancel",
"inputs_no_binding_continue"
)
}
}
p <- p %...>% {
if (file.exists(saveFile())) {
presentModal(
modalDialog(
paste0("Overwrite ", basename(saveFile()), "?"),
footer = tagList(
actionButton("overwrite_cancel", "Cancel", `data-dismiss` = "modal"),
actionButton("overwrite_continue", "Continue", `data-dismiss` = "modal")
)
),
"overwrite_cancel",
"overwrite_continue"
)
} else {
promise_resolve(TRUE)
}
}
p <- p %...>% {
saveAndExit()
}
# When Cancel is pressed, catch the rejection.
p <- p %...!% {
NULL
}
# Need to return something other than the promise. Otherwise Shiny will
# wait for the promise to resolve before processing any further
# reactivity, including the inputs from the actionButtons, so the app
# will simply stop responding.
NULL
})
observeEvent(input$exit_nosave, {
stopApp({
message("Quitting without saving or running tests.")
invisible(list(
appDir = NULL,
file = NULL,
run = FALSE
))
})
})
}
)
rstudio/shinytest documentation built on March 5, 2024, 5:12 a.m.
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
library(promises)
target_url <- getOption("shinytest.recorder.url")
app <- getOption("shinytest.app")
debug <- getOption("shinytest.debug")
load_mode <- getOption("shinytest.load.mode")
load_timeout <- getOption("shinytest.load.timeout")
start_seed <- getOption("shinytest.seed")
shiny_options<- getOption("shinytest.shiny.options")
# If there are any reasons to not run a test, a message should be appended to
# this vector.
dont_run_reasons <- character(0)
add_dont_run_reason <- function(reason) {
dont_run_reasons <<- c(dont_run_reasons, reason)
}
if (is.null(target_url) || is.null(app$getAppDir())) {
stop("Test recorder requires the 'shinytest.recorder.url' and ",
"'shinytest.app.dir' options to be set.")
}
# Can't register more than once, so remove existing one just in case.
removeInputHandler("shinytest.testevents")
# Need to avoid Shiny's default recursive unlisting
registerInputHandler("shinytest.testevents", function(val, shinysession, name) {
val
})
escapeString <- function(s) {
# escape \ as well as "
s <- gsub('\\', '\\\\', s, fixed = TRUE)
gsub('"', '\\"', s, fixed = TRUE)
}
# A replacement for deparse() that's a little less verbose for named lists.
deparse2 <- function(x) {
expr <- deparse(x)
expr <- paste(expr, collapse = "")
# If the deparsed expression is something like:
# "structure(list(a = 1, b = 2), .Names = c(\"a\", \"b\"))"
# simplify it to "list(a = 1, b = 2)".
expr <- sub("^structure\\((list.*), \\.Names = c\\([^(]+\\)\\)$", "\\1", expr)
# Same as above, but for single item in .Names, like:
# "structure(list(a = 1), .Names = \"a\")"
expr <- sub('^structure\\((list.*), \\.Names = \\"[^\\"]*\\"\\)$', "\\1", expr)
expr
}
# A modified version of shiny::numericInput but with a placholder
numericInput <- function(..., placeholder = NULL) {
res <- shiny::numericInput(...)
res$children[[2]]$attribs$placeholder <- placeholder
res
}
# Create a question mark icon that displays a tooltip when hovered over.
tooltip <- function(text, placement = "top") {
a(href = "#",
`data-toggle` = "tooltip",
title = text,
icon("question-sign", lib = "glyphicon"),
`data-placement` = placement,
`data-html` = "true"
)
}
enable_tooltip_script <- function() {
tags$script("$('a[data-toggle=\"tooltip\"]').tooltip({ delay: 250 });")
}
# Given a vector/list, return TRUE if any elements are unnamed, FALSE otherwise.
anyUnnamed <- function(x) {
# Zero-length vector
if (length(x) == 0) return(FALSE)
nms <- names(x)
# List with no name attribute
if (is.null(nms)) return(TRUE)
# List with name attribute; check for any ""
any(!nzchar(nms))
}
# Given two named vectors, join them together, and keep only the last element
# with a given name in the resulting vector. If b has any elements with the same
# name as elements in a, the element in a is dropped. Also, if there are any
# duplicated names in a or b, only the last one with that name is kept.
mergeVectors <- function(a, b) {
if (anyUnnamed(a) || anyUnnamed(b)) {
stop("Vectors must be either NULL or have names for all elements")
}
x <- c(a, b)
drop_idx <- duplicated(names(x), fromLast = TRUE)
x[!drop_idx]
}
inputProcessors <- list(
default = function(value) {
# This function is designed to operate on atomic vectors (not lists), so if
# this is a list, we need to unlist it.
if (is.list(value))
value <- unlist(value, recursive = FALSE)
if (length(value) > 1) {
# If it's an array, recurse
vals <- vapply(value, inputProcessors$default, "")
return(paste0(
"c(",
paste0(vals, collapse = ", "),
")"
))
}
if (length(value) == 0) {
return("character(0)")
}
if (is.character(value)) {
return(paste0('"', escapeString(value), '"'))
} else {
return(as.character(value))
}
},
shiny.action = function(value) {
'"click"'
},
shiny.fileupload = function(value) {
# Extract filenames, then send to default processor
value <- vapply(value, function(file) file$name, character(1))
inputProcessors$default(value)
}
)
# Add in input processors registered by other packages.
inputProcessors <- mergeVectors(inputProcessors, shinytest::getInputProcessors())
# Given an input value taken from the client, return the value that would need
# to be passed to app$set_input() to set the input to that value.
processInputValue <- function(value, inputType) {
if (is.null(inputProcessors[[inputType]])) {
# For input with type "mypkg.foo", get "mypkg", and then try to load it.
# This is helpful in cases where the R session running `recordTest()` has
# not loaded the package with the input type. (There's a separate R session
# running the Shiny app.) See https://github.com/rstudio/learnr/pull/407 for
# more info.
pkg <- strsplit(inputType, ".", fixed = TRUE)[[1]][1]
if (tryLoadPackage(pkg)) {
# The set of inputProcessors may have changed by loading the package, so
# re-merge the registered input processors.
inputProcessors <<- mergeVectors(inputProcessors, shinytest::getInputProcessors())
}
}
# Check again if the input type is now registered.
if (is.null(inputProcessors[[inputType]])) {
inputType <- "default"
}
inputProcessors[[inputType]](value)
}
# Try to load a package, but only once; subsequent calls with the same value of
# `pkg` will do nothing. Returns TRUE if the package is successfully loaded,
# FALSE otherwise.
triedPackages <- character()
tryLoadPackage <- function(pkg) {
if (pkg %in% triedPackages) {
return(FALSE)
}
triedPackages <<- c(triedPackages, pkg)
requireNamespace(pkg, quietly = TRUE)
}
# Quote variable/argument names. Normal names like x, x1, or x_y will not be changed, but
# if there are any strange characters, it will be quoted; x-1 will return `x-1`.
quoteName <- function(name) {
if (!grepl("^[a-zA-Z0-9_]*$", name)) {
paste0("`", name, "`")
} else {
name
}
}
codeGenerators <- list(
initialize = function(event, nextEvent = NULL, useTimes = FALSE, ...) {
NA_character_
},
input = function(event, nextEvent = NULL, useTimes = FALSE, allowInputNoBinding = FALSE, ...) {
# Extra arguments when using times
args <- ""
if (useTimes && !is.null(nextEvent)) {
if (nextEvent$type == "input") {
# When using timings, don't wait when next event is also setting an input.
args <- ", values_ = FALSE, wait_ = FALSE"
} else if (nextEvent$type == "outputEvent") {
# When the next event is an output event, use 3 * the timediff value
# (rounded to the nearest whole number) for the timeout, or 3 seconds,
# whichever is larger.
args <- paste0(", timeout_ = ",
max(3000, round(nextEvent$timediff * 3, -3))
)
}
}
if (event$inputType == "shiny.fileupload") {
filename <- processInputValue(event$value, event$inputType)
code <- paste0(
"app$uploadFile(",
quoteName(event$name), " = ", filename,
args,
")"
)
# Get unescaped filenames in a char vector, with full path
filepaths <- vapply(event$value, `[[`, "name", FUN.VALUE = "")
filepaths <- file.path(app$getTestsDir(), filepaths)
# Check that all files exist. If not, add a message and don't run test
# automatically on exit.
if (!all(file.exists(filepaths))) {
add_dont_run_reason("An uploadFile() must be updated: use the correct path relative to the app's tests/shinytest directory, or copy the file to the app's tests/shinytest directory.")
code <- paste0(code,
" # <-- This should be the path to the file, relative to the app's tests/shinytest directory"
)
}
code
} else if (event$hasBinding) {
paste0(
"app$setInputs(",
quoteName(event$name), " = ",
processInputValue(event$value, event$inputType),
args,
")"
)
} else {
if (allowInputNoBinding) {
args <- paste0(args, ", allowInputNoBinding_ = TRUE")
if (identical(event$priority, "event")) args <- paste0(args, ', priority_ = "event"')
paste0(
"app$setInputs(",
quoteName(event$name), " = ",
processInputValue(event$value, inputType = "default"),
args,
")"
)
} else {
paste0(
"# Input '", quoteName(event$name),
"' was set, but doesn't have an input binding."
)
}
}
},
fileDownload = function(event, nextEvent = NULL, useTimes = FALSE, ...) {
paste0('app$snapshotDownload("', event$name, '")')
},
outputEvent = function(event, nextEvent = NULL, useTimes = FALSE, ...) {
NA_character_
},
outputSnapshot = function(event, nextEvent = NULL, useTimes = FALSE, ...) {
paste0('app$snapshot(list(output = "', event$name, '"))')
},
snapshot = function(event, nextEvent = NULL, useTimes = FALSE, ...) {
"app$snapshot()"
}
)
generateTestCode <- function(events, name, seed, useTimes = FALSE,
allowInputNoBinding = FALSE)
{
if (useTimes) {
# Convert from absolute to relative times; first event has time 0.
startTime <- NA
if (length(events) != 0) {
events[[1]]$timediff <- 0
for (i in seq_len(length(events)-1)) {
events[[i+1]]$timediff <- events[[i+1]]$time - events[[i]]$time
}
}
}
# Generate code for each input and output event
eventCode <- mapply(
function(event, nextEvent, useTimes) {
codeGenerators[[event$type]](event, nextEvent, useTimes,
allowInputNoBinding = allowInputNoBinding)
},
events,
c(events[-1], list(NULL)),
useTimes
)
# Find the indices of the initialize event and output events. The code lines
# and (optional) Sys.sleep() calls for these events will be removed later.
# We need the output events for now in order to calculate times.
removeEvents <- vapply(events, function(event) {
event$type %in% c("initialize", "outputEvent")
}, logical(1))
if (length(eventCode) != 0) {
if (useTimes) {
timingCode <- vapply(events, function(event) {
sprintf("Sys.sleep(%0.1f)", event$timediff / 1000)
}, "")
# Remove unwanted events
eventCode <- eventCode[!removeEvents]
timingCode <- timingCode[!removeEvents]
# Interleave events and times with c(rbind()) trick
eventCode <- c(rbind(timingCode, eventCode))
} else {
# Remove unwanted events
eventCode <- eventCode[!removeEvents]
}
eventCode <- paste(eventCode, collapse = "\n")
}
paste(
if (load_mode) {
'app <- ShinyLoadDriver$new()'
} else {
paste0(
# Need paste instead of file.path because app$getAppFileName() can be NULL which makes file.path grumpy.
'app <- ShinyDriver$new("', paste(app$getRelativePathToApp(), app$getAppFilename(), sep="/"), '"',
if (!is.null(seed)) sprintf(", seed = %s", seed),
if (!is.null(load_timeout)) paste0(", loadTimeout = ", load_timeout),
if (length(shiny_options) > 0) paste0(", shinyOptions = ", deparse2(shiny_options)),
')'
)
},
paste0('app$snapshotInit("', name, '")'),
'',
eventCode,
if (load_mode) {
'\napp$snapshot()\napp$stop()\napp$getEventLog()\n'
},
sep = "\n"
)
}
hasInputsWithoutBinding <- function(events) {
any(vapply(events, function(event) {
return(event$type == "input" && !event$hasBinding)
}, TRUE))
}
shinyApp(
ui = fluidPage(
tags$head(
tags$link(rel = "stylesheet", type = "text/css", href = "recorder.css"),
tags$script(src = "inject-recorder.js")
),
div(id = "app-iframe-container",
tags$iframe(id = "app-iframe", src = target_url)
),
div(id = "shiny-recorder",
div(class = "shiny-recorder-header", "Test event recorder"),
div(class = "shiny-recorder-controls",
if (!load_mode) {
span(
actionLink("snapshot",
span(
img(src = "snapshot.png", class = "shiny-recorder-icon"),
"Take snapshot"
),
style = "display: inline;"
),
tooltip(
HTML("You can also Ctrl-click or ⌘-click on an output to snapshot just that one output.<br> To trigger a snapshot via the keyboard, press Ctrl-shift-S or ⌘-shift-S"),
placement = "bottom"
),
hr()
)
},
actionLink("exit_save",
span(
img(src = "exit-save.png", class = "shiny-recorder-icon"),
"Save script and exit test event recorder"
)
),
actionLink("exit_nosave",
span(
img(src = "exit-nosave.png", class = "shiny-recorder-icon"),
"Quit without saving"
)
),
textInput("testname", label = "On exit, save test script as:",
value = if (load_mode) "myloadtest" else "mytest"),
checkboxInput("editSaveFile", "Open script in editor on exit", value = TRUE),
if (!load_mode) checkboxInput("runScript", "Run test script on exit", value = TRUE),
checkboxInput(
"allowInputNoBinding",
tagList("Save inputs that do not have a binding",
tooltip(
paste(
"This enables recording inputs that do not have a binding, which is common in htmlwidgets",
"like DT and plotly. Note that playback support is limited: shinytest will set the input",
"value so that R gets the input value, but the htmlwidget itself will not be aware of the value."
),
placement = "bottom"
)
),
value = FALSE
),
numericInput("seed",
label = tagList("Random seed:",
tooltip("A seed is recommended if your application uses any randomness. This includes all Shiny Rmd documents.")
),
value = start_seed,
placeholder = "(None)"
)
),
div(class = "shiny-recorder-header", "Recorded events"),
div(id = "recorded-events",
tableOutput("recordedEvents")
),
enable_tooltip_script()
)
),
server = function(input, output) {
# Read the recorder.js file for injection into iframe
output$recorder_js <- renderText({
file <- "recorder.js"
readChar(file, file.info(file)$size, useBytes = TRUE)
})
outputOptions(output, "recorder_js", suspendWhenHidden = FALSE)
# echo console output from the driver object (in real-time)
if (!identical(debug, "none")) {
nConsoleLines <- 0
observe({
invalidateLater(500)
logs <- app$getDebugLog(debug)
n <- nrow(logs)
if (n > nConsoleLines) {
newLines <- seq.int(nConsoleLines + 1, n)
print(logs[newLines, ], short = TRUE)
cat("\n")
}
nConsoleLines <<- n
})
}
saveFile <- reactive({
file.path(app$getTestsDir(), paste0(input$testname, ".R"))
})
# Number of snapshot or fileDownload events in input$testevents
numSnapshots <- reactive({
snapshots <- vapply(input$testevents, function(event) {
return(event$type %in% c("snapshot", "outputSnapshot", "fileDownload"))
}, logical(1))
sum(snapshots)
})
output$recordedEvents <- renderTable(
{
# Genereate list of lists from all events. Inner lists have 'type' and
# 'name' fields.
events <- lapply(input$testevents, function(event) {
type <- event$type
if (type == "initialize") {
NULL
} else if (type == "outputSnapshot") {
list(type = "snapshot-output", name = event$name)
} else if (type == "snapshot") {
list(type = "snapshot", name = "<all>")
} else if (type == "input") {
if (event$inputType == "shiny.fileupload") {
# File uploads are a special case of inputs
list(type = "file-upload", name = event$name)
} else if (!event$hasBinding) {
list(type = "input *", name = event$name)
} else {
list(type = "input", name = event$name)
}
} else if (type == "fileDownload") {
list(type = "file-download", name = event$name)
} else if (type == "outputEvent") {
list(type = "output-event", name = "--")
}
})
events <- events[!vapply(events, is.null, logical(1))]
# Transpose list of lists into data frame
data.frame(
`Event type` = vapply(events, `[[`, character(1), "type"),
Name = vapply(events, `[[`, character(1), "name"),
stringsAsFactors = FALSE,
check.names = FALSE
)
},
width = "100%",
rownames = TRUE
)
saveAndExit <- function() {
stopApp({
# If no snapshot events occurred, don't write file. However, in load
# testing mode, we don't expect snapshots (except one at the end).
if (!load_mode && numSnapshots() == 0) {
message("No snapshot or download events occurred; not saving test code.")
invisible(list(
appDir = NULL,
file = NULL,
run = FALSE
))
} else {
seed <- as.integer(input$seed)
if (is.null(seed) || is.na(seed))
seed <- NULL
code <- generateTestCode(input$testevents, input$testname,
seed = seed, useTimes = load_mode,
allowInputNoBinding = input$allowInputNoBinding)
cat(code, file = saveFile())
message("Saved test code to ", saveFile())
if (input$editSaveFile)
file.edit(saveFile())
invisible(list(
appDir = app$getAppDir(),
file = paste0(input$testname, ".R"),
run = input$runScript && (length(dont_run_reasons) == 0),
dont_run_reasons = dont_run_reasons
))
}
})
}
presentModal <- function(modalDialog, cancel, ok) {
promise(function(resolve, reject) {
cancelObs <- observeEvent(input[[cancel]],
{
okObs$destroy()
cancelObs$destroy()
reject("cancelObs")
},
ignoreInit = TRUE
)
okObs <- observeEvent(input[[ok]],
{
okObs$destroy()
cancelObs$destroy()
resolve(TRUE)
},
ignoreInit = TRUE
)
showModal(modalDialog)
})
}
observeEvent(input$exit_save, {
if (!load_mode && numSnapshots() == 0) {
showModal(
modalDialog("Must have at least one snapshot to save and exit.")
)
return()
}
p <- promise_resolve(TRUE)
if (hasInputsWithoutBinding(input$testevents) && !input$allowInputNoBinding) {
p <- p %...>% {
presentModal(
modalDialog(
tagList(
"There are some input events (marked with a *) that do not have a corresponding input binding.",
"If you want them to be saved in the test script, press Cancel, then check ",
tags$b("Save inputs that do not have a binding."),
"If you don't want to save them, press Continue."
),
footer = tagList(
actionButton("inputs_no_binding_cancel", "Cancel", `data-dismiss` = "modal"),
actionButton("inputs_no_binding_continue", "Continue", `data-dismiss` = "modal")
)
),
"inputs_no_binding_cancel",
"inputs_no_binding_continue"
)
}
}
p <- p %...>% {
if (file.exists(saveFile())) {
presentModal(
modalDialog(
paste0("Overwrite ", basename(saveFile()), "?"),
footer = tagList(
actionButton("overwrite_cancel", "Cancel", `data-dismiss` = "modal"),
actionButton("overwrite_continue", "Continue", `data-dismiss` = "modal")
)
),
"overwrite_cancel",
"overwrite_continue"
)
} else {
promise_resolve(TRUE)
}
}
p <- p %...>% {
saveAndExit()
}
# When Cancel is pressed, catch the rejection.
p <- p %...!% {
NULL
}
# Need to return something other than the promise. Otherwise Shiny will
# wait for the promise to resolve before processing any further
# reactivity, including the inputs from the actionButtons, so the app
# will simply stop responding.
NULL
})
observeEvent(input$exit_nosave, {
stopApp({
message("Quitting without saving or running tests.")
invisible(list(
appDir = NULL,
file = NULL,
run = FALSE
))
})
})
}
)
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
Embedding an R snippet on your website
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.