diff --git a/R/ace.R b/R/ace.R
index 454944bc3..5c7087386 100644
--- a/R/ace.R
+++ b/R/ace.R
@@ -1,3 +1,48 @@
# This file was autogenerated by 'tools/update-ace.R'
ACE_VERSION <- "1.10.1"
-ACE_THEMES <- c("ambiance", "chaos", "chrome", "cloud9_day", "cloud9_night_low_color", "cloud9_night", "clouds_midnight", "clouds", "cobalt", "crimson_editor", "dawn", "dracula", "dreamweaver", "eclipse", "github", "gob", "gruvbox_dark_hard", "gruvbox_light_hard", "gruvbox", "idle_fingers", "iplastic", "katzenmilch", "kr_theme", "kuroir", "merbivore_soft", "merbivore", "mono_industrial", "monokai", "nord_dark", "one_dark", "pastel_on_dark", "solarized_dark", "solarized_light", "sqlserver", "terminal", "textmate", "tomorrow_night_blue", "tomorrow_night_bright", "tomorrow_night_eighties", "tomorrow_night", "tomorrow", "twilight", "vibrant_ink", "xcode")
+ACE_THEMES <- c(
+ "ambiance",
+ "chaos",
+ "chrome",
+ "cloud9_day",
+ "cloud9_night_low_color",
+ "cloud9_night",
+ "clouds_midnight",
+ "clouds",
+ "cobalt",
+ "crimson_editor",
+ "dawn",
+ "dracula",
+ "dreamweaver",
+ "eclipse",
+ "github",
+ "gob",
+ "gruvbox_dark_hard",
+ "gruvbox_light_hard",
+ "gruvbox",
+ "idle_fingers",
+ "iplastic",
+ "katzenmilch",
+ "kr_theme",
+ "kuroir",
+ "merbivore_soft",
+ "merbivore",
+ "mono_industrial",
+ "monokai",
+ "nord_dark",
+ "one_dark",
+ "pastel_on_dark",
+ "solarized_dark",
+ "solarized_light",
+ "sqlserver",
+ "terminal",
+ "textmate",
+ "tomorrow_night_blue",
+ "tomorrow_night_bright",
+ "tomorrow_night_eighties",
+ "tomorrow_night",
+ "tomorrow",
+ "twilight",
+ "vibrant_ink",
+ "xcode"
+)
diff --git a/R/auto-complete.R b/R/auto-complete.R
index a6c3b6d4e..b58fae83b 100644
--- a/R/auto-complete.R
+++ b/R/auto-complete.R
@@ -1,8 +1,6 @@
-
# Given a line buffer, return a list of possible auto completions.
# If there is a valid label, then attach the server env to allow for local overrides of functions
auto_complete_r <- function(line, label = NULL, server_env = NULL) {
-
# If the last line includes comments then we don't return any completions.
# It's okay to consider only the last line for comments: Comment detection
# takes into account quotes on the same line, but `quotes = FALSE` in the
@@ -17,18 +15,31 @@ auto_complete_r <- function(line, label = NULL, server_env = NULL) {
# set completion settings
options <- utils::rc.options()
- utils::rc.options(package.suffix = "::",
- funarg.suffix = " = ",
- function.suffix = "(")
+ utils::rc.options(
+ package.suffix = "::",
+ funarg.suffix = " = ",
+ function.suffix = "("
+ )
on.exit(do.call(utils::rc.options, as.list(options)), add = TRUE)
# If and when exercises gain access to files, then we should evaluate this
# code in the exercise dir with `quotes = TRUE` (and sanitize to keep
# filename lookup local to exercise dir)
settings <- utils::rc.settings()
- utils::rc.settings(ops = TRUE, ns = TRUE, args = TRUE, func = FALSE,
- ipck = TRUE, S3 = TRUE, data = TRUE, help = TRUE,
- argdb = TRUE, fuzzy = FALSE, files = FALSE, quotes = FALSE)
+ utils::rc.settings(
+ ops = TRUE,
+ ns = TRUE,
+ args = TRUE,
+ func = FALSE,
+ ipck = TRUE,
+ S3 = TRUE,
+ data = TRUE,
+ help = TRUE,
+ argdb = TRUE,
+ fuzzy = FALSE,
+ files = FALSE,
+ quotes = FALSE
+ )
on.exit(do.call(utils::rc.settings, as.list(settings)), add = TRUE)
# temporarily attach global setup to search path
@@ -55,15 +66,19 @@ auto_complete_r <- function(line, label = NULL, server_env = NULL) {
# detect functions
splat <- strsplit(completions, ":{2,3}")
- fn <- vapply(splat, function(el) {
- n <- length(el)
- envir <- if (n == 1) .GlobalEnv else asNamespace(el[[1]])
- symbol <- if (n == 2) el[[2]] else el[[1]]
- tryCatch(
- is.function(get(symbol, envir = envir)),
- error = function(e) FALSE
- )
- }, logical(1))
+ fn <- vapply(
+ splat,
+ function(el) {
+ n <- length(el)
+ envir <- if (n == 1) .GlobalEnv else asNamespace(el[[1]])
+ symbol <- if (n == 2) el[[2]] else el[[1]]
+ tryCatch(
+ is.function(get(symbol, envir = envir)),
+ error = function(e) FALSE
+ )
+ },
+ logical(1)
+ )
# remove a leading '::', ':::' from autocompletion results, as
# those won't be inserted as expected in Ace
@@ -102,8 +117,12 @@ detect_comment <- function(line = "") {
next
}
in_escape <- FALSE
- if (!identical(char, "#")) next
- if (in_quote) next
+ if (!identical(char, "#")) {
+ next
+ }
+ if (in_quote) {
+ next
+ }
return(TRUE)
}
diff --git a/R/available_tutorials.R b/R/available_tutorials.R
index 8809fa8ab..cf2257649 100644
--- a/R/available_tutorials.R
+++ b/R/available_tutorials.R
@@ -1,4 +1,3 @@
-
#' List available tutorials
#'
#' List the tutorials that are currently available via installed R packages.
@@ -15,7 +14,6 @@
#'
#' @export
available_tutorials <- function(package = NULL) {
-
info <-
if (is.null(package)) {
all_available_tutorials()
@@ -45,7 +43,6 @@ available_tutorials <- function(package = NULL) {
#' "yaml_front_matter": list column of all yaml header info; [list()]
#' @noRd
available_tutorials_for_package <- function(package) {
-
an_error <- function(...) {
list(
tutorials = NULL,
@@ -53,22 +50,32 @@ available_tutorials_for_package <- function(package) {
)
}
- if (!file.exists(
- system.file(package = package)
- )) {
+ if (
+ !file.exists(
+ system.file(package = package)
+ )
+ ) {
return(an_error(
- "No package found with name: \"", package, "\""
+ "No package found with name: \"",
+ package,
+ "\""
))
}
tutorials_dir <- system.file("tutorials", package = package)
if (!file.exists(tutorials_dir)) {
return(an_error(
- "No tutorials found for package: \"", package, "\""
+ "No tutorials found for package: \"",
+ package,
+ "\""
))
}
- tutorial_folders <- list.dirs(tutorials_dir, full.names = TRUE, recursive = FALSE)
+ tutorial_folders <- list.dirs(
+ tutorials_dir,
+ full.names = TRUE,
+ recursive = FALSE
+ )
names(tutorial_folders) <- basename(tutorial_folders)
rmd_info <- lapply(tutorial_folders, function(tut_dir) {
dir_rmd_file <- run_find_tutorial_rmd(tut_dir)
@@ -83,7 +90,9 @@ available_tutorials_for_package <- function(package) {
title = yaml_front_matter$title %||% NA,
description = yaml_front_matter$description %||% NA,
private = yaml_front_matter$private %||% FALSE,
- package_dependencies = I(list(tutorial_dir_package_dependencies(tut_dir))),
+ package_dependencies = I(list(tutorial_dir_package_dependencies(
+ tut_dir
+ ))),
yaml_front_matter = I(list(yaml_front_matter)),
stringsAsFactors = FALSE,
row.names = FALSE
@@ -93,7 +102,9 @@ available_tutorials_for_package <- function(package) {
has_no_rmd <- vapply(rmd_info, is.null, logical(1))
if (all(has_no_rmd)) {
return(an_error(
- "No tutorial .Rmd files found for package: \"", package, "\""
+ "No tutorial .Rmd files found for package: \"",
+ package,
+ "\""
))
}
@@ -115,7 +126,7 @@ available_tutorials_for_package <- function(package) {
#' @noRd
all_available_tutorials <- function() {
ret <- list()
- all_pkgs <- installed.packages()[,"Package"]
+ all_pkgs <- installed.packages()[, "Package"]
for (pkg in all_pkgs) {
info <- available_tutorials_for_package(pkg)
@@ -136,21 +147,29 @@ all_available_tutorials <- function() {
get_tutorial_path <- function(name, package) {
-
tutorial_path <- system.file("tutorials", name, package = package)
# validate that it's a direcotry
if (!utils::file_test("-d", tutorial_path)) {
tutorials <- available_tutorials(package)
possible_tutorials <- tutorials$name
- msg <- paste0("Tutorial \"", name, "\" was not found in the \"", package, "\" package.")
+ msg <- paste0(
+ "Tutorial \"",
+ name,
+ "\" was not found in the \"",
+ package,
+ "\" package."
+ )
# if any tutorial names are _close_ tell the user
adist_vals <- utils::adist(possible_tutorials, name, ignore.case = TRUE)
if (any(adist_vals <= 3)) {
best_match <- possible_tutorials[which.min(adist_vals)]
msg <- paste0(
- msg, "\n",
- "Did you mean \"", best_match, "\"?"
+ msg,
+ "\n",
+ "Did you mean \"",
+ best_match,
+ "\"?"
)
}
stop.(msg, "\n", format(tutorials))
@@ -188,8 +207,11 @@ format.learnr_available_tutorials <- function(x, ...) {
)
ret <- paste0(
- ret, "\n",
- "* ", pkg, "\n",
+ ret,
+ "\n",
+ "* ",
+ pkg,
+ "\n",
paste0(txts, collapse = "\n")
)
}
diff --git a/R/debug_exercise_checker.R b/R/debug_exercise_checker.R
index fedd30c3d..592dc5d37 100644
--- a/R/debug_exercise_checker.R
+++ b/R/debug_exercise_checker.R
@@ -1,4 +1,3 @@
-
#' An Exercise Checker for Debugging
#'
#' An exercise checker for debugging that renders all of the expected arguments
@@ -23,16 +22,16 @@
#'
#' @keywords internal
debug_exercise_checker <- function(
- label,
- user_code,
- solution_code,
- check_code,
- envir_result,
- evaluate_result,
- envir_prep,
- last_value,
- engine,
- ...
+ label,
+ user_code,
+ solution_code,
+ check_code,
+ envir_result,
+ evaluate_result,
+ envir_prep,
+ last_value,
+ engine,
+ ...
) {
# Use I() around check_code to indicate that we want to evaluate the check code
checker_result <- if (is_AsIs(check_code)) {
@@ -109,16 +108,16 @@ debug_exercise_checker <- function(
location = "replace",
checker_result = checker_result,
checker_args = list(
- label = label,
- user_code = user_code,
- solution_code = solution_code,
- check_code = check_code,
- envir_result = envir_result,
+ label = label,
+ user_code = user_code,
+ solution_code = solution_code,
+ check_code = check_code,
+ envir_result = envir_result,
evaluate_result = evaluate_result,
- envir_prep = envir_prep,
- last_value = last_value,
- engine = engine,
- "..." = list(...)
+ envir_prep = envir_prep,
+ last_value = last_value,
+ engine = engine,
+ "..." = list(...)
)
)
}
diff --git a/R/evaluators.R b/R/evaluators.R
index 6f35cd9aa..10b2feb18 100644
--- a/R/evaluators.R
+++ b/R/evaluators.R
@@ -1,16 +1,16 @@
-
# inline execution evaluator
inline_evaluator <- function(expr, timelimit, ...) {
-
result <- NULL
list(
start = function() {
-
# setTimeLimit -- if the timelimit is exceeeded an error will occur
# during knit which we will catch and format within evaluate_exercise
- setTimeLimit(elapsed=timelimit, transient=TRUE);
- on.exit(setTimeLimit(cpu=Inf, elapsed=Inf, transient=FALSE), add = TRUE);
+ setTimeLimit(elapsed = timelimit, transient = TRUE)
+ on.exit(
+ setTimeLimit(cpu = Inf, elapsed = Inf, transient = FALSE),
+ add = TRUE
+ )
# execute and capture result
result <<- tryCatch(
@@ -34,7 +34,7 @@ inline_evaluator <- function(expr, timelimit, ...) {
}
# forked execution evaluator
-setup_forked_evaluator_factory <- function(max_forked_procs){
+setup_forked_evaluator_factory <- function(max_forked_procs) {
running_exercises <- 0
function(expr, timelimit, ...) {
@@ -63,11 +63,10 @@ setup_forked_evaluator_factory <- function(max_forked_procs){
}
list(
-
start = function() {
self$start_time <<- Sys.time()
- doStart <- function(){
+ doStart <- function() {
if (running_exercises >= max_forked_procs) {
# Then we can't start this job yet.
print("Delaying exercise execution due to forked proc limits")
@@ -79,7 +78,6 @@ setup_forked_evaluator_factory <- function(max_forked_procs){
running_exercises <<- running_exercises + 1
self$job <<- parallel::mcparallel(mc.interactive = FALSE, {
-
# close all connections
closeAllConnections()
@@ -105,7 +103,11 @@ setup_forked_evaluator_factory <- function(max_forked_procs){
}
# attempt to collect the result
- collect <- parallel::mccollect(jobs = self$job, wait = FALSE, timeout = 0.01)
+ collect <- parallel::mccollect(
+ jobs = self$job,
+ wait = FALSE,
+ timeout = 0.01
+ )
# got result
if (!is.null(collect)) {
@@ -120,15 +122,19 @@ setup_forked_evaluator_factory <- function(max_forked_procs){
# check if it's an error and convert it to an html error if it is
if (inherits(self$result, "try-error")) {
- self$result <<- exercise_result_error(self$result, timeout_exceeded = FALSE)
+ self$result <<- exercise_result_error(
+ self$result,
+ timeout_exceeded = FALSE
+ )
}
return(TRUE)
}
# hit timeout
- if (difftime(Sys.time(), self$start_time, units="secs") >= timelimit) {
-
+ if (
+ difftime(Sys.time(), self$start_time, units = "secs") >= timelimit
+ ) {
# call cleanup hook
call_hook("oncleanup", default = default_cleanup)
@@ -151,7 +157,12 @@ setup_forked_evaluator_factory <- function(max_forked_procs){
}
}
-forked_evaluator_factory <- setup_forked_evaluator_factory(max_forked_procs = getOption("tutorial.max.forked.procs", Sys.getenv("TUTORIAL_MAX_FORKED_PROCS", 3)))
+forked_evaluator_factory <- setup_forked_evaluator_factory(
+ max_forked_procs = getOption(
+ "tutorial.max.forked.procs",
+ Sys.getenv("TUTORIAL_MAX_FORKED_PROCS", 3)
+ )
+)
# Maintain for backwards-compatibility with original implementation in which
# forked_evaluator was uncapped
forked_evaluator <- setup_forked_evaluator_factory(max_forked_procs = Inf)
@@ -168,9 +179,12 @@ forked_evaluator <- setup_forked_evaluator_factory(max_forked_procs = Inf)
#' and `session`.
#' @export
external_evaluator <- function(
- endpoint = getOption("tutorial.external.host", Sys.getenv("TUTORIAL_EXTERNAL_EVALUATOR_HOST", NA)),
+ endpoint = getOption(
+ "tutorial.external.host",
+ Sys.getenv("TUTORIAL_EXTERNAL_EVALUATOR_HOST", NA)
+ ),
max_curl_conns = 50
-){
+) {
rlang::check_installed("curl", "to use an external evaluator.")
internal_external_evaluator(endpoint, max_curl_conns)
}
@@ -186,10 +200,12 @@ external_evaluator <- function(
internal_external_evaluator <- function(
endpoint,
max_curl_conns,
- initiate = initiate_external_session){
-
- if (is.na(endpoint)){
- stop("You must specify an endpoint explicitly as a parameter, or via the `tutorial.external.host` option, or the `TUTORIAL_EXTERNAL_EVALUATOR_HOST` environment variable")
+ initiate = initiate_external_session
+) {
+ if (is.na(endpoint)) {
+ stop(
+ "You must specify an endpoint explicitly as a parameter, or via the `tutorial.external.host` option, or the `TUTORIAL_EXTERNAL_EVALUATOR_HOST` environment variable"
+ )
}
# Trim trailing slash
@@ -197,38 +213,61 @@ internal_external_evaluator <- function(
function(expr, timelimit, exercise, session, ...) {
result <- NULL
- pool <- curl::new_pool(total_con = max_curl_conns, host_con = max_curl_conns)
+ pool <- curl::new_pool(
+ total_con = max_curl_conns,
+ host_con = max_curl_conns
+ )
list(
start = function() {
-
# The actual workhorse here -- called once we have a session ID on the external evaluator
- submit_req <- function(sess_id, cookiejar){
+ submit_req <- function(sess_id, cookiejar) {
# Work around a few edge cases on the exercise that don't serialize well
- if (identical(exercise$options$exercise.checker, "NULL")){
+ if (identical(exercise$options$exercise.checker, "NULL")) {
exercise$options$exercise.checker <- c()
}
- json <- jsonlite::toJSON(exercise, auto_unbox = TRUE, null = "null", force = TRUE)
+ json <- jsonlite::toJSON(
+ exercise,
+ auto_unbox = TRUE,
+ null = "null",
+ force = TRUE
+ )
if (
- identical(tolower(Sys.getenv("TUTORIAL_DEBUG_EXTERNAL_EVALUATOR_EVENT_SUBMISSION", "")), "true") ||
- "submission" %in% getOption("tutorial.debug.external_evaluator_event", "")
+ identical(
+ tolower(Sys.getenv(
+ "TUTORIAL_DEBUG_EXTERNAL_EVALUATOR_EVENT_SUBMISSION",
+ ""
+ )),
+ "true"
+ ) ||
+ "submission" %in%
+ getOption("tutorial.debug.external_evaluator_event", "")
) {
- event_trigger(session, "external_evaluator_submission", as.character(json))
+ event_trigger(
+ session,
+ "external_evaluator_submission",
+ as.character(json)
+ )
}
- if (is.null(exercise$options$exercise.timelimit) || exercise$options$exercise.timelimit == 0){
+ if (
+ is.null(exercise$options$exercise.timelimit) ||
+ exercise$options$exercise.timelimit == 0
+ ) {
timeout_s <- 30 * 1000
} else {
timeout_s <- exercise$options$exercise.timelimit * 1000
}
# Create curl request
- handle <- curl::new_handle(customrequest = "POST",
- copypostfields = json,
- # add 15 seconds for application startup
- timeout_ms = timeout_s + 15000,
- cookiefile=cookiejar)
+ handle <- curl::new_handle(
+ customrequest = "POST",
+ copypostfields = json,
+ # add 15 seconds for application startup
+ timeout_ms = timeout_s + 15000,
+ cookiefile = cookiejar
+ )
curl::handle_setheaders(handle, "Content-Type" = "application/json")
url <- paste0(endpoint, "/learnr/", sess_id)
@@ -238,48 +277,66 @@ internal_external_evaluator <- function(
# requests in the pool to resolve.
pending <- TRUE
- done_cb <- function(res){
+ done_cb <- function(res) {
pending <<- FALSE
- tryCatch({
- if (res$status != 200){
+ tryCatch(
+ {
+ if (res$status != 200) {
+ fail_cb(response_to_error(res))
+ return()
+ }
+
+ r <- rawToChar(res$content)
+ if (
+ identical(
+ tolower(Sys.getenv(
+ "TUTORIAL_DEBUG_EXTERNAL_EVALUATOR_EVENT_RESULT",
+ ""
+ )),
+ "true"
+ ) ||
+ "result" %in%
+ getOption("tutorial.debug.external_evaluator_event", "")
+ ) {
+ event_trigger(session, "external_evaluator_result", r)
+ }
+
+ valid_json <- jsonlite::validate(r)
+ if (!valid_json) {
+ stop(attr(valid_json, "err"))
+ }
+
+ result <<- r
+ },
+ error = function(e) {
+ print(e)
fail_cb(response_to_error(res))
- return()
- }
-
- r <- rawToChar(res$content)
- if (
- identical(tolower(Sys.getenv("TUTORIAL_DEBUG_EXTERNAL_EVALUATOR_EVENT_RESULT", "")), "true") ||
- "result" %in% getOption("tutorial.debug.external_evaluator_event", "")
- ) {
- event_trigger(session, "external_evaluator_result", r)
- }
-
- valid_json <- jsonlite::validate(r)
- if (!valid_json) {
- stop(attr(valid_json, "err"))
}
-
- result <<- r
- }, error = function(e){
- print(e)
- fail_cb(response_to_error(res))
- })
+ )
}
- fail_cb <- function(err){
+ fail_cb <- function(err) {
pending <<- FALSE
print("Error submitting external exercise:")
print(err)
- result <<- exercise_result_error("Error submitting external exercise. Please try again later")
+ result <<- exercise_result_error(
+ "Error submitting external exercise. Please try again later"
+ )
}
- curl::curl_fetch_multi(url, handle = handle, done = done_cb, fail = fail_cb, pool = pool)
+ curl::curl_fetch_multi(
+ url,
+ handle = handle,
+ done = done_cb,
+ fail = fail_cb,
+ pool = pool
+ )
- poll <- function(){
+ poll <- function() {
curl::multi_run(timeout = 0, pool = pool)
- if (pending){
+ if (pending) {
later::later(poll, delay = 0.1)
}
}
@@ -287,11 +344,15 @@ internal_external_evaluator <- function(
}
# Initiate a session
- if (is.null(session$userData$.external_evaluator_session_id)){
+ if (is.null(session$userData$.external_evaluator_session_id)) {
session$userData$.external_evaluator_session_id <-
- initiate(pool, paste0(endpoint, "/learnr/"), exercise$global_setup) %>%
- then(onFulfilled = function(extsess){
- session$onSessionEnded(function(){
+ initiate(
+ pool,
+ paste0(endpoint, "/learnr/"),
+ exercise$global_setup
+ ) %>%
+ then(onFulfilled = function(extsess) {
+ session$onSessionEnded(function() {
# Cleanup session cookiefile
# Because of https://github.com/rstudio/shiny/pull/2757, we can't
# trust that the reactive context will be provided here. So just
@@ -302,15 +363,18 @@ internal_external_evaluator <- function(
})
}
- session$userData$.external_evaluator_session_id %>% then(
- onFulfilled = function(extsess){
- submit_req(extsess$id, extsess$cookieFile)
- },
- onRejected = function(err){
- print(err)
- result <<- exercise_result_error("Error initiating session for external requests. Please try again later")
- }
- )
+ session$userData$.external_evaluator_session_id %>%
+ then(
+ onFulfilled = function(extsess) {
+ submit_req(extsess$id, extsess$cookieFile)
+ },
+ onRejected = function(err) {
+ print(err)
+ result <<- exercise_result_error(
+ "Error initiating session for external requests. Please try again later"
+ )
+ }
+ )
},
completed = function() {
@@ -321,18 +385,21 @@ internal_external_evaluator <- function(
if (is_exercise_result(result)) {
return(result)
}
- tryCatch({
- if (length(result) > 1) {
- result <- paste(result, collapse = "\n")
+ tryCatch(
+ {
+ if (length(result) > 1) {
+ result <- paste(result, collapse = "\n")
+ }
+ exercise_result_from_json(result)
+ },
+ error = function(e) {
+ exercise_result_error_internal(
+ exercise = exercise,
+ error = e,
+ task_internal = "converting result from external evaluator into a learnr exercise result"
+ )
}
- exercise_result_from_json(result)
- }, error = function(e) {
- exercise_result_error_internal(
- exercise = exercise,
- error = e,
- task_internal = "converting result from external evaluator into a learnr exercise result"
- )
- })
+ )
}
)
}
@@ -385,23 +452,37 @@ exercise_result_from_json <- function(json) {
#' @importFrom promises promise
#' @importFrom promises %>%
#' @noRd
-initiate_external_session <- function(pool, url, global_setup, retry_count = 0){
- promises::promise(function(resolve, reject){
- json <- jsonlite::toJSON(list(global_setup = global_setup), auto_unbox = TRUE, null = "null")
- handle <- curl::new_handle(customrequest = "POST",
- copypostfields = json)
+initiate_external_session <- function(
+ pool,
+ url,
+ global_setup,
+ retry_count = 0
+) {
+ promises::promise(function(resolve, reject) {
+ json <- jsonlite::toJSON(
+ list(global_setup = global_setup),
+ auto_unbox = TRUE,
+ null = "null"
+ )
+ handle <- curl::new_handle(customrequest = "POST", copypostfields = json)
# Track whether or not the current request is still active.
# We cannot use multi_run()$pending because it waits for ALL pending
# requests in the pool to resolve.
pending <- TRUE
- err_cb <- function(res){
+ err_cb <- function(res) {
pending <<- FALSE
# may just have hit a temporarily overloaded server. Retry
- if (res$status == 503 && retry_count < 2) { # three total tries
- resolve(initiate_external_session(pool, url, global_setup, retry_count+1))
+ if (res$status == 503 && retry_count < 2) {
+ # three total tries
+ resolve(initiate_external_session(
+ pool,
+ url,
+ global_setup,
+ retry_count + 1
+ ))
return()
} else {
# invoke the given error callback
@@ -410,26 +491,29 @@ initiate_external_session <- function(pool, url, global_setup, retry_count = 0){
}
}
- done_cb <- function(res){
+ done_cb <- function(res) {
pending <<- FALSE
id <- NULL
failed <- FALSE
- if (res$status != 200){
+ if (res$status != 200) {
reject(response_to_error(res))
return()
}
- tryCatch({
- r <- rawToChar(res$content)
- p <- jsonlite::fromJSON(r)
- id <- p$id
- }, error = function(e) {
- print(e)
- reject(response_to_error(res))
- return()
- })
+ tryCatch(
+ {
+ r <- rawToChar(res$content)
+ p <- jsonlite::fromJSON(r)
+ id <- p$id
+ },
+ error = function(e) {
+ print(e)
+ reject(response_to_error(res))
+ return()
+ }
+ )
cookies <- curl::handle_cookies(handle)
cookieFile <- tempfile("cookies")
@@ -437,11 +521,17 @@ initiate_external_session <- function(pool, url, global_setup, retry_count = 0){
resolve(list(id = id, cookieFile = cookieFile))
}
- curl::curl_fetch_multi(url, handle = handle, done = done_cb, fail = reject, pool = pool)
+ curl::curl_fetch_multi(
+ url,
+ handle = handle,
+ done = done_cb,
+ fail = reject,
+ pool = pool
+ )
- poll <- function(){
+ poll <- function() {
curl::multi_run(timeout = 0, pool = pool)
- if (pending){
+ if (pending) {
later::later(poll, delay = 0.1)
}
}
@@ -449,14 +539,14 @@ initiate_external_session <- function(pool, url, global_setup, retry_count = 0){
})
}
-response_to_error <- function(res){
+response_to_error <- function(res) {
headers <- res$headers
- if (is.raw(headers)){
+ if (is.raw(headers)) {
headers <- rawToChar(headers)
}
content <- res$content
- if (is.raw(content)){
+ if (is.raw(content)) {
content <- rawToChar(content)
}
@@ -484,9 +574,18 @@ response_to_error <- function(res){
# So we settled on this approach -- persisting the cookies off the connection
# ourselves in a format that can be read in by curl using the COOKIEFILE option.
#' @importFrom utils write.table
-write_cookies <- function(cookies, cookieFile){
+write_cookies <- function(cookies, cookieFile) {
cookies$expiration <- as.numeric(cookies$expiration)
- cookies$expiration[is.infinite(cookies$expiration) | is.na(cookies$expiration)] <- 0
+ cookies$expiration[
+ is.infinite(cookies$expiration) | is.na(cookies$expiration)
+ ] <- 0
cookies$expiration <- as.integer(cookies$expiration)
- write.table(cookies, cookieFile, row.names=FALSE, col.names=FALSE, sep="\t", quote = FALSE)
+ write.table(
+ cookies,
+ cookieFile,
+ row.names = FALSE,
+ col.names = FALSE,
+ sep = "\t",
+ quote = FALSE
+ )
}
diff --git a/R/events.R b/R/events.R
index bfbec6799..02e0b57f4 100644
--- a/R/events.R
+++ b/R/events.R
@@ -26,10 +26,13 @@ event_handlers <- new.env(parent = emptyenv())
#'
#' @export
event_register_handler <- function(event, callback) {
- if (!is.function(callback) ||
- !identical(names(formals(callback)), c("session", "event", "data")))
- {
- stop("`callback` must be a function that takes three arguments, `session`, `event`, and `data`.")
+ if (
+ !is.function(callback) ||
+ !identical(names(formals(callback)), c("session", "event", "data"))
+ ) {
+ stop(
+ "`callback` must be a function that takes three arguments, `session`, `event`, and `data`."
+ )
}
if (is.null(event_handlers[[event]])) {
@@ -77,9 +80,10 @@ create_event_handler_remover <- function(event, id) {
# Remove an event handler.
event_remove_handler <- function(event, id) {
- if (is.null(event_handlers[[event]]) ||
- is.null(event_handlers[[event]][[id]]))
- {
+ if (
+ is.null(event_handlers[[event]]) ||
+ is.null(event_handlers[[event]][[id]])
+ ) {
return(invisible(FALSE))
}
diff --git a/R/events_default.R b/R/events_default.R
index 1b0b29297..45e9424cb 100644
--- a/R/events_default.R
+++ b/R/events_default.R
@@ -1,20 +1,23 @@
-
broadcast_progress_event_to_client <- function(session, event, data) {
- session$sendCustomMessage("tutorial.progress_event", list(
- event = event,
- data = data
- ))
+ session$sendCustomMessage(
+ "tutorial.progress_event",
+ list(
+ event = event,
+ data = data
+ )
+ )
}
broadcast_question_event_to_client <- function(session, label, answer) {
- broadcast_progress_event_to_client(session = session,
- event = "question_submission",
- data = list(label = label, answer = answer))
+ broadcast_progress_event_to_client(
+ session = session,
+ event = "question_submission",
+ data = list(label = label, answer = answer)
+ )
}
register_default_event_handlers <- function() {
-
event_register_handler(
"session_start",
function(session, event, data) {
@@ -82,16 +85,16 @@ register_default_event_handlers <- function() {
# notify client side listeners
broadcast_question_event_to_client(
session = session,
- label = data$label,
- answer = data$answer
+ label = data$label,
+ answer = data$answer
)
# store submission for later replay
save_question_submission(
- session = session,
- label = data$label,
+ session = session,
+ label = data$label,
question = data$question,
- answer = data$answer
+ answer = data$answer
)
}
)
@@ -106,11 +109,10 @@ register_default_event_handlers <- function() {
list(label = data$label, answer = NULL)
)
-
# store submission for later replay
save_reset_question_submission(
- session = session,
- label = data$label,
+ session = session,
+ label = data$label,
question = data$question
)
}
@@ -131,7 +133,6 @@ register_default_event_handlers <- function() {
}
)
-
event_register_handler(
"exercise_result",
function(session, event, data) {
@@ -144,29 +145,33 @@ register_default_event_handlers <- function() {
# 1. Some code is submitted
# 2. A check is not required OR the submission was checked
# (correctness does not affect completion)
- completed <- nzchar(trimws(data$code)) && (!requires_check || data$checked)
+ completed <- nzchar(trimws(data$code)) &&
+ (!requires_check || data$checked)
# notify client side listeners
broadcast_progress_event_to_client(
session = session,
event = "exercise_submission",
- data = list(label = data$label, correct = correct, completed = completed)
+ data = list(
+ label = data$label,
+ correct = correct,
+ completed = completed
+ )
)
# save submission for later replay
save_exercise_submission(
- session = session,
- label = data$label,
- code = data$code,
- output = data$output,
+ session = session,
+ label = data$label,
+ code = data$code,
+ output = data$output,
error_message = data$error_message,
- checked = data$checked,
- feedback = data$feedback
+ checked = data$checked,
+ feedback = data$feedback
)
}
)
-
event_register_handler(
"video_progress",
function(session, event, data) {
diff --git a/R/events_record.R b/R/events_record.R
index 78e18920e..8a8696333 100644
--- a/R/events_record.R
+++ b/R/events_record.R
@@ -1,11 +1,13 @@
record_event <- function(session, event, data) {
recorder <- getOption("tutorial.event_recorder", default = NULL)
if (!is.null(recorder)) {
- recorder(tutorial_id = read_request(session, "tutorial.tutorial_id"),
- tutorial_version = read_request(session, "tutorial.tutorial_version"),
- user_id = read_request(session, "tutorial.user_id"),
- event = event,
- data = data)
+ recorder(
+ tutorial_id = read_request(session, "tutorial.tutorial_id"),
+ tutorial_version = read_request(session, "tutorial.tutorial_version"),
+ user_id = read_request(session, "tutorial.user_id"),
+ event = event,
+ data = data
+ )
}
invisible(NULL)
}
@@ -20,6 +22,10 @@ debug_event_recorder <- function(
) {
cat(tutorial_id, " (", tutorial_version, "): ", user_id, "\n", sep = "")
cat("event: ", event, "\n", sep = "")
- if (is.character(data)) cat(data) else utils::str(data)
+ if (is.character(data)) {
+ cat(data)
+ } else {
+ utils::str(data)
+ }
cat("\n")
}
diff --git a/R/exercise.R b/R/exercise.R
index fbf280ffc..ee97ade8b 100644
--- a/R/exercise.R
+++ b/R/exercise.R
@@ -11,17 +11,22 @@ cache_complete_exercise <- function(exercise) {
get_opt_quick_restore <- function() {
env <- Sys.getenv("TUTORIAL_QUICK_RESTORE", NA)
- if (!is.na(env)) return(env)
+ if (!is.na(env)) {
+ return(env)
+ }
opt <- getOption("tutorial.quick_restore", NA)
- if (isTRUE(opt)) return("1")
- if (isFALSE(opt)) return("0")
+ if (isTRUE(opt)) {
+ return("1")
+ }
+ if (isFALSE(opt)) {
+ return("0")
+ }
if (!is.na(opt)) as.character(opt) else "0"
}
# run an exercise and return HTML UI
setup_exercise_handler <- function(exercise_rx, session) {
-
# get the environment where shared setup and data is located. one environment up
# includes all of the shiny housekeeping (e.g. inputs, output, etc.); two
# environments up will be an empty environment
@@ -56,7 +61,10 @@ setup_exercise_handler <- function(exercise_rx, session) {
return()
}
- object <- get_exercise_submission(session = session, label = exercise$label)
+ object <- get_exercise_submission(
+ session = session,
+ label = exercise$label
+ )
if (!is.null(object) && !is.null(object$data$output)) {
# restore user state, but don't report correct
# since the user's code wasn't re-evaluated
@@ -72,8 +80,11 @@ setup_exercise_handler <- function(exercise_rx, session) {
# ensure that html dependencies only reference package files
dependencies <- htmltools::htmlDependencies(output)
- if (!is.null(dependencies))
- htmltools::htmlDependencies(output) <- filter_dependencies(dependencies)
+ if (!is.null(dependencies)) {
+ htmltools::htmlDependencies(output) <- filter_dependencies(
+ dependencies
+ )
+ }
# assign to rv and return
rv$result <- output
@@ -88,15 +99,22 @@ setup_exercise_handler <- function(exercise_rx, session) {
}
# get exercise evaluator factory function (allow replacement via global option)
- evaluator_factory <- getOption("tutorial.exercise.evaluator", default = NULL)
+ evaluator_factory <- getOption(
+ "tutorial.exercise.evaluator",
+ default = NULL
+ )
if (is.null(evaluator_factory)) {
- remote_host <- getOption("tutorial.external.host", Sys.getenv("TUTORIAL_EXTERNAL_EVALUATOR_HOST", NA))
- if (!is.na(remote_host)){
+ remote_host <- getOption(
+ "tutorial.external.host",
+ Sys.getenv("TUTORIAL_EXTERNAL_EVALUATOR_HOST", NA)
+ )
+ if (!is.na(remote_host)) {
evaluator_factory <- external_evaluator(remote_host)
- } else if (!is_windows() && !is_mac())
+ } else if (!is_windows() && !is_mac()) {
evaluator_factory <- forked_evaluator_factory
- else
+ } else {
evaluator_factory <- inline_evaluator
+ }
}
# retrieve exercise cache information:
@@ -118,8 +136,9 @@ setup_exercise_handler <- function(exercise_rx, session) {
# get timelimit option (either from chunk option or from global option)
timelimit <- exercise$options$exercise.timelimit
- if (is.null(timelimit))
+ if (is.null(timelimit)) {
timelimit <- getOption("tutorial.exercise.timelimit", default = 30)
+ }
# placeholder for current learnr version to deal with exercise structure differences
# with other learnr versions
@@ -133,8 +152,12 @@ setup_exercise_handler <- function(exercise_rx, session) {
}
# create exercise evaluator
- evaluator <- evaluator_factory(evaluate_exercise(exercise, envir),
- timelimit, exercise, session)
+ evaluator <- evaluator_factory(
+ evaluate_exercise(exercise, envir),
+ timelimit,
+ exercise,
+ session
+ )
# Create exercise ID to map the associated events.
ex_id <- random_id("lnr_ex")
@@ -144,9 +167,9 @@ setup_exercise_handler <- function(exercise_rx, session) {
session,
"exercise_submitted",
data = list(
- label = exercise$label,
- id = ex_id,
- code = exercise$code,
+ label = exercise$label,
+ id = ex_id,
+ code = exercise$code,
restore = exercise$restore
)
)
@@ -158,9 +181,7 @@ setup_exercise_handler <- function(exercise_rx, session) {
# poll for completion
o <- observe({
-
if (evaluator$completed()) {
-
# get the result
result <- evaluator$result()
@@ -169,20 +190,26 @@ setup_exercise_handler <- function(exercise_rx, session) {
session,
"exercise_result",
data = list(
- label = exercise$label,
- id = ex_id,
- code = exercise$code,
- output = result$html_output,
+ label = exercise$label,
+ id = ex_id,
+ code = exercise$code,
+ output = result$html_output,
timeout_exceeded = result$timeout_exceeded,
- time_elapsed = as.numeric(difftime(Sys.time(), start, units="secs")),
- error_message = result$error_message,
- checked = check_was_requested,
- feedback = result$feedback
+ time_elapsed = as.numeric(difftime(
+ Sys.time(),
+ start,
+ units = "secs"
+ )),
+ error_message = result$error_message,
+ checked = check_was_requested,
+ feedback = result$feedback
)
)
# assign reactive result to be sent to the UI
- rv$triggered <- isolate({ rv$triggered + 1})
+ rv$triggered <- isolate({
+ rv$triggered + 1
+ })
rv$result <- exercise_result_as_html(result)
isolate({
@@ -199,10 +226,8 @@ setup_exercise_handler <- function(exercise_rx, session) {
}
})
-
# destroy the observer
o$destroy()
-
} else {
invalidateLater(100, session)
}
@@ -255,7 +280,9 @@ upgrade_exercise <- function(exercise, require_items = NULL) {
}
stop(
- "Received an exercise with ", v, ", most likely because it's ",
+ "Received an exercise with ",
+ v,
+ ", most likely because it's ",
"from an older version of {learnr}. This is {learnr} version ",
utils::packageVersion("learnr")
)
@@ -304,18 +331,28 @@ upgrade_exercise <- function(exercise, require_items = NULL) {
# this exercise will work out. Or at least won't result in surfacing an
# internal learnr error as the culprit.
warning(
- "Expected exercise version ", current_version, ", but received version ",
- exercise$version, ". This version of {learnr} is likely able to evaluate ",
- "version ", exercise$version, " exercises, but there may be differences. ",
+ "Expected exercise version ",
+ current_version,
+ ", but received version ",
+ exercise$version,
+ ". This version of {learnr} is likely able to evaluate ",
+ "version ",
+ exercise$version,
+ " exercises, but there may be differences. ",
"Please upgrade {learnr}; this version is ",
- utils::packageVersion("learnr"), "."
+ utils::packageVersion("learnr"),
+ "."
)
return(exercise)
}
stop(
- "Expected exercise version ", current_version, ", but received version ",
- exercise$version, ". These versions are incompatible. ", exercise_problem
+ "Expected exercise version ",
+ current_version,
+ ", but received version ",
+ exercise$version,
+ ". These versions are incompatible. ",
+ exercise_problem
)
}
@@ -327,7 +364,10 @@ validate_exercise <- function(exercise, require_items = NULL) {
required_names <- c("code", "label", "options", "chunks", require_items)
missing_names <- setdiff(required_names, names(exercise))
if (length(missing_names)) {
- return(paste("Missing exercise items:", paste(missing_names, collapse = ", ")))
+ return(paste(
+ "Missing exercise items:",
+ paste(missing_names, collapse = ", ")
+ ))
}
NULL
@@ -346,7 +386,15 @@ standardize_code <- function(code) {
}
standardize_exercise_code <- function(exercise) {
- ex_code_items <- c("error_check", "code_check", "check", "code", "global_setup", "solution", "tests")
+ ex_code_items <- c(
+ "error_check",
+ "code_check",
+ "check",
+ "code",
+ "global_setup",
+ "solution",
+ "tests"
+ )
exercise[ex_code_items] <- lapply(exercise[ex_code_items], standardize_code)
exercise
}
@@ -364,9 +412,11 @@ standardize_exercise_code <- function(exercise) {
# evaluators, if they choose to use this function, might want to include the
# global setup.
evaluate_exercise <- function(
- exercise, envir, evaluate_global_setup = FALSE, data_dir = NULL
+ exercise,
+ envir,
+ evaluate_global_setup = FALSE,
+ data_dir = NULL
) {
-
# Exercise Prep and Standardization ---------------------------------------
# Protect global options and environment vars from permanent modification
local_restore_options_and_envvars()
@@ -392,17 +442,20 @@ evaluate_exercise <- function(
# Evaluate Global Setup ---------------------------------------------------
if (evaluate_global_setup) {
res_global <-
- tryCatch({
- eval(parse(text = exercise$global_setup), envir = envir)
- NULL
- }, error = function(err) {
- exercise_result_error_internal(
- exercise,
- err,
- task_internal = "evaluating the global setup",
- task_external = "setting up the tutorial"
- )
- })
+ tryCatch(
+ {
+ eval(parse(text = exercise$global_setup), envir = envir)
+ NULL
+ },
+ error = function(err) {
+ exercise_result_error_internal(
+ exercise,
+ err,
+ task_internal = "evaluating the global setup",
+ task_external = "setting up the tutorial"
+ )
+ }
+ )
if (is_exercise_result(res_global)) {
return(res_global)
@@ -470,15 +523,23 @@ evaluate_exercise <- function(
if (!inherits(err_render, "learnr_render_exercise_error")) {
# render exercise errors are expected, but something really went wrong
return(
- exercise_result_error_internal(exercise, err_render, "evaluating your exercise", "inside render_exercise()")
+ exercise_result_error_internal(
+ exercise,
+ err_render,
+ "evaluating your exercise",
+ "inside render_exercise()"
+ )
)
}
error_feedback <- NULL
error_check_code <- exercise$error_check
- error_should_check <- nzchar(exercise$check) || nzchar(exercise$code_check)
+ error_should_check <- nzchar(exercise$check) ||
+ nzchar(exercise$code_check)
if (error_should_check && !nzchar(error_check_code)) {
# If there is no locally defined error check code, look for globally defined error check option
- error_check_code <- standardize_code(exercise$options$exercise.error.check.code)
+ error_check_code <- standardize_code(
+ exercise$options$exercise.error.check.code
+ )
}
if (nzchar(error_check_code)) {
# Error check -------------------------------------------------------
@@ -536,9 +597,14 @@ evaluate_exercise <- function(
try_checker <- function(
- exercise, stage,
- name = "exercise.checker", check_code = NULL, envir_result = NULL,
- evaluate_result = NULL, envir_prep, last_value = NULL,
+ exercise,
+ stage,
+ name = "exercise.checker",
+ check_code = NULL,
+ envir_result = NULL,
+ evaluate_result = NULL,
+ envir_prep,
+ last_value = NULL,
engine = exercise$engine
) {
checker_func <- tryCatch(
@@ -576,7 +642,8 @@ try_checker <- function(
} else {
msg <- sprintf(
"Either add ... or the following arguments to the '%s' function: '%s'",
- name, paste(missing_args, collapse = "', '")
+ name,
+ paste(missing_args, collapse = "', '")
)
message(msg)
rlang::return_from(rlang::caller_env(), exercise_result_error(msg))
@@ -612,8 +679,13 @@ get_checker_func <- function(exercise, name, envir) {
if (is.function(checker)) {
environment(checker) <- envir
return(checker)
- } else if(!is.null(checker)) {
- warning("Ignoring the ", name, " option since it isn't a function", call. = FALSE)
+ } else if (!is.null(checker)) {
+ warning(
+ "Ignoring the ",
+ name,
+ " option since it isn't a function",
+ call. = FALSE
+ )
}
function(...) NULL
}
@@ -646,7 +718,10 @@ render_exercise <- function(exercise, envir) {
if (isTRUE(user)) {
knitr_options$knit_hooks$evaluate <- function(
- code, envir, ..., output_handler # knitr's output_handler
+ code,
+ envir,
+ ...,
+ output_handler # knitr's output_handler
) {
has_visible_arg <- length(formals(output_handler$value)) > 1
# wrap `output_handler$value` to be able to capture the `last_value`
@@ -667,7 +742,9 @@ render_exercise <- function(exercise, envir) {
}
}
evaluate_result <<- evaluate::evaluate(
- code, envir, ...,
+ code,
+ envir,
+ ...,
output_handler = output_handler
)
evaluate_result
@@ -689,70 +766,75 @@ render_exercise <- function(exercise, envir) {
envir_result <- envir_prep
# First, Rmd to markdown (and exit early if any error)
- output_file <- tryCatch({
- # — Render Exercise Stage: Prep ----
- # TODO: The render stage and everything associated with it should really be
- # named "setup", e.g. `envir_setup`, etc. The stage here is called
- # "prep" to avoid confusion with the current naming.
- render_stage <- "prep"
-
- render_exercise_evaluate_prep(
- exercise = exercise,
- envir_prep = envir_prep,
- output_format_exercise(user = FALSE)
- )
-
- # Create exercise.Rmd after running setup so it isn't accidentally overwritten
- if (file.exists("exercise.Rmd")) {
- warning(
- "Evaluating user code in exercise '", exercise$label, "' created ",
- "'exercise.Rmd'. If the setup code for this exercise creates a file ",
- "with that name, please choose another name.",
- immediate. = TRUE
+ output_file <- tryCatch(
+ {
+ # — Render Exercise Stage: Prep ----
+ # TODO: The render stage and everything associated with it should really be
+ # named "setup", e.g. `envir_setup`, etc. The stage here is called
+ # "prep" to avoid confusion with the current naming.
+ render_stage <- "prep"
+
+ render_exercise_evaluate_prep(
+ exercise = exercise,
+ envir_prep = envir_prep,
+ output_format_exercise(user = FALSE)
)
- }
- # — Render Exercise Stage: User ----
- render_stage <- "user"
- # Copy in a full clone `envir_prep` before running user code in `envir_result`
- # By being a sibling to `envir_prep` (rather than a dependency),
- # alterations to `envir_prep` from eval'ing code in `envir_result`
- # are much more difficult
- envir_result <- duplicate_env(envir_prep)
-
- render_exercise_evaluate_user(
- exercise = exercise,
- envir_result = envir_result,
- output_format_exercise(user = TRUE)
- )
- }, error = function(e) {
- msg <- conditionMessage(e)
- # make the time limit error message a bit more friendly
- pattern <- gettext("reached elapsed time limit", domain = "R")
- if (grepl(pattern, msg, fixed = TRUE)) {
- return(exercise_result_timeout())
- }
+ # Create exercise.Rmd after running setup so it isn't accidentally overwritten
+ if (file.exists("exercise.Rmd")) {
+ warning(
+ "Evaluating user code in exercise '",
+ exercise$label,
+ "' created ",
+ "'exercise.Rmd'. If the setup code for this exercise creates a file ",
+ "with that name, please choose another name.",
+ immediate. = TRUE
+ )
+ }
- if (render_stage == "prep") {
- # errors in setup (prep) code should be returned as internal error results
- return(
- exercise_result_error_internal(
- exercise = exercise,
- error = e,
- task_external = "setting up the exercise",
- task_internal = "rendering exercise setup"
+ # — Render Exercise Stage: User ----
+ render_stage <- "user"
+ # Copy in a full clone `envir_prep` before running user code in `envir_result`
+ # By being a sibling to `envir_prep` (rather than a dependency),
+ # alterations to `envir_prep` from eval'ing code in `envir_result`
+ # are much more difficult
+ envir_result <- duplicate_env(envir_prep)
+
+ render_exercise_evaluate_user(
+ exercise = exercise,
+ envir_result = envir_result,
+ output_format_exercise(user = TRUE)
+ )
+ },
+ error = function(e) {
+ msg <- conditionMessage(e)
+ # make the time limit error message a bit more friendly
+ pattern <- gettext("reached elapsed time limit", domain = "R")
+ if (grepl(pattern, msg, fixed = TRUE)) {
+ return(exercise_result_timeout())
+ }
+
+ if (render_stage == "prep") {
+ # errors in setup (prep) code should be returned as internal error results
+ return(
+ exercise_result_error_internal(
+ exercise = exercise,
+ error = e,
+ task_external = "setting up the exercise",
+ task_internal = "rendering exercise setup"
+ )
)
+ }
+
+ rlang::abort(
+ class = "learnr_render_exercise_error",
+ envir_result = envir_result,
+ evaluate_result = evaluate_result,
+ envir_prep = envir_prep,
+ parent = e
)
}
-
- rlang::abort(
- class = "learnr_render_exercise_error",
- envir_result = envir_result,
- evaluate_result = evaluate_result,
- envir_prep = envir_prep,
- parent = e
- )
- })
+ )
if (is_exercise_result(output_file)) {
# this only happens when the render result is a timeout error or setup error
@@ -762,8 +844,11 @@ render_exercise <- function(exercise, envir) {
# Render markdown to HTML
dependencies <- filter_dependencies(attr(output_file, "knit_meta"))
output_file <- rmarkdown::render(
- input = output_file, output_format = output_format_exercise(user = TRUE),
- envir = envir_result, quiet = TRUE, clean = FALSE
+ input = output_file,
+ output_format = output_format_exercise(user = TRUE),
+ envir = envir_result,
+ quiet = TRUE,
+ clean = FALSE
)
output <- readLines(output_file, warn = FALSE, encoding = "UTF-8")
html_output <- htmltools::attachDependencies(
@@ -771,10 +856,13 @@ render_exercise <- function(exercise, envir) {
dependencies
)
- if (!last_value_is_visible && isTRUE(exercise$options$exercise.warn_invisible)) {
+ if (
+ !last_value_is_visible && isTRUE(exercise$options$exercise.warn_invisible)
+ ) {
invisible_feedback <- list(
message = "The submitted code didn't produce a visible value, so exercise checking may not work correctly.",
- type = "warning", correct = FALSE
+ type = "warning",
+ correct = FALSE
)
html_output <- htmltools::tagList(
feedback_as_html(invisible_feedback),
@@ -815,7 +903,11 @@ render_exercise_evaluate_prep <- function(exercise, envir_prep, output_format) {
}
}
-render_exercise_evaluate_user <- function(exercise, envir_result, output_format) {
+render_exercise_evaluate_user <- function(
+ exercise,
+ envir_result,
+ output_format
+) {
withr::defer(render_exercise_post_stage_hook(exercise, "user", envir_result))
rmd_src_user <- render_exercise_rmd_user(exercise)
@@ -864,19 +956,26 @@ exercise_code_chunks_user <- function(exercise) {
}
exercise_code_chunks <- function(chunks, engine = "r") {
- vapply(chunks, function(chunk) {
- opts <- chunk$opts[setdiff(names(chunk$opts), "label")]
- opts <- paste(names(opts), unname(opts), sep = "=")
- chunk_engine <- chunk$engine %||% engine %||% "r"
- chunk_opts <- paste0(c(dput_to_string(chunk$label), opts), collapse = ", ")
- paste(
- sep = "\n",
- # we quote the label to ensure that it is treated as a label and not a symbol for instance
- sprintf("```{%s %s}", chunk_engine, chunk_opts),
- paste0(chunk$code, collapse = "\n"),
- "```"
- )
- }, character(1))
+ vapply(
+ chunks,
+ function(chunk) {
+ opts <- chunk$opts[setdiff(names(chunk$opts), "label")]
+ opts <- paste(names(opts), unname(opts), sep = "=")
+ chunk_engine <- chunk$engine %||% engine %||% "r"
+ chunk_opts <- paste0(
+ c(dput_to_string(chunk$label), opts),
+ collapse = ", "
+ )
+ paste(
+ sep = "\n",
+ # we quote the label to ensure that it is treated as a label and not a symbol for instance
+ sprintf("```{%s %s}", chunk_engine, chunk_opts),
+ paste0(chunk$code, collapse = "\n"),
+ "```"
+ )
+ },
+ character(1)
+ )
}
exercise_get_blanks_pattern <- function(exercise) {
@@ -940,14 +1039,23 @@ exercise_check_code_for_blanks <- function(exercise) {
key = "text.pleasereplaceblank",
opts = list(
count = length(blanks),
- blank = i18n_combine_words(unique(blanks), before = "", after = ""),
+ blank = i18n_combine_words(
+ unique(blanks),
+ before = "",
+ after = ""
+ ),
interpolation = list(escapeValue = FALSE)
)
)
)
exercise_result(
- list(message = HTML(msg), correct = FALSE, location = "prepend", type = "error")
+ list(
+ message = HTML(msg),
+ correct = FALSE,
+ location = "prepend",
+ type = "error"
+ )
)
}
@@ -1023,7 +1131,13 @@ exercise_check_unparsable_unicode <- function(exercise, error_message) {
names(replacement_pattern) <- c(single_quote_pattern, double_quote_pattern)
return(
- unparsable_unicode_message("unparsablequotes", code, line, quote_pattern, replacement_pattern)
+ unparsable_unicode_message(
+ "unparsablequotes",
+ code,
+ line,
+ quote_pattern,
+ replacement_pattern
+ )
)
}
@@ -1042,7 +1156,13 @@ exercise_check_unparsable_unicode <- function(exercise, error_message) {
names(replacement_pattern) <- dash_pattern
return(
- unparsable_unicode_message("unparsableunicodesuggestion", code, line, dash_pattern, replacement_pattern)
+ unparsable_unicode_message(
+ "unparsableunicodesuggestion",
+ code,
+ line,
+ dash_pattern,
+ replacement_pattern
+ )
)
}
@@ -1050,12 +1170,21 @@ exercise_check_unparsable_unicode <- function(exercise, error_message) {
# Regex searches for any codepoints not in the ASCII range (00-7F)
non_ascii_pattern <- "[^\u01-\u7f]"
return(
- unparsable_unicode_message("unparsableunicode", code, line, non_ascii_pattern)
+ unparsable_unicode_message(
+ "unparsableunicode",
+ code,
+ line,
+ non_ascii_pattern
+ )
)
}
unparsable_unicode_message <- function(
- i18n_key, code, line, pattern, replacement_pattern = NULL
+ i18n_key,
+ code,
+ line,
+ pattern,
+ replacement_pattern = NULL
) {
code <- unlist(strsplit(code, "\n"))[[line]]
@@ -1111,7 +1240,12 @@ exercise_result_timeout <- function() {
# @param timeout_exceeded represents whether or not the error was triggered
# because the exercise exceeded the timeout. Use NA if unknown
-exercise_result_error <- function(error_message, feedback = NULL, timeout_exceeded = NA, style = "code") {
+exercise_result_error <- function(
+ error_message,
+ feedback = NULL,
+ timeout_exceeded = NA,
+ style = "code"
+) {
exercise_result(
feedback = feedback,
timeout_exceeded = timeout_exceeded,
@@ -1126,8 +1260,14 @@ exercise_result_error_internal <- function(
task_external = "",
task_internal = task_external
) {
- task_external <- paste0(if (nzchar(task_external %||% "")) " while ", task_external)
- task_internal <- paste0(if (nzchar(task_internal %||% "")) " while ", task_internal)
+ task_external <- paste0(
+ if (nzchar(task_external %||% "")) " while ",
+ task_external
+ )
+ task_internal <- paste0(
+ if (nzchar(task_internal %||% "")) " while ",
+ task_internal
+ )
msg_internal <- sprintf(
"An error occurred%s for exercise '%s'",
@@ -1164,7 +1304,11 @@ exercise_result <- function(
feedback$html <- feedback_as_html(feedback)
}
- if (!inherits(html_output, "html") && is.character(html_output) && any(nzchar(html_output))) {
+ if (
+ !inherits(html_output, "html") &&
+ is.character(html_output) &&
+ any(nzchar(html_output))
+ ) {
html_output <- htmltools::HTML(html_output)
} else if (length(html_output) == 0) {
html_output <- NULL
@@ -1222,9 +1366,11 @@ filter_dependencies <- function(dependencies) {
} else if (!is.null(dependency$package)) {
TRUE
} else {
- ! is.null(tryCatch(
- rprojroot::find_root(rprojroot::is_r_package,
- path = dependency$src$file),
+ !is.null(tryCatch(
+ rprojroot::find_root(
+ rprojroot::is_r_package,
+ path = dependency$src$file
+ ),
error = function(e) NULL
))
}
@@ -1259,7 +1405,6 @@ render_exercise_prepare.default <- function(exercise, ...) {
}
exercise$chunks <- lapply(exercise[["chunks"]], function(chunk) {
-
if (identical(chunk[["label"]], exercise[["label"]])) {
# Exercise Chunk ----
chunk[["opts"]] <- discard_forced_opts(chunk[["opts"]])
@@ -1269,8 +1414,13 @@ render_exercise_prepare.default <- function(exercise, ...) {
inherited = I(exercise[["opts_chunk"]])
)
# keep only unique options that we over-rode when prepping specific ex type (e.g. sql)
- different_ex_opt <- function(opt, name) !identical(opt, exercise[["opts_chunk"]][[name]])
- chunk[["opts"]] <- chunk[["opts"]][imap_lgl(chunk[["opts"]], different_ex_opt)]
+ different_ex_opt <- function(opt, name) {
+ !identical(opt, exercise[["opts_chunk"]][[name]])
+ }
+ chunk[["opts"]] <- chunk[["opts"]][imap_lgl(
+ chunk[["opts"]],
+ different_ex_opt
+ )]
# move user submission code into the exercise chunk
chunk[["code"]] <- exercise[["code"]]
} else {
@@ -1341,7 +1491,7 @@ merge_chunk_options <- function(
option_names <- unique(c(names(chunk), names(inherited), names(forced)))
opts <- lapply(option_names, function(option_name) {
# first we want manually set options, then user's, then exercise
- forced[[option_name]] %||%
+ forced[[option_name]] %||%
chunk[[option_name]] %||%
inherited[[option_name]]
})
@@ -1376,7 +1526,12 @@ render_exercise_rmd_user <- function(exercise, ...) {
#' @export
render_exercise_rmd_user.default <- function(exercise, ...) {
c(
- readLines(system.file("internals", "templates", "exercise-setup.Rmd", package = "learnr")),
+ readLines(system.file(
+ "internals",
+ "templates",
+ "exercise-setup.Rmd",
+ package = "learnr"
+ )),
"",
exercise_code_chunks_user(exercise)
)
@@ -1429,7 +1584,12 @@ render_exercise_post_stage_hook.default <- function(exercise, ...) {
}
#' @export
-render_exercise_post_stage_hook.python <- function(exercise, stage, envir, ...) {
+render_exercise_post_stage_hook.python <- function(
+ exercise,
+ stage,
+ envir,
+ ...
+) {
# Add copy of python environment into the prep/result environment
assign(".__py__", py_copy_global_env(), envir = envir)
invisible()
@@ -1482,7 +1642,11 @@ render_exercise_result.sql <- function(
if (exists("___sql_result", envir = envir_result)) {
if (!is.null(exercise[["options"]][["output.var"]])) {
# the author expected the sql results in a specific variable
- assign(exercise[["options"]][["output.var"]], last_value, envir = envir_result)
+ assign(
+ exercise[["options"]][["output.var"]],
+ last_value,
+ envir = envir_result
+ )
}
rm("___sql_result", envir = envir_result)
}
@@ -1539,15 +1703,15 @@ local_restore_envvars <- function(.local_envir = parent.frame()) {
}
restore_options <- function(old) {
- current <- options()
- nulls <- setdiff(names(current), names(old))
+ current <- options()
+ nulls <- setdiff(names(current), names(old))
old[nulls] <- list(NULL)
options(old)
}
restore_envvars <- function(old) {
current <- Sys.getenv()
- nulls <- setdiff(names(current), names(old))
+ nulls <- setdiff(names(current), names(old))
Sys.unsetenv(nulls)
do.call(Sys.setenv, as.list(old))
}
@@ -1555,11 +1719,19 @@ restore_envvars <- function(old) {
# Print Methods -----------------------------------------------------------
#' @export
-format.tutorial_exercise <- function (x, ..., setup_chunk_only = FALSE) {
+format.tutorial_exercise <- function(x, ..., setup_chunk_only = FALSE) {
label <- x$label
if (!isTRUE(setup_chunk_only)) {
- for (chunk in c("solution", "code_check", "check", "error_check", "tests")) {
- if (is.null(x[[chunk]]) || !nzchar(x[[chunk]])) next
+ for (chunk in c(
+ "solution",
+ "code_check",
+ "check",
+ "error_check",
+ "tests"
+ )) {
+ if (is.null(x[[chunk]]) || !nzchar(x[[chunk]])) {
+ next
+ }
support_chunk <- mock_chunk(
label = paste0(label, "-", sub("_", "-", chunk)),
code = x[[chunk]],
diff --git a/R/feedback.R b/R/feedback.R
index 6849cea5d..003acdd94 100644
--- a/R/feedback.R
+++ b/R/feedback.R
@@ -13,27 +13,47 @@ feedback_validated <- function(feedback) {
if (!length(feedback)) {
return(feedback)
}
- if (!(is.list(feedback) && all(c("message", "correct") %in% names(feedback)))) {
- stop("Feedback must be a list with 'message' and 'correct' fields", call. = FALSE)
+ if (
+ !(is.list(feedback) && all(c("message", "correct") %in% names(feedback)))
+ ) {
+ stop(
+ "Feedback must be a list with 'message' and 'correct' fields",
+ call. = FALSE
+ )
}
- if (!(is.character(feedback$message) || inherits(feedback$message, c("shiny.tag", "shiny.tag.list")))) {
- stop("The 'message' field of feedback must be a character vector or an htmltools tag or tagList", call. = FALSE)
+ if (
+ !(is.character(feedback$message) ||
+ inherits(feedback$message, c("shiny.tag", "shiny.tag.list")))
+ ) {
+ stop(
+ "The 'message' field of feedback must be a character vector or an htmltools tag or tagList",
+ call. = FALSE
+ )
}
if (!is.logical(feedback$correct)) {
- stop("The 'correct' field of feedback must be a logical (i.e., boolean) value", call. = FALSE)
+ stop(
+ "The 'correct' field of feedback must be a logical (i.e., boolean) value",
+ call. = FALSE
+ )
}
# Fill in type/location defaults and check their value
feedback$type <- feedback$type[1] %||% "auto"
feedback$location <- feedback$location[1] %||% "append"
feedback_types <- c("auto", "success", "info", "warning", "error", "custom")
if (!feedback$type %in% feedback_types) {
- stop("Feedback 'type' field must be one of these values: ",
- paste(feedback_types, collapse = ", "), call. = FALSE)
+ stop(
+ "Feedback 'type' field must be one of these values: ",
+ paste(feedback_types, collapse = ", "),
+ call. = FALSE
+ )
}
feedback_locations <- c("append", "prepend", "replace")
if (!feedback$location %in% feedback_locations) {
- stop("Feedback 'location' field must be one of these values: ",
- paste(feedback_locations, collapse = ", "), call. = FALSE)
+ stop(
+ "Feedback 'location' field must be one of these values: ",
+ paste(feedback_locations, collapse = ", "),
+ call. = FALSE
+ )
}
if (feedback$type %in% "auto") {
feedback$type <- if (feedback$correct) "success" else "error"
diff --git a/R/html-dependencies.R b/R/html-dependencies.R
index e32cb9c8c..d0db1c440 100644
--- a/R/html-dependencies.R
+++ b/R/html-dependencies.R
@@ -1,4 +1,3 @@
-
#' Tutorial HTML dependency
#'
#' HTML dependency for core tutorial JS and CSS. This should be included as a
@@ -25,8 +24,7 @@ html_dependency_src <- function(...) {
r_dir <- utils::getSrcDirectory(html_dependency_src, unique = TRUE)
pkg_dir <- dirname(r_dir)
file.path(pkg_dir, "inst", ...)
- }
- else {
+ } else {
system.file(..., package = "learnr")
}
}
diff --git a/R/html_selector.R b/R/html_selector.R
index c86f8f55d..90f4785e0 100644
--- a/R/html_selector.R
+++ b/R/html_selector.R
@@ -1,7 +1,9 @@
-
# only handles id and classes
as_selector <- function(selector) {
- if (inherits(selector, "shiny_selector") || inherits(selector, "shiny_selector_list")) {
+ if (
+ inherits(selector, "shiny_selector") ||
+ inherits(selector, "shiny_selector_list")
+ ) {
return(selector)
}
@@ -30,12 +32,15 @@ as_selector <- function(selector) {
classes <- str_remove(str_match_all(selector, "\\.([^.]+)"), "^\\.")
- structure(class = "shiny_selector", list(
- element = element,
- id = id,
- classes = classes,
- match_everything = match_everything
- ))
+ structure(
+ class = "shiny_selector",
+ list(
+ element = element,
+ id = id,
+ classes = classes,
+ match_everything = match_everything
+ )
+ )
}
as_selector_list <- function(selector) {
@@ -51,7 +56,11 @@ format.shiny_selector <- function(x, ...) {
if (x$match_everything) {
paste0("* // match everything")
} else {
- paste0(x$element, if (!is.null(x$id)) paste0("#", x$id), paste0(".", x$classes, collapse = ""))
+ paste0(
+ x$element,
+ if (!is.null(x$id)) paste0("#", x$id),
+ paste0(".", x$classes, collapse = "")
+ )
}
}
diff --git a/R/http-handlers.R b/R/http-handlers.R
index bb9ff9eae..e2e1be307 100644
--- a/R/http-handlers.R
+++ b/R/http-handlers.R
@@ -1,5 +1,3 @@
-
-
register_http_handlers <- function(session, metadata) {
session$userData$learnr_state <- reactiveVal("start")
@@ -11,8 +9,7 @@ register_http_handlers <- function(session, metadata) {
state <- new.env(parent = emptyenv())
# initialize handler
- session$registerDataObj("initialize", NULL, function(data, req) {
-
+ session$registerDataObj("initialize", NULL, function(data, req) {
# parameters
location <- json_rpc_input(req)$location
@@ -39,52 +36,62 @@ register_http_handlers <- function(session, metadata) {
})
# restore state handler
- session$registerDataObj("restore_state", NULL, rpc_handler(function(input) {
-
- # forward any client stored objects into our own storage
- if (!is.null(input))
- initialize_objects_from_client(session, input)
-
- # get state objects
- state_objects <- get_all_state_objects(session, exercise_output = FALSE)
-
- # create submissions from state objects
- submissions <- submissions_from_state_objects(state_objects)
-
- # create video progress from state objects
- video_progress <- video_progress_from_state_objects(state_objects)
-
- # create progress events from state objects
- progress_events <- progress_events_from_state_objects(state_objects)
-
- # get client state
- client_state <- get_client_state(session)
-
- session$userData$learnr_state("restored")
-
- # return data
- list(
- client_state = client_state,
- submissions = submissions,
- video_progress = video_progress,
- progress_events = progress_events
- )
- }))
+ session$registerDataObj(
+ "restore_state",
+ NULL,
+ rpc_handler(function(input) {
+ # forward any client stored objects into our own storage
+ if (!is.null(input)) {
+ initialize_objects_from_client(session, input)
+ }
+
+ # get state objects
+ state_objects <- get_all_state_objects(session, exercise_output = FALSE)
+
+ # create submissions from state objects
+ submissions <- submissions_from_state_objects(state_objects)
+
+ # create video progress from state objects
+ video_progress <- video_progress_from_state_objects(state_objects)
+
+ # create progress events from state objects
+ progress_events <- progress_events_from_state_objects(state_objects)
+
+ # get client state
+ client_state <- get_client_state(session)
+
+ session$userData$learnr_state("restored")
+
+ # return data
+ list(
+ client_state = client_state,
+ submissions = submissions,
+ video_progress = video_progress,
+ progress_events = progress_events
+ )
+ })
+ )
# remove state handler
- session$registerDataObj("remove_state", NULL, rpc_handler(function(input) {
- remove_all_objects(session)
- }))
+ session$registerDataObj(
+ "remove_state",
+ NULL,
+ rpc_handler(function(input) {
+ remove_all_objects(session)
+ })
+ )
# event recording
- session$registerDataObj("record_event", NULL, rpc_handler(function(input) {
- # Augment the data with the label
- input$data$label <- input$label
+ session$registerDataObj(
+ "record_event",
+ NULL,
+ rpc_handler(function(input) {
+ # Augment the data with the label
+ input$data$label <- input$label
- record_event(session = session,
- event = input$event,
- data = input$data)
- }))
+ record_event(session = session, event = input$event, data = input$data)
+ })
+ )
# # question submission handler
# session$registerDataObj("question_submission", NULL, rpc_handler(function(input) {
@@ -105,85 +112,97 @@ register_http_handlers <- function(session, metadata) {
# }))
# video progress handler
- session$registerDataObj("video_progress", NULL, rpc_handler(function(input) {
-
- # extract inputs
- video_url <- input$video_url
- time <- input$time
- total_time <- input$total_time
-
- # fire event
- event_trigger(
- session,
- "video_progress",
- data = list(
- video_url = video_url,
- time = time,
- total_time = total_time
+ session$registerDataObj(
+ "video_progress",
+ NULL,
+ rpc_handler(function(input) {
+ # extract inputs
+ video_url <- input$video_url
+ time <- input$time
+ total_time <- input$total_time
+
+ # fire event
+ event_trigger(
+ session,
+ "video_progress",
+ data = list(
+ video_url = video_url,
+ time = time,
+ total_time = total_time
+ )
)
- )
- }))
+ })
+ )
# exercise skipped event
- session$registerDataObj("section_skipped", NULL, rpc_handler(function(input) {
-
- # extract inputs
- sectionId <- input$sectionId
-
- # fire event
- event_trigger(
- session,
- "section_skipped",
- data = list(sectionId = sectionId)
- )
-
- }))
+ session$registerDataObj(
+ "section_skipped",
+ NULL,
+ rpc_handler(function(input) {
+ # extract inputs
+ sectionId <- input$sectionId
+
+ # fire event
+ event_trigger(
+ session,
+ "section_skipped",
+ data = list(sectionId = sectionId)
+ )
+ })
+ )
# client state handler
- session$registerDataObj("set_client_state", NULL, rpc_handler(function(input) {
- save_client_state(session, input)
- }))
+ session$registerDataObj(
+ "set_client_state",
+ NULL,
+ rpc_handler(function(input) {
+ save_client_state(session, input)
+ })
+ )
# help handler
- session$registerDataObj("help", NULL, rpc_handler(function(input) {
-
- }))
+ session$registerDataObj("help", NULL, rpc_handler(function(input) {}))
# setup chunk handler
- session$registerDataObj("initialize_chunk", NULL, rpc_handler(function(input) {
- params <- input
-
- # evaluate setup code to prime environment
- label <- as.character(params$label)
- code <- paste(params$setup_code, collapse = "\n")
-
- # no setup chunk / label? nothing to do
- if (!(nzchar(label) && nzchar(code)))
- return()
-
- # evaluate code in environment to prime
- Encoding(code) <- "UTF-8"
- state[[label]] <- new.env()
- eval(parse(text = code, encoding = "UTF-8"), envir = state[[label]])
-
- }))
+ session$registerDataObj(
+ "initialize_chunk",
+ NULL,
+ rpc_handler(function(input) {
+ params <- input
+
+ # evaluate setup code to prime environment
+ label <- as.character(params$label)
+ code <- paste(params$setup_code, collapse = "\n")
+
+ # no setup chunk / label? nothing to do
+ if (!(nzchar(label) && nzchar(code))) {
+ return()
+ }
+
+ # evaluate code in environment to prime
+ Encoding(code) <- "UTF-8"
+ state[[label]] <- new.env()
+ eval(parse(text = code, encoding = "UTF-8"), envir = state[[label]])
+ })
+ )
# completion handler
- session$registerDataObj("completion", NULL, rpc_handler(function(input) {
-
- # read params
- line <- as.character(input$contents)
- label <- as.character(input$label)
+ session$registerDataObj(
+ "completion",
+ NULL,
+ rpc_handler(function(input) {
+ # read params
+ line <- as.character(input$contents)
+ label <- as.character(input$label)
- Encoding(line) <- "UTF-8"
+ Encoding(line) <- "UTF-8"
- auto_complete_r(line, label, state)
- }))
+ auto_complete_r(line, label, state)
+ })
+ )
# diagnostics handler
- session$registerDataObj("diagnotics", NULL, rpc_handler(function(input) {
-
- }))
+ session$registerDataObj("diagnotics", NULL, rpc_handler(function(input) {}))
# this is a "bat signal" to let the JS side know that the Shiny
# server is ready to handle http requests
@@ -194,9 +213,7 @@ register_http_handlers <- function(session, metadata) {
# return a rook wrapper for a function that takes a list and returns a list
# (list contents are automatically converted to/from JSON for rook as required)
rpc_handler <- function(handler) {
-
function(data, req) {
-
# get the input
input <- json_rpc_input(req)
diff --git a/R/i18n.R b/R/i18n.R
index a366f9f70..160ffb803 100644
--- a/R/i18n.R
+++ b/R/i18n.R
@@ -50,7 +50,9 @@ i18n_process_language_options <- function(language = NULL) {
language[[lng]] <- i18n_validate_customization(language[[lng]])
- if (is.null(language[[lng]])) next
+ if (is.null(language[[lng]])) {
+ next
+ }
custom[[lng]] <- list(custom = language[[lng]])
}
}
@@ -68,7 +70,11 @@ i18n_process_language_options <- function(language = NULL) {
i18n_read_json <- function(path) {
tryCatch(
- jsonlite::read_json(path, simplifyDataFrame = FALSE, simplifyMatrix = FALSE),
+ jsonlite::read_json(
+ path,
+ simplifyDataFrame = FALSE,
+ simplifyMatrix = FALSE
+ ),
error = function(e) {
message("Unable to read custom language JSON file at: ", path)
NULL
@@ -100,7 +106,8 @@ i18n_validate_customization <- function(lng) {
extra_group_keys <- setdiff(names(lng), group_keys)
if (length(extra_group_keys)) {
warning(
- "Ignoring extra customization groups ", paste(extra_group_keys, collapse = ", "),
+ "Ignoring extra customization groups ",
+ paste(extra_group_keys, collapse = ", "),
immediate. = TRUE
)
}
@@ -109,7 +116,9 @@ i18n_validate_customization <- function(lng) {
extra_keys <- setdiff(names(lng[[group]]), names(default[[group]]))
if (length(extra_keys)) {
warning(
- "Ignoring extra ", group, " language customizations: ",
+ "Ignoring extra ",
+ group,
+ " language customizations: ",
paste(extra_keys, collapse = ", "),
immediate. = TRUE
)
@@ -137,10 +146,14 @@ i18n_div <- function(key, ..., opts = NULL) {
}
i18n_combine_words <- function(
- words, and = c("and", "or"), before = "", after = before, oxford_comma = TRUE
+ words,
+ and = c("and", "or"),
+ before = "",
+ after = before,
+ oxford_comma = TRUE
) {
- and <- match.arg(and)
- and <- sprintf(" $t(text.%s) ", and)
+ and <- match.arg(and)
+ and <- sprintf(" $t(text.%s) ", and)
words <- paste0(before, words, after)
n <- length(words)
@@ -151,7 +164,8 @@ i18n_combine_words <- function(
knitr::combine_words(
words,
sep = "$t(text.listcomma) ",
- and = and, oxford_comma = FALSE
+ and = and,
+ oxford_comma = FALSE
)
}
diff --git a/R/identifiers.R b/R/identifiers.R
index 3c031255a..f4218044a 100644
--- a/R/identifiers.R
+++ b/R/identifiers.R
@@ -1,23 +1,25 @@
-
initialize_session_state <- function(session, metadata, location, request) {
-
# helper to read rook headers
as_rook_header <- function(name) {
- if (!is.null(name))
+ if (!is.null(name)) {
paste0("HTTP_", toupper(gsub("-", "_", name, fixed = TRUE)))
- else
+ } else {
NULL
+ }
}
# function to initialize an identifier (read from http header or take default)
initialize_identifier <- function(identifier, default) {
-
# determine whether a custom header provides the value (fallback to default)
- header <- as_rook_header(getOption(sprintf("tutorial.http_header_%s", identifier)))
- if (!is.null(header) && exists(header, envir = request))
+ header <- as_rook_header(getOption(sprintf(
+ "tutorial.http_header_%s",
+ identifier
+ )))
+ if (!is.null(header) && exists(header, envir = request)) {
value <- get(header, envir = request)
- else
+ } else {
value <- default
+ }
# write it into the request for reading later on
write_request(session, sprintf("tutorial.%s", identifier), value)
@@ -64,10 +66,16 @@ package_info <- function() {
}
}
-default_tutorial_id <- function(id = NULL, location = NULL, pkg = package_info()) {
+default_tutorial_id <- function(
+ id = NULL,
+ location = NULL,
+ pkg = package_info()
+) {
# determine default tutorial id (metadata first then filesystem-based for
# localhost and remote URL based for other configurations)
- if (!is.null(id)) return(id)
+ if (!is.null(id)) {
+ return(id)
+ }
if (!is_localhost(location)) {
return(paste0(location$host, location$pathname))
@@ -86,7 +94,9 @@ default_tutorial_id <- function(id = NULL, location = NULL, pkg = package_info()
default_tutorial_version <- function(version = NULL, pkg = package_info()) {
# determine default version (if in a package use the package version)
- if (!is.null(version)) return(version)
+ if (!is.null(version)) {
+ return(version)
+ }
if (!is.null(pkg$dir)) {
return(pkg$info$Version)
@@ -107,10 +117,13 @@ default_language <- function() {
read_request <- function(session, name, default = NULL) {
if (!is.null(name)) {
- if (is.environment(session$request) && exists(name, envir = session$request))
+ if (
+ is.environment(session$request) && exists(name, envir = session$request)
+ ) {
get(name, envir = session$request)
- else
+ } else {
default
+ }
} else {
default
}
@@ -121,4 +134,3 @@ write_request <- function(session, name, value) {
session$request[[name]] <- value
do.call("lockBinding", list("request", session))
}
-
diff --git a/R/initialize.R b/R/initialize.R
index b1ecdd9b4..651d664aa 100644
--- a/R/initialize.R
+++ b/R/initialize.R
@@ -1,6 +1,3 @@
-
-
-
#' Initialize tutorial R Markdown extensions
#'
#' One time initialization of R Markdown extensions required by the
@@ -12,11 +9,11 @@
#'
#' @export
initialize_tutorial <- function() {
-
# helper function for one time initialization
- if (isTRUE(getOption("knitr.in.progress")) &&
- !isTRUE(knitr::opts_knit$get("tutorial.initialized"))) {
-
+ if (
+ isTRUE(getOption("knitr.in.progress")) &&
+ !isTRUE(knitr::opts_knit$get("tutorial.initialized"))
+ ) {
# html dependencies
knitr::knit_meta_add(list(
rmarkdown::html_dependency_jquery(),
@@ -29,8 +26,10 @@ initialize_tutorial <- function() {
# session initialization (forward tutorial metadata)
rmarkdown::shiny_prerendered_chunk(
'server',
- sprintf('learnr:::register_http_handlers(session, metadata = %s)',
- dput_to_string(rmarkdown::metadata$tutorial)),
+ sprintf(
+ 'learnr:::register_http_handlers(session, metadata = %s)',
+ dput_to_string(rmarkdown::metadata$tutorial)
+ ),
singleton = TRUE
)
@@ -50,9 +49,11 @@ initialize_tutorial <- function() {
# Register session stop handler
rmarkdown::shiny_prerendered_chunk(
'server',
- sprintf('session$onSessionEnded(function() {
+ sprintf(
+ 'session$onSessionEnded(function() {
learnr:::event_trigger(session, "session_stop")
- })'),
+ })'
+ ),
singleton = TRUE
)
@@ -64,7 +65,9 @@ initialize_tutorial <- function() {
dput_to_string <- function(x) {
conn <- textConnection("dput_to_string", "w")
- on.exit({close(conn)})
+ on.exit({
+ close(conn)
+ })
dput(x, file = conn)
# Must use a `"\n"` if `dput()`ing a function
paste0(textConnectionValue(conn), collapse = "\n")
diff --git a/R/knitr-hooks.R b/R/knitr-hooks.R
index 94a0f121d..3b62e7285 100644
--- a/R/knitr-hooks.R
+++ b/R/knitr-hooks.R
@@ -19,7 +19,7 @@ detect_installed_knitr_hooks <- function() {
tutorial_knitr_options <- function() {
# helper to check for runtime: shiny_prerendered being active
is_shiny_prerendered_active <- function() {
- identical(knitr::opts_knit$get("rmarkdown.runtime"),"shiny_prerendered")
+ identical(knitr::opts_knit$get("rmarkdown.runtime"), "shiny_prerendered")
}
# helper to check for an exercise chunk
@@ -34,7 +34,9 @@ tutorial_knitr_options <- function() {
return(TRUE)
}
- chunk_opt_exercise <- attr(get_knitr_chunk(label), "chunk_opts")[["exercise"]]
+ chunk_opt_exercise <- attr(get_knitr_chunk(label), "chunk_opts")[[
+ "exercise"
+ ]]
if (is.symbol(chunk_opt_exercise)) {
# original chunk options might not be evaluated yet, see #757
chunk_opt_exercise <- eval(chunk_opt_exercise, knitr::knit_global())
@@ -46,7 +48,10 @@ tutorial_knitr_options <- function() {
# is an empty chunk that didn't trigger knitr's duplicate chunk error).
# Note that we can't rely on knit_code$get() or options$code since they
# both report the code for the non-exercise chunk.
- msg <- sprintf("Cannot create exercise '%s': duplicate chunk label", label)
+ msg <- sprintf(
+ "Cannot create exercise '%s': duplicate chunk label",
+ label
+ )
rlang::abort(msg)
}
@@ -117,7 +122,8 @@ tutorial_knitr_options <- function() {
# look for another chunk which names this as its setup chunk or if it has `exercise.setup`
# this second condition is for support chunks that isn't referenced by an exercise yet
# but is part of a chain and should be stored as a setup chunk
- is_referenced <- length(exercise_chunks_for_setup_chunk(options$label)) > 0
+ is_referenced <- length(exercise_chunks_for_setup_chunk(options$label)) >
+ 0
if (is_referenced) {
find_parent_setup_chunks(options) # only used to check for cycles; the return value is not useful here
return(TRUE)
@@ -126,8 +132,16 @@ tutorial_knitr_options <- function() {
# if this looks like a setup chunk, but no one references it, error
if (is.null(options[["exercise"]]) && !is.null(options$exercise.setup)) {
stop(
- "Chunk '", options$label, "' is not being used by any exercise or exercise setup chunk.\n",
- "Please remove chunk '", options$label, "' or reference '", options$label, "' with `exercise.setup = '", options$label, "'`",
+ "Chunk '",
+ options$label,
+ "' is not being used by any exercise or exercise setup chunk.\n",
+ "Please remove chunk '",
+ options$label,
+ "' or reference '",
+ options$label,
+ "' with `exercise.setup = '",
+ options$label,
+ "'`",
call. = FALSE
)
}
@@ -137,7 +151,8 @@ tutorial_knitr_options <- function() {
}
is_exercise_setup_chunk <- function(label) {
- grepl("-setup$", label) || (length(exercise_chunks_for_setup_chunk(label)) > 0)
+ grepl("-setup$", label) ||
+ (length(exercise_chunks_for_setup_chunk(label)) > 0)
}
# helper function to grab the raw knitr chunk associated with a chunk label
@@ -159,22 +174,34 @@ tutorial_knitr_options <- function() {
# it goes up the chain of setup dependencies and returns a list of raw knitr chunks (if any)
find_parent_setup_chunks <- function(options, visited = NULL) {
# base case: when options are null, there are no more setup references
- if (is.null(options))
+ if (is.null(options)) {
return(NULL)
+ }
has_visited <- options$label %in% visited
# update visited set
visited <- append(visited, options$label)
# error out if there is a cycle
if (has_visited) {
- stop("Chained setup chunks form a cycle!\nCycle: ", paste0(visited, collapse = " => "), call. = FALSE)
+ stop(
+ "Chained setup chunks form a cycle!\nCycle: ",
+ paste0(visited, collapse = " => "),
+ call. = FALSE
+ )
}
# check if the chunk with label has another setup chunk associated with it
setup_label <- options$exercise.setup
setup_chunk <- get_knitr_chunk(setup_label)
# if the setup_label is mispelled, throw an error to user instead of silently ignoring
# which would cause other issues when data dependencies can't be found
- if (!is.null(setup_label) && is.null(setup_chunk))
- stop(paste0("exercise.setup label '", setup_label, "' not found for exercise '", options$label, "'"))
+ if (!is.null(setup_label) && is.null(setup_chunk)) {
+ stop(paste0(
+ "exercise.setup label '",
+ setup_label,
+ "' not found for exercise '",
+ options$label,
+ "'"
+ ))
+ }
setup_options <- attr(setup_chunk, "chunk_opts")
# serialize the options here so that the values are not evaluated when retrieved from learnr cache
@@ -191,7 +218,10 @@ tutorial_knitr_options <- function() {
)
}
# recurse
- append(find_parent_setup_chunks(setup_options, visited), current_setup_chunks)
+ append(
+ find_parent_setup_chunks(setup_options, visited),
+ current_setup_chunks
+ )
}
# helper function to return a list of exercise chunk and its setup chunks
@@ -214,13 +244,29 @@ tutorial_knitr_options <- function() {
} else {
NULL
}
- append(setup_chunks, list(list(label = options$label, code = exercise_chunk, opts = chunk_opts, engine = knitr_engine(options$engine))))
+ append(
+ setup_chunks,
+ list(list(
+ label = options$label,
+ code = exercise_chunk,
+ opts = chunk_opts,
+ engine = knitr_engine(options$engine)
+ ))
+ )
}
get_reveal_solution_option <- function(solution_opts) {
- exercise_chunk <- get_knitr_chunk(sub("-solution$", "", solution_opts$label))
+ exercise_chunk <- get_knitr_chunk(sub(
+ "-solution$",
+ "",
+ solution_opts$label
+ ))
if (is.null(exercise_chunk)) {
- stop("Can not find exercise chunk for solution: `", solution_opts$label, "`")
+ stop(
+ "Can not find exercise chunk for solution: `",
+ solution_opts$label,
+ "`"
+ )
}
# these are unevaluated options at this point
@@ -232,9 +278,15 @@ tutorial_knitr_options <- function() {
# Determine if we should reveal the solution using...
reveal_solution <-
# 1. the option explicitly set on the solution chunk
- eval(sol_opts_user$exercise.reveal_solution, envir = knitr::knit_global()) %||%
+ eval(
+ sol_opts_user$exercise.reveal_solution,
+ envir = knitr::knit_global()
+ ) %||%
# 2. the option explicitly set on the exercise chunk
- eval(exercise_opts$exercise.reveal_solution, envir = knitr::knit_global()) %||%
+ eval(
+ exercise_opts$exercise.reveal_solution,
+ envir = knitr::knit_global()
+ ) %||%
# 3. the global knitr chunk option
solution_opts$exercise.reveal_solution %||%
# 4. the global R option
@@ -244,7 +296,7 @@ tutorial_knitr_options <- function() {
}
# hook to turn off evaluation/highlighting for exercise related chunks
- tutorial_opts_hook <- function(options) {
+ tutorial_opts_hook <- function(options) {
# ensure label is an unnamed string (yihui/knitr#2280)
options$label <- unname(options$label)
@@ -254,9 +306,14 @@ tutorial_knitr_options <- function() {
exercise_setup_chunk <- is_exercise_support_chunk(options, type = "setup")
# validate that we have runtime: shiny_prerendered
- if ((exercise_chunk || exercise_support_chunk) && !is_shiny_prerendered_active()) {
- stop("Tutorial exercises require the use of 'runtime: shiny_prerendered'",
- call. = FALSE)
+ if (
+ (exercise_chunk || exercise_support_chunk) &&
+ !is_shiny_prerendered_active()
+ ) {
+ stop(
+ "Tutorial exercises require the use of 'runtime: shiny_prerendered'",
+ call. = FALSE
+ )
}
# validate or ensure that the exercise chunk is 'defined'
@@ -266,7 +323,6 @@ tutorial_knitr_options <- function() {
# if this is an exercise chunk then set various options
if (exercise_chunk) {
-
# one time tutor initialization
initialize_tutorial()
@@ -274,10 +330,11 @@ tutorial_knitr_options <- function() {
options$include <- TRUE
options$highlight <- FALSE
options$comment <- NA
- if (!is.null(options$exercise.eval))
+ if (!is.null(options$exercise.eval)) {
options$eval <- options$exercise.eval
- else
+ } else {
options$eval <- FALSE
+ }
# exercises can be support chunks, but if it's an exercise it should be treated that way
return(options)
}
@@ -291,7 +348,12 @@ tutorial_knitr_options <- function() {
options$highlight <- FALSE
}
- if (is_exercise_support_chunk(options, type = c("code-check", "error-check", "check", "tests"))) {
+ if (
+ is_exercise_support_chunk(
+ options,
+ type = c("code-check", "error-check", "check", "tests")
+ )
+ ) {
# completely suppress behind-the-scenes support chunks
options$include <- FALSE
}
@@ -299,7 +361,9 @@ tutorial_knitr_options <- function() {
if (is_exercise_support_chunk(options, type = "check")) {
if (is.null(knitr::opts_chunk$get("exercise.checker"))) {
stop(
- "An exercise check chunk exists ('", options$label, "') but an ",
+ "An exercise check chunk exists ('",
+ options$label,
+ "') but an ",
"exercise checker function is not configured for this tutorial. ",
"Please use `tutorial_options()` to define an `exercise.checker`."
)
@@ -316,21 +380,30 @@ tutorial_knitr_options <- function() {
if (exercise_setup_chunk) {
# figure out the default behavior
exercise_eval <- knitr::opts_chunk$get('exercise.eval')
- if (is.null(exercise_eval))
+ if (is.null(exercise_eval)) {
exercise_eval <- FALSE
+ }
# look for chunks that name this as their setup chunk
labels <- exercise_chunks_for_setup_chunk(options$label)
- if (grepl("-setup$", options$label))
+ if (grepl("-setup$", options$label)) {
labels <- c(labels, sub("-setup$", "", options$label))
+ }
labels <- paste0('"', labels, '"')
- labels <- paste0('c(', paste(labels, collapse = ', ') ,')')
- label_query <- paste0("knitr::all_labels(label %in% ", labels, ", ",
- "identical(exercise.eval, ", !exercise_eval, "))")
+ labels <- paste0('c(', paste(labels, collapse = ', '), ')')
+ label_query <- paste0(
+ "knitr::all_labels(label %in% ",
+ labels,
+ ", ",
+ "identical(exercise.eval, ",
+ !exercise_eval,
+ "))"
+ )
default_reversed <- length(eval(parse(text = label_query))) > 0
- if (default_reversed)
+ if (default_reversed) {
exercise_eval <- !exercise_eval
+ }
# set the eval property as appropriate
options$eval <- exercise_eval
@@ -343,9 +416,13 @@ tutorial_knitr_options <- function() {
is.null(get_knitr_chunk(sub("-error", "", options$label)))
) {
stop(
- "Exercise '", sub("-error-check", "", options$label), "': ",
+ "Exercise '",
+ sub("-error-check", "", options$label),
+ "': ",
"a *-check chunk is required when using an *-error-check chunk, but",
- " '", sub("-error", "", options$label), "' was not found in the tutorial.",
+ " '",
+ sub("-error", "", options$label),
+ "' was not found in the tutorial.",
call. = FALSE
)
}
@@ -366,38 +443,46 @@ tutorial_knitr_options <- function() {
exercise_wrapper_div <- function(suffix = NULL, extra_html = NULL) {
# before exercise
if (before) {
- if (!is.null(suffix))
+ if (!is.null(suffix)) {
suffix <- paste0("-", suffix)
+ }
class <- paste0("exercise", suffix)
- lines <- ifelse(is.numeric(options$exercise.lines),
- options$exercise.lines, 0)
- completion <- as.numeric(options$exercise.completion %||% 1 > 0)
+ lines <- ifelse(
+ is.numeric(options$exercise.lines),
+ options$exercise.lines,
+ 0
+ )
+ completion <- as.numeric(options$exercise.completion %||% 1 > 0)
diagnostics <- as.numeric(options$exercise.diagnostics %||% 1 > 0)
startover <- as.numeric(options$exercise.startover %||% 1 > 0)
paste0(
- ''
)
- }
- # after exercise
- else {
+ } else {
+ # after exercise
c(extra_html, '
')
}
}
# handle exercise chunks
if (is_exercise_chunk(options)) {
-
# one-time dependencies/server code
extra_html <- NULL
if (before) {
-
# verify the chunk has a label if required
verify_tutorial_chunk_label()
@@ -409,16 +494,23 @@ tutorial_knitr_options <- function() {
# write server code
exercise_server_chunk(options$label)
- }
- else {
+ } else {
# forward a subset of standard knitr chunk options
options$engine <- knitr_engine(options$engine)
- options$exercise.df_print <- options$exercise.df_print %||% knitr::opts_knit$get('rmarkdown.df_print') %||% "default"
+ options$exercise.df_print <- options$exercise.df_print %||%
+ knitr::opts_knit$get('rmarkdown.df_print') %||%
+ "default"
options$exercise.checker <- dput_to_string(options$exercise.checker)
all_chunks <- get_all_chunks(options)
- code_check_chunk <- get_knitr_chunk(paste0(options$label, "-code-check"))
- error_check_chunk <- get_knitr_chunk(paste0(options$label, "-error-check"))
+ code_check_chunk <- get_knitr_chunk(paste0(
+ options$label,
+ "-code-check"
+ ))
+ error_check_chunk <- get_knitr_chunk(paste0(
+ options$label,
+ "-error-check"
+ ))
check_chunk <- get_knitr_chunk(paste0(options$label, "-check"))
solution <- get_knitr_chunk(paste0(options$label, "-solution"))
tests <- get_knitr_chunk(paste0(options$label, "-tests"))
@@ -431,7 +523,11 @@ tutorial_knitr_options <- function() {
all_setup_code <- NULL
if (length(all_chunks) > 1) {
all_setup_code <- paste0(
- vapply(all_chunks[-length(all_chunks)], function(x) x$code, character(1)),
+ vapply(
+ all_chunks[-length(all_chunks)],
+ function(x) x$code,
+ character(1)
+ ),
collapse = "\n"
)
}
@@ -445,7 +541,7 @@ tutorial_knitr_options <- function() {
code_check = code_check_chunk,
error_check = error_check_chunk,
check = check_chunk,
- solution = solution,
+ solution = solution,
tests = tests,
options = options[setdiff(names(options), "tutorial")],
engine = options$engine,
@@ -471,7 +567,10 @@ tutorial_knitr_options <- function() {
cap_engine <- knitr_engine(options$engine)
# use logo shipped within learnr pkg (currently none)
- cap_engine_file <- system.file(file.path("internals", "icons", paste0(cap_engine, ".svg")), package = "learnr")
+ cap_engine_file <- system.file(
+ file.path("internals", "icons", paste0(cap_engine, ".svg")),
+ package = "learnr"
+ )
if (file.exists(cap_engine_file)) {
as.character(htmltools::div(
class = "tutorial_engine_icon",
@@ -491,18 +590,17 @@ tutorial_knitr_options <- function() {
has_checker = (!is.null(check_chunk) || !is.null(code_check_chunk)),
caption = as.character(caption)
)
- extra_html <- c('')
+ extra_html <- c(
+ ''
+ )
}
# wrapper div (called for before and after)
exercise_wrapper_div(extra_html = extra_html)
- }
-
- # handle exercise support chunks (hints, solution)
- else if (is_exercise_support_chunk(options)) {
-
+ } else if (is_exercise_support_chunk(options)) {
+ # handle exercise support chunks (hints, solution)
# setup and checking code (-setup, -code-check, and -check) are included in exercise cache
# do not send the setup and checking code to the browser
@@ -515,7 +613,6 @@ tutorial_knitr_options <- function() {
exercise_wrapper_div(suffix = "support")
}
}
-
}
}
@@ -547,22 +644,34 @@ remove_knitr_hooks <- function() {
exercise_server_chunk <- function(label) {
# reactive for exercise execution
- rmarkdown::shiny_prerendered_chunk('server', sprintf(
-'`tutorial-exercise-%s-result` <- learnr:::setup_exercise_handler(reactive(req(input$`tutorial-exercise-%s-code-editor`)), session)
+ rmarkdown::shiny_prerendered_chunk(
+ 'server',
+ sprintf(
+ '`tutorial-exercise-%s-result` <- learnr:::setup_exercise_handler(reactive(req(input$`tutorial-exercise-%s-code-editor`)), session)
output$`tutorial-exercise-%s-output` <- renderUI({
`tutorial-exercise-%s-result`()
-})', label, label, label, label))
+})',
+ label,
+ label,
+ label,
+ label
+ )
+ )
}
verify_tutorial_chunk_label <- function() {
- if (!isTRUE(getOption("knitr.in.progress"))) return()
+ if (!isTRUE(getOption("knitr.in.progress"))) {
+ return()
+ }
label <- knitr::opts_current$get('label')
unnamed_label <- knitr::opts_knit$get('unnamed.chunk.label')
if (isTRUE(grepl(paste0('^', unnamed_label), label))) {
- stop("Code chunks with exercises or quiz questions must be labeled.",
- call. = FALSE)
+ stop(
+ "Code chunks with exercises or quiz questions must be labeled.",
+ call. = FALSE
+ )
}
not_valid_char_regex <- "[^a-zA-Z0-9_-]"
if (grepl(not_valid_char_regex, label)) {
@@ -573,8 +682,12 @@ verify_tutorial_chunk_label <- function() {
"\n\tnumbers case letters: 0-9",
"\n\tunderscore: _",
"\n\tdash: -",
- "\n\nCurrent label: \"", label ,"\"",
- "\n\nTry using: \"", gsub(not_valid_char_regex, "_", label) ,"\"",
+ "\n\nCurrent label: \"",
+ label,
+ "\"",
+ "\n\nTry using: \"",
+ gsub(not_valid_char_regex, "_", label),
+ "\"",
call. = FALSE
)
}
diff --git a/R/learnr_messages.R b/R/learnr_messages.R
index 8096a99ec..2685d428b 100644
--- a/R/learnr_messages.R
+++ b/R/learnr_messages.R
@@ -16,7 +16,7 @@
if (length(queue)) queue
},
flush = function() {
- while(length(queue)) {
+ while (length(queue)) {
cnd <- queue[[1]]
if (inherits(cnd, "error")) {
# throw errors, they're immediate
@@ -49,7 +49,10 @@ learnr_render_message <- function(..., level = c("inform", "warn", "abort")) {
warn = rlang::warn,
abort = rlang::abort
)
- cnd <- rlang::catch_cnd(create_cnd(paste0(..., "\n"), "learnr_render_message"))
+ cnd <- rlang::catch_cnd(create_cnd(
+ paste0(..., "\n"),
+ "learnr_render_message"
+ ))
if (isTRUE(getOption('knitr.in.progress'))) {
.learnr_messages$add(cnd)
diff --git a/R/mock_exercise.R b/R/mock_exercise.R
index 5fd5e1d76..22fbffd70 100644
--- a/R/mock_exercise.R
+++ b/R/mock_exercise.R
@@ -73,10 +73,10 @@ mock_exercise <- function(
global_setup = NULL,
setup_label = NULL,
solution_code = NULL,
- code_check = NULL, # code_check chunk
+ code_check = NULL, # code_check chunk
error_check = NULL, # error_check chunk
- check = NULL, # check chunk
- tests = NULL, # tests chunk
+ check = NULL, # check chunk
+ tests = NULL, # tests chunk
exercise.checker = NULL,
exercise.error.check.code = NULL,
exercise.df_print = "default",
@@ -102,7 +102,8 @@ mock_exercise <- function(
fig.retina = fig.retina,
engine = engine,
max.print = 1000,
- exercise.checker = exercise.checker %||% dput_to_string(debug_exercise_checker),
+ exercise.checker = exercise.checker %||%
+ dput_to_string(debug_exercise_checker),
label = label,
exercise = TRUE,
exercise.setup = setup_label,
@@ -111,22 +112,26 @@ mock_exercise <- function(
exercise.df_print = exercise.df_print,
exercise.warn_invisible = exercise.warn_invisible,
exercise.timelimit = exercise.timelimit,
- exercise.error.check.code = exercise.error.check.code %||% dput_to_string(debug_exercise_checker)
+ exercise.error.check.code = exercise.error.check.code %||%
+ dput_to_string(debug_exercise_checker)
)
assert_unique_exercise_chunk_labels(chunks, label)
# create non-existent exercise chunk from global options
- chunks <- c(chunks, list(
- mock_chunk(
- label,
- user_code,
- exercise = TRUE,
- engine = engine,
- exercise.setup = setup_label,
- ...
+ chunks <- c(
+ chunks,
+ list(
+ mock_chunk(
+ label,
+ user_code,
+ exercise = TRUE,
+ engine = engine,
+ exercise.setup = setup_label,
+ ...
+ )
)
- ))
+ )
assert_unique_chunk_labels(chunks)
@@ -136,7 +141,7 @@ mock_exercise <- function(
restore = FALSE,
timestamp = as.numeric(Sys.time()),
global_setup = paste(global_setup, collapse = "\n"), # added by get_global_setup()
- setup = mock_prep_setup(chunks, setup_label), # walk setup chain
+ setup = mock_prep_setup(chunks, setup_label), # walk setup chain
chunks = chunks,
solution = solution_code,
code_check = code_check,
@@ -177,7 +182,12 @@ assert_unique_exercise_chunk_labels <- function(chunks, label) {
if (!any(is_exercise_chunk)) {
return()
}
- exercise_chunk_labels <- vapply(chunks[is_exercise_chunk], `[[`, character(1), "label")
+ exercise_chunk_labels <- vapply(
+ chunks[is_exercise_chunk],
+ `[[`,
+ character(1),
+ "label"
+ )
n_ex_label_chunks <- sum(exercise_chunk_labels == label)
if (n_ex_label_chunks == 0) {
return()
@@ -225,7 +235,8 @@ mock_prep_setup <- function(chunks, setup_label) {
stop(
"Cycles detected in setup chunks: ",
paste(visited_setup_chunks, collapse = " -> "),
- " -> ", setup_label
+ " -> ",
+ setup_label
)
}
found_chunk <- FALSE
diff --git a/R/mutate_tags.R b/R/mutate_tags.R
index 25b94c439..eb5225306 100644
--- a/R/mutate_tags.R
+++ b/R/mutate_tags.R
@@ -1,5 +1,3 @@
-
-
# ' S3 method to recursively look for elements according to a basic css string.
# ' This method should not be used publically until adopted by \code{htmltools}.
# ' @param selector css selector string
@@ -12,14 +10,20 @@ mutate_tags <- function(ele, selector, fn, ...) {
#' @export
mutate_tags.default <- function(ele, selector, fn, ...) {
- if (any(
- c(
- "NULL",
- "numeric", "integer", "complex",
- "logical",
- "character", "factor"
- ) %in% class(ele)
- )) {
+ if (
+ any(
+ c(
+ "NULL",
+ "numeric",
+ "integer",
+ "complex",
+ "logical",
+ "character",
+ "factor"
+ ) %in%
+ class(ele)
+ )
+ ) {
return(ele)
}
@@ -76,7 +80,9 @@ mutate_tags.shiny.tag <- function(ele, selector, fn, ...) {
}
# match on class values
if (is_match && !is.null(cur_selector$classes)) {
- is_match <- all(strsplit(ele$attribs$class %||% "", " ")[[1]] %in% cur_selector$classes)
+ is_match <- all(
+ strsplit(ele$attribs$class %||% "", " ")[[1]] %in% cur_selector$classes
+ )
}
# if it is a match, drop a selector
@@ -97,8 +103,8 @@ mutate_tags.shiny.tag <- function(ele, selector, fn, ...) {
if (
# it is a "leaf" match
length(selector) == 0 ||
- # or should match everything
- cur_selector$match_everything
+ # or should match everything
+ cur_selector$match_everything
) {
# update it
ele <- fn(ele, ...)
@@ -171,7 +177,9 @@ finalize_question <- function(ele) {
ele <- disable_all_tags(ele)
if (inherits(ele, "shiny.tag.list")) {
ele_class <- class(ele)
- ele <- lapply(ele, function(el) tagAppendAttributes(el, class = "question-final"))
+ ele <- lapply(ele, function(el) {
+ tagAppendAttributes(el, class = "question-final")
+ })
class(ele) <- ele_class
} else {
ele <- tagAppendAttributes(ele, class = "question-final")
diff --git a/R/options.R b/R/options.R
index aa6de3742..ca11d97bc 100644
--- a/R/options.R
+++ b/R/options.R
@@ -1,4 +1,3 @@
-
#' Set tutorial options
#'
#' Set various tutorial options that control the display and evaluation of
@@ -39,19 +38,20 @@
#' @return Nothing. Invisibly sets [knitr::opts_chunk] settings.
#'
#' @export
-tutorial_options <- function(exercise.cap = NULL,
- exercise.eval = FALSE,
- exercise.timelimit = 30,
- exercise.lines = NULL,
- exercise.pipe = NULL,
- exercise.blanks = NULL,
- exercise.checker = NULL,
- exercise.error.check.code = NULL,
- exercise.completion = TRUE,
- exercise.diagnostics = TRUE,
- exercise.startover = TRUE,
- exercise.reveal_solution = TRUE)
-{
+tutorial_options <- function(
+ exercise.cap = NULL,
+ exercise.eval = FALSE,
+ exercise.timelimit = 30,
+ exercise.lines = NULL,
+ exercise.pipe = NULL,
+ exercise.blanks = NULL,
+ exercise.checker = NULL,
+ exercise.error.check.code = NULL,
+ exercise.completion = TRUE,
+ exercise.diagnostics = TRUE,
+ exercise.startover = TRUE,
+ exercise.reveal_solution = TRUE
+) {
# string to evalute for setting chunk options %1$s
set_option_code <- 'if (!missing(%1$s)) knitr::opts_chunk$set(%1$s = %1$s)'
diff --git a/R/praise.R b/R/praise.R
index 477d06637..78639546a 100644
--- a/R/praise.R
+++ b/R/praise.R
@@ -1,4 +1,3 @@
-
#' Random praise and encouragement
#'
#' Random praises and encouragements sayings to compliment your question and
@@ -29,7 +28,11 @@ random_encouragement <- function(language = NULL) {
}
read_random_phrases <- function() {
- readRDS(system.file("internals", "i18n_random_phrases.rds", package = "learnr"))
+ readRDS(system.file(
+ "internals",
+ "i18n_random_phrases.rds",
+ package = "learnr"
+ ))
}
random_phrases_languages <- function() {
@@ -43,7 +46,10 @@ random_phrases <- function(type, language = NULL) {
if (!type %in% names(.random_phrases)) {
stop.(
"`type` should be one of ",
- knitr::combine_words(paste0("'", names(.random_phrases), "'"), and = " or ")
+ knitr::combine_words(
+ paste0("'", names(.random_phrases), "'"),
+ and = " or "
+ )
)
}
@@ -55,7 +61,11 @@ random_phrases <- function(type, language = NULL) {
}
if (!language %in% names(.random_phrases[[type]])) {
learnr_render_message(
- "learnr doesn't know how to provide ", type, " in the language '", language, "'",
+ "learnr doesn't know how to provide ",
+ type,
+ " in the language '",
+ language,
+ "'",
level = "warn"
)
return(warn_unsupported_language(default))
@@ -118,7 +128,11 @@ random_phrases <- function(type, language = NULL) {
#' rendered chunk.
#'
#' @export
-random_phrases_add <- function(language = "en", praise = NULL, encouragement = NULL) {
+random_phrases_add <- function(
+ language = "en",
+ praise = NULL,
+ encouragement = NULL
+) {
phrases <- list()
if (!is.null(praise)) {
stopifnot(is.character(praise))
@@ -130,9 +144,7 @@ random_phrases_add <- function(language = "en", praise = NULL, encouragement = N
phrases$encouragement <- list()
phrases$encouragement[[language]] <- encouragement
}
- if (
- isTRUE(getOption('knitr.in.progress'))
- ) {
+ if (isTRUE(getOption('knitr.in.progress'))) {
if (!identical(knitr::opts_current$get("label"), "setup")) {
rmarkdown::shiny_prerendered_chunk(
context = "server-start",
diff --git a/R/question_answers.R b/R/question_answers.R
index 28b624edf..1e9069860 100644
--- a/R/question_answers.R
+++ b/R/question_answers.R
@@ -41,7 +41,12 @@
#' @export
answer <- function(text, correct = FALSE, message = NULL, label = text) {
if (!is_html_tag(message)) {
- checkmate::assert_character(message, len = 1, null.ok = TRUE, any.missing = FALSE)
+ checkmate::assert_character(
+ message,
+ len = 1,
+ null.ok = TRUE,
+ any.missing = FALSE
+ )
}
answer_new(
@@ -86,12 +91,12 @@ answer_fn <- function(fn, label = NULL) {
#' @param type Is this a literal answer (directly compare with `option` or `value`)
#' or is this a function to evaluate the submission.
answer_new <- function(
- value,
- label = value,
- option = as.character(value),
- correct = NULL,
- message = NULL,
- type = "literal"
+ value,
+ label = value,
+ option = as.character(value),
+ correct = NULL,
+ message = NULL,
+ type = "literal"
) {
if (!is.character(option)) {
option <- as.character(option)
@@ -162,7 +167,12 @@ incorrect <- function(messages = NULL) {
#' @rdname mark_as_correct_incorrect
#' @export
mark_as <- function(correct, messages = NULL) {
- checkmate::assert_logical(correct, len = 1, null.ok = FALSE, any.missing = FALSE)
+ checkmate::assert_logical(
+ correct,
+ len = 1,
+ null.ok = FALSE,
+ any.missing = FALSE
+ )
ret <- list(
correct = correct,
messages = messages
diff --git a/R/question_checkbox.R b/R/question_checkbox.R
index 69a855ced..24b835320 100644
--- a/R/question_checkbox.R
+++ b/R/question_checkbox.R
@@ -95,7 +95,6 @@ question_ui_initialize.learnr_checkbox <- function(question, value, ...) {
#' @export
question_is_correct.learnr_checkbox <- function(question, value, ...) {
-
append_message <- function(x, ans) {
message <- ans$message
if (is.null(message)) {
@@ -112,7 +111,10 @@ question_is_correct.learnr_checkbox <- function(question, value, ...) {
# Check function answers first
for (q_answer in q_answers[["function"]]) {
- answer_checker <- eval(parse(text = q_answer$value), envir = rlang::caller_env())
+ answer_checker <- eval(
+ parse(text = q_answer$value),
+ envir = rlang::caller_env()
+ )
ret <- answer_checker(value)
if (inherits(ret, "learnr_mark_as")) {
return(ret)
@@ -164,13 +166,14 @@ question_is_correct.learnr_checkbox <- function(question, value, ...) {
#' @export
question_ui_completed.learnr_checkbox <- function(question, value, ...) {
-
choice_values <- answer_values(question, exclude_answer_fn = TRUE)
answers <- answers_split_type(question$answers)[["literal"]]
correct_answers <- Reduce(answers, init = c(), f = function(acc, answer) {
- if (!isTRUE(answer$correct)) return(acc)
+ if (!isTRUE(answer$correct)) {
+ return(acc)
+ }
c(acc, answer$option)
})
diff --git a/R/question_methods.R b/R/question_methods.R
index 6ee78e6bf..9df6023b1 100644
--- a/R/question_methods.R
+++ b/R/question_methods.R
@@ -75,11 +75,15 @@ question_stop <- function(name, question) {
class_txt <-
if (length(classes) == 1) {
classes
- } else{
+ } else {
paste0("{", paste0(classes, collapse = "/"), "}")
}
stop(
- "`", name, ".", class_txt, "(question, ...)` has not been implemented",
+ "`",
+ name,
+ ".",
+ class_txt,
+ "(question, ...)` has not been implemented",
call. = FALSE
)
}
diff --git a/R/question_numeric.R b/R/question_numeric.R
index cbd2c5e59..b9ad16aac 100644
--- a/R/question_numeric.R
+++ b/R/question_numeric.R
@@ -56,14 +56,20 @@ question_numeric <- function(
options = list(),
tolerance = 1.5e-8
) {
- min <- min %||% NA_real_
- max <- max %||% NA_real_
+ min <- min %||% NA_real_
+ max <- max %||% NA_real_
step <- step %||% NA_real_
checkmate::assert_numeric(value, len = 1, null.ok = TRUE, any.missing = FALSE)
checkmate::assert_numeric(min, len = 1, null.ok = FALSE)
checkmate::assert_numeric(max, len = 1, null.ok = FALSE)
- checkmate::assert_numeric(step, len = 1, null.ok = FALSE, lower = 0, finite = TRUE)
+ checkmate::assert_numeric(
+ step,
+ len = 1,
+ null.ok = FALSE,
+ lower = 0,
+ finite = TRUE
+ )
learnr::question(
text = text,
@@ -87,7 +93,6 @@ question_numeric <- function(
}
-
#' @export
question_ui_initialize.learnr_numeric <- function(question, value, ...) {
numericInput(
@@ -115,7 +120,10 @@ question_is_correct.learnr_numeric <- function(question, value, ...) {
if (length(value) == 0 || is.na(value)) {
if (!is.null(shiny::getDefaultReactiveDomain())) {
- showNotification("Please enter a number before submitting", type = "error")
+ showNotification(
+ "Please enter a number before submitting",
+ type = "error"
+ )
}
shiny::validate("Please enter a number")
}
@@ -130,7 +138,10 @@ question_is_correct.learnr_numeric <- function(question, value, ...) {
}
check_answer <- function(answer) {
- answer_checker <- eval(parse(text = answer$value), envir = rlang::caller_env(2))
+ answer_checker <- eval(
+ parse(text = answer$value),
+ envir = rlang::caller_env(2)
+ )
answer_checker(value)
}
@@ -146,10 +157,16 @@ question_is_correct.learnr_numeric <- function(question, value, ...) {
}
if (!is.na(question$options$min) && value < question$options$min) {
- return(mark_as(FALSE, paste0("The number is at least ", question$options$min, ".")))
+ return(mark_as(
+ FALSE,
+ paste0("The number is at least ", question$options$min, ".")
+ ))
}
if (!is.na(question$options$max) && value > question$options$max) {
- return(mark_as(FALSE, paste0("The number is at most ", question$options$max, ".")))
+ return(mark_as(
+ FALSE,
+ paste0("The number is at most ", question$options$max, ".")
+ ))
}
mark_as(FALSE, NULL)
diff --git a/R/question_radio.R b/R/question_radio.R
index d787f082c..9bb8eeb0d 100644
--- a/R/question_radio.R
+++ b/R/question_radio.R
@@ -27,13 +27,13 @@
#' @family Interactive Questions
#' @export
question_radio <- function(
- text,
- ...,
- correct = "Correct!",
- incorrect = "Incorrect",
- try_again = incorrect,
- allow_retry = FALSE,
- random_answer_order = FALSE
+ text,
+ ...,
+ correct = "Correct!",
+ incorrect = "Incorrect",
+ try_again = incorrect,
+ allow_retry = FALSE,
+ random_answer_order = FALSE
) {
question <-
learnr::question(
@@ -63,7 +63,6 @@ question_radio <- function(
#' @export
question_ui_initialize.learnr_radio <- function(question, value, ...) {
-
choice_names <- answer_labels(question, exclude_answer_fn = TRUE)
choice_values <- answer_values(question, exclude_answer_fn = TRUE)
diff --git a/R/question_text.R b/R/question_text.R
index 30f17e03e..973d0a3a5 100644
--- a/R/question_text.R
+++ b/R/question_text.R
@@ -73,7 +73,12 @@ question_text <- function(
cols = NULL,
options = list()
) {
- checkmate::assert_character(placeholder, len = 1, null.ok = TRUE, any.missing = FALSE)
+ checkmate::assert_character(
+ placeholder,
+ len = 1,
+ null.ok = TRUE,
+ any.missing = FALSE
+ )
checkmate::assert_logical(trim, len = 1, null.ok = FALSE, any.missing = FALSE)
if (!identical(random_answer_order, FALSE)) {
@@ -81,7 +86,9 @@ question_text <- function(
lifecycle::deprecate_warn(
when = "0.11.0",
what = "question_text(random_answer_order)",
- details = c(i = "Random answer order is automatically disabled for text questions.")
+ details = c(
+ i = "Random answer order is automatically disabled for text questions."
+ )
)
)
}
@@ -115,7 +122,11 @@ question_ui_initialize.learnr_text <- function(question, value, ...) {
textInput
} else {
function(...) {
- textAreaInput(..., cols = question$options$cols, rows = question$options$rows)
+ textAreaInput(
+ ...,
+ cols = question$options$cols,
+ rows = question$options$rows
+ )
}
}
@@ -134,17 +145,19 @@ question_is_valid.learnr_text <- function(question, value, ...) {
}
if (isTRUE(question$options$trim)) {
return(nchar(str_trim(value)) > 0)
- } else{
+ } else {
return(nchar(value) > 0)
}
}
#' @export
question_is_correct.learnr_text <- function(question, value, ...) {
-
if (nchar(value) == 0) {
if (!is.null(shiny::getDefaultReactiveDomain())) {
- showNotification("Please enter some text before submitting", type = "error")
+ showNotification(
+ "Please enter some text before submitting",
+ type = "error"
+ )
}
shiny::validate("Please enter some text")
}
@@ -164,7 +177,10 @@ question_is_correct.learnr_text <- function(question, value, ...) {
}
check_answer <- function(answer) {
- answer_checker <- eval(parse(text = answer$value), envir = rlang::caller_env(2))
+ answer_checker <- eval(
+ parse(text = answer$value),
+ envir = rlang::caller_env(2)
+ )
answer_checker(value)
}
diff --git a/R/quiz.R b/R/quiz.R
index 64528c610..abe829b5a 100644
--- a/R/quiz.R
+++ b/R/quiz.R
@@ -1,7 +1,7 @@
# TODO - Allow for messages to be functions
- ## defer to v2
+## defer to v2
# X - Allow for null input$answer
- ## No. If the quiz module wants a null value, it can provide a placeholder value that is not NULL
+## No. If the quiz module wants a null value, it can provide a placeholder value that is not NULL
#' Tutorial quiz questions
#'
@@ -101,12 +101,11 @@
#' @rdname quiz
#' @export
quiz <- function(..., caption = rlang::missing_arg()) {
-
# create table rows from questions
index <- 1
questions <- lapply(list(...), function(question) {
if (!is.null(question$label)) {
- label <- paste(question$label, index, sep="-")
+ label <- paste(question$label, index, sep = "-")
question$label <- label
question$ids$answer <- NS(label)("answer")
question$ids$question <- label
@@ -132,22 +131,29 @@ quiz <- function(..., caption = rlang::missing_arg()) {
#' @import shiny
#' @export
question <- function(
- text,
- ...,
- type = c("auto", "single", "multiple", "learnr_radio", "learnr_checkbox", "learnr_text", "learnr_numeric"),
- correct = "Correct!",
- incorrect = "Incorrect",
- try_again = NULL,
- message = NULL,
- post_message = NULL,
- loading = NULL,
- submit_button = rlang::missing_arg(),
- try_again_button = rlang::missing_arg(),
- allow_retry = FALSE,
- random_answer_order = FALSE,
- options = list()
+ text,
+ ...,
+ type = c(
+ "auto",
+ "single",
+ "multiple",
+ "learnr_radio",
+ "learnr_checkbox",
+ "learnr_text",
+ "learnr_numeric"
+ ),
+ correct = "Correct!",
+ incorrect = "Incorrect",
+ try_again = NULL,
+ message = NULL,
+ post_message = NULL,
+ loading = NULL,
+ submit_button = rlang::missing_arg(),
+ try_again_button = rlang::missing_arg(),
+ allow_retry = FALSE,
+ random_answer_order = FALSE,
+ options = list()
) {
-
# one time tutor initialization
initialize_tutorial()
@@ -163,7 +169,12 @@ question <- function(
# count total correct answers to decide between radio/checkbox
answers_split <- answers_split_type(answers)
- total_correct <- sum(vapply(answers_split[["literal"]], `[[`, logical(1), "correct"))
+ total_correct <- sum(vapply(
+ answers_split[["literal"]],
+ `[[`,
+ logical(1),
+ "correct"
+ ))
# determine or resolve question type
if (missing(type)) {
@@ -178,7 +189,8 @@ question <- function(
}
}
if (length(type) == 1) {
- type <- switch(type,
+ type <- switch(
+ type,
"radio" = ,
"single" = "learnr_radio",
"checkbox" = ,
@@ -196,7 +208,8 @@ question <- function(
}
# ensure we have at least one correct answer, if required
- must_have_correct <- identical(type, "learnr_radio") || is.null(answers_split[["function"]])
+ must_have_correct <- identical(type, "learnr_radio") ||
+ is.null(answers_split[["function"]])
if (must_have_correct && total_correct == 0) {
stop("At least one correct answer must be supplied")
}
@@ -268,8 +281,7 @@ quiz_text <- function(text) {
md <- sub("\n?$", "", md)
}
HTML(md)
- }
- else {
+ } else {
NULL
}
}
@@ -358,9 +370,11 @@ retrieve_question_submission_answer <- function(session, question_label) {
}
-
-
-question_prerendered_chunk <- function(question, ..., session = getDefaultReactiveDomain()) {
+question_prerendered_chunk <- function(
+ question,
+ ...,
+ session = getDefaultReactiveDomain()
+) {
store_question_cache(question)
question_state <-
@@ -395,16 +409,17 @@ question_module_ui <- function(id) {
}
question_module_server <- function(
- input, output, session,
+ input,
+ output,
+ session,
question
) {
-
output$answer_container <- renderUI({
if (is.null(question$loading)) {
question_ui_loading(question)
} else {
div(
- class="loading",
+ class = "loading",
question$loading
)
}
@@ -416,18 +431,25 @@ question_module_server <- function(
observeEvent(
req(session$userData$learnr_state() == "restored"),
once = TRUE,
- question_module_server_impl(input, output, session, question, question_state)
+ question_module_server_impl(
+ input,
+ output,
+ session,
+ question,
+ question_state
+ )
)
question_state
}
question_module_server_impl <- function(
- input, output, session,
+ input,
+ output,
+ session,
question,
question_state = NULL
) {
-
ns <- getDefaultReactiveDomain()$ns
# set a seed for each user session for question methods to use
question$seed <- random_seed()
@@ -439,22 +461,27 @@ question_module_server_impl <- function(
is_correct_info <- reactive(label = "is_correct_info", {
# question has not been submitted
- if (is.null(submitted_answer())) return(NULL)
+ if (is.null(submitted_answer())) {
+ return(NULL)
+ }
# find out if answer is right
ret <- question_is_correct(question, submitted_answer())
if (!inherits(ret, "learnr_mark_as")) {
- stop("`question_is_correct(question, input$answer)` must return a result from `correct`, `incorrect`, or `mark_as`")
+ stop(
+ "`question_is_correct(question, input$answer)` must return a result from `correct`, `incorrect`, or `mark_as`"
+ )
}
ret
})
# should present all messages?
is_done <- reactive(label = "is_done", {
- if (is.null(is_correct_info())) return(NULL)
+ if (is.null(is_correct_info())) {
+ return(NULL)
+ }
(!isTRUE(question$allow_retry)) || is_correct_info()$correct
})
-
button_type <- reactive(label = "button type", {
if (is.null(submitted_answer())) {
"submit"
@@ -493,21 +520,25 @@ question_module_server_impl <- function(
if (question$random_answer_order) {
# Shuffle visible answer options (i.e. static, non-function answers)
is_visible_option <- !answer_type_is_function(question$answers)
- question$answers[is_visible_option] <<- shuffle(question$answers[is_visible_option])
+ question$answers[is_visible_option] <<- shuffle(question$answers[
+ is_visible_option
+ ])
}
submitted_answer(restoreValue)
}
# restore past submission
# If no prior submission, it returns NULL
- past_submission_answer <- retrieve_question_submission_answer(session, question$label)
+ past_submission_answer <- retrieve_question_submission_answer(
+ session,
+ question$label
+ )
# initialize like normal... nothing has been submitted
# or
# initialize with the past answer
# this should cascade throughout the app to display correct answers and final outputs
init_question(past_submission_answer)
-
output$action_button_container <- renderUI({
question_button_label(
question,
@@ -569,9 +600,7 @@ question_module_server_impl <- function(
)
})
-
observeEvent(input$action_button, {
-
if (button_type() == "try_again") {
# maintain current submission / do not randomize answer order
# only reset the submitted answers
@@ -583,7 +612,7 @@ question_module_server_impl <- function(
session,
"reset_question_submission",
data = list(
- label = as.character(question$label),
+ label = as.character(question$label),
question = as.character(question$question)
)
)
@@ -595,15 +624,14 @@ question_module_server_impl <- function(
# submit question to server
event_trigger(
session = session,
- event = "question_submission",
- data = list(
- label = as.character(question$label),
+ event = "question_submission",
+ data = list(
+ label = as.character(question$label),
question = as.character(question$question),
- answer = as.character(input$answer),
- correct = is_correct_info()$correct
+ answer = as.character(input$answer),
+ correct = is_correct_info()$correct
)
)
-
})
observe({
@@ -619,9 +647,15 @@ question_module_server_impl <- function(
}
-
-question_button_label <- function(question, label_type = "submit", is_valid = TRUE) {
- label_type <- match.arg(label_type, c("submit", "try_again", "correct", "incorrect"))
+question_button_label <- function(
+ question,
+ label_type = "submit",
+ is_valid = TRUE
+) {
+ label_type <- match.arg(
+ label_type,
+ c("submit", "try_again", "correct", "incorrect")
+ )
if (label_type %in% c("correct", "incorrect")) {
# No button when answer is correct or incorrect (wrong without try again)
@@ -638,7 +672,8 @@ question_button_label <- function(question, label_type = "submit", is_valid = TR
if (label_type == "submit") {
button <- actionButton(
- action_button_id, button_label,
+ action_button_id,
+ button_label,
class = default_class
)
if (!is_valid) {
@@ -648,7 +683,8 @@ question_button_label <- function(question, label_type = "submit", is_valid = TR
} else if (label_type == "try_again") {
mutate_tags(
actionButton(
- action_button_id, button_label,
+ action_button_id,
+ button_label,
class = warning_class
),
paste0("#", action_button_id),
@@ -661,7 +697,6 @@ question_button_label <- function(question, label_type = "submit", is_valid = TR
}
question_messages <- function(question, messages, is_correct, is_done) {
-
# Always display the incorrect, correct, or try again messages
default_message <-
if (is_correct) {
@@ -699,7 +734,13 @@ question_messages <- function(question, messages, is_correct, is_done) {
if (length(messages) > 1) {
# add breaks inbetween similar messages
break_tag <- list(tags$br(), tags$br())
- all_messages <- replicate(length(messages) * 2 - 1, {break_tag}, simplify = FALSE)
+ all_messages <- replicate(
+ length(messages) * 2 - 1,
+ {
+ break_tag
+ },
+ simplify = FALSE
+ )
# store in all _odd_ positions
all_messages[(seq_along(messages) * 2) - 1] <- messages
messages <- tagList(all_messages)
@@ -710,7 +751,6 @@ question_messages <- function(question, messages, is_correct, is_done) {
)
}
-
if (is.null(question$messages$message)) {
always_message_alert <- NULL
} else {
@@ -731,11 +771,13 @@ question_messages <- function(question, messages, is_correct, is_done) {
}
# set UI message
- if (all(
- is.null(message_alert),
- is.null(always_message_alert),
- is.null(post_alert)
- )) {
+ if (
+ all(
+ is.null(message_alert),
+ is.null(always_message_alert),
+ is.null(post_alert)
+ )
+ ) {
NULL
} else {
htmltools::tagList(message_alert, always_message_alert, post_alert)
@@ -753,7 +795,9 @@ question_ui_loading <- function(question) {
})
q_opts <- NULL
- if (length(intersect(question$type, c("learnr_radio", "learnr_checkbox"))) > 0) {
+ if (
+ length(intersect(question$type, c("learnr_radio", "learnr_checkbox"))) > 0
+ ) {
q_opts <- htmltools::tags$ul(
lapply(seq_along(question$answers), function(...) {
htmltools::tags$li(
@@ -779,7 +823,6 @@ question_ui_loading <- function(question) {
}
-
withLearnrMathJax <- function(...) {
htmltools::tagList(
...,
diff --git a/R/quiz_print.R b/R/quiz_print.R
index 12b1825e4..cbbdf5035 100644
--- a/R/quiz_print.R
+++ b/R/quiz_print.R
@@ -23,12 +23,18 @@
#' )
#' cat(format(ex_question), "\n")
format.tutorial_question_answer <- function(x, ..., spacing = "") {
- correct_label <- if (is.null(x$correct)) "?" else ifelse(x$correct, "\u2714", "X")
+ correct_label <- if (is.null(x$correct)) {
+ "?"
+ } else {
+ ifelse(x$correct, "\u2714", "X")
+ }
paste0(
spacing,
correct_label,
": ",
- "\"", x$label, "\"",
+ "\"",
+ x$label,
+ "\"",
if (!is.null(x$message)) paste0("; \"", x$message, "\"")
)
}
@@ -46,29 +52,68 @@ format.tutorial_question <- function(x, ..., spacing = "") {
if (length(x$options) > 0) {
paste0(
"\n",
- spacing, " Options:\n",
- paste0(mapply(SIMPLIFY = FALSE, names(x$options), x$options, FUN = function(name, val) {
- paste0(spacing, " ", name, ": ", quote_chars(val))
- }), collapse = "\n")
+ spacing,
+ " Options:\n",
+ paste0(
+ mapply(
+ SIMPLIFY = FALSE,
+ names(x$options),
+ x$options,
+ FUN = function(name, val) {
+ paste0(spacing, " ", name, ": ", quote_chars(val))
+ }
+ ),
+ collapse = "\n"
+ )
)
} else {
NULL
}
# x$label belongs to the knitr label
paste0(
- spacing, "Question: \"", x$question, "\"\n",
+ spacing,
+ "Question: \"",
+ x$question,
+ "\"\n",
# all for a type vector
- spacing, " type: ", paste0("\"", x$type, "\"", sep = "", collapse = ", "), "\n",
- spacing, " allow_retry: ", x$allow_retry, "\n",
- spacing, " random_answer_order: ", x$random_answer_order, "\n",
- spacing, " answers:\n",
- paste0(lapply(x$answers, format, spacing = paste0(spacing, " ")), collapse = "\n"), "\n",
- spacing, " messages:\n",
- spacing, " correct: \"", x$messages$correct, "\"\n",
- spacing, " incorrect: \"", x$messages$incorrect, "\"",
- if (x$allow_retry) paste0("\n", spacing, " try_again: \"", x$messages$try_again, "\""),
- if (!is.null(x$messages$message)) paste0("\n", spacing, " message: \"", x$messages$message, "\""),
- if (!is.null(x$messages$post_message)) paste0("\n", spacing, " message: \"", x$messages$post_message, "\""),
+ spacing,
+ " type: ",
+ paste0("\"", x$type, "\"", sep = "", collapse = ", "),
+ "\n",
+ spacing,
+ " allow_retry: ",
+ x$allow_retry,
+ "\n",
+ spacing,
+ " random_answer_order: ",
+ x$random_answer_order,
+ "\n",
+ spacing,
+ " answers:\n",
+ paste0(
+ lapply(x$answers, format, spacing = paste0(spacing, " ")),
+ collapse = "\n"
+ ),
+ "\n",
+ spacing,
+ " messages:\n",
+ spacing,
+ " correct: \"",
+ x$messages$correct,
+ "\"\n",
+ spacing,
+ " incorrect: \"",
+ x$messages$incorrect,
+ "\"",
+ if (x$allow_retry) {
+ paste0("\n", spacing, " try_again: \"", x$messages$try_again, "\"")
+ },
+ if (!is.null(x$messages$message)) {
+ paste0("\n", spacing, " message: \"", x$messages$message, "\"")
+ },
+ if (!is.null(x$messages$post_message)) {
+ paste0("\n", spacing, " message: \"", x$messages$post_message, "\"")
+ },
options
)
}
@@ -76,7 +121,9 @@ format.tutorial_question <- function(x, ..., spacing = "") {
#' @rdname format_quiz
format.tutorial_quiz <- function(x, ...) {
paste0(
- "Quiz: \"", x$caption, "\"\n",
+ "Quiz: \"",
+ x$caption,
+ "\"\n",
"\n",
paste0(lapply(x$questions, format, spacing = " "), collapse = "\n\n")
)
diff --git a/R/run.R b/R/run.R
index 80126fd88..edc67df35 100644
--- a/R/run.R
+++ b/R/run.R
@@ -48,8 +48,18 @@ run_tutorial <- function(
as_rstudio_job = NULL
) {
rlang::check_dots_empty()
- checkmate::assert_character(name, any.missing = FALSE, max.len = 1, null.ok = TRUE)
- checkmate::assert_character(package, any.missing = FALSE, max.len = 1, null.ok = TRUE)
+ checkmate::assert_character(
+ name,
+ any.missing = FALSE,
+ max.len = 1,
+ null.ok = TRUE
+ )
+ checkmate::assert_character(
+ package,
+ any.missing = FALSE,
+ max.len = 1,
+ null.ok = TRUE
+ )
if (is.null(name)) {
tutorials <- available_tutorials(package = package)
@@ -100,40 +110,46 @@ run_tutorial <- function(
}
render_args <-
- tryCatch({
- local({
- # try to save a file to check for write permissions
- tmp_save_file <- file.path(tutorial$dir, "__learnr_test_file")
- # make sure it's deleted
- on.exit({
- if (file.exists(tmp_save_file)) {
- unlink(tmp_save_file)
- }
- }, add = TRUE)
- # write to the test file
- suppressWarnings(cat("test", file = tmp_save_file))
- # if no errors have occurred, return an empty list of render_args
- list()
- })
- }, error = function(e) {
- # Could not write in the tutorial folder
- message(
- "Rendering tutorial in a temp folder since `learnr` does not have write permissions in the tutorial folder: ",
- tutorial$dir
- )
-
- # Set rmarkdown args to render in tmp dir
- # This will cause the tutorial to be re-rendered in each R session
- temp_output_dir <- file.path(tempdir(), "learnr", package, name)
- if (!dir.exists(temp_output_dir)) {
- dir.create(temp_output_dir, recursive = TRUE)
+ tryCatch(
+ {
+ local({
+ # try to save a file to check for write permissions
+ tmp_save_file <- file.path(tutorial$dir, "__learnr_test_file")
+ # make sure it's deleted
+ on.exit(
+ {
+ if (file.exists(tmp_save_file)) {
+ unlink(tmp_save_file)
+ }
+ },
+ add = TRUE
+ )
+ # write to the test file
+ suppressWarnings(cat("test", file = tmp_save_file))
+ # if no errors have occurred, return an empty list of render_args
+ list()
+ })
+ },
+ error = function(e) {
+ # Could not write in the tutorial folder
+ message(
+ "Rendering tutorial in a temp folder since `learnr` does not have write permissions in the tutorial folder: ",
+ tutorial$dir
+ )
+
+ # Set rmarkdown args to render in tmp dir
+ # This will cause the tutorial to be re-rendered in each R session
+ temp_output_dir <- file.path(tempdir(), "learnr", package, name)
+ if (!dir.exists(temp_output_dir)) {
+ dir.create(temp_output_dir, recursive = TRUE)
+ }
+ list(
+ output_dir = temp_output_dir,
+ intermediates_dir = temp_output_dir,
+ knit_root_dir = temp_output_dir
+ )
}
- list(
- output_dir = temp_output_dir,
- intermediates_dir = temp_output_dir,
- knit_root_dir = temp_output_dir
- )
- })
+ )
if (isTRUE(clean)) {
run_clean_tutorial_prerendered(tutorial$dir)
@@ -151,7 +167,12 @@ run_tutorial <- function(
# is currently running in a server, do not allow for prerender (rmarkdown::render)
withr::local_envvar(c(RMARKDOWN_RUN_PRERENDER = "0"))
}
- rmarkdown::run(file = tutorial$file, dir = tutorial$dir, shiny_args = shiny_args, render_args = render_args)
+ rmarkdown::run(
+ file = tutorial$file,
+ dir = tutorial$dir,
+ shiny_args = shiny_args,
+ render_args = render_args
+ )
})
}
@@ -162,12 +183,22 @@ run_stop_invalid_name <- function(name = NULL, package = NULL, n_parent = 1) {
name
)
} else if (!is.null(name)) {
- sprintf("'%s' is not the name of a tutorial in the package '%s'.", name, package)
+ sprintf(
+ "'%s' is not the name of a tutorial in the package '%s'.",
+ name,
+ package
+ )
} else {
"When `package` is provided, `name` must be the name of a tutorial in the package. Otherwise `name` is the path to a tutorial or the path to a directory containing a tutorial."
}
if (!is.null(package)) {
- msg <- paste(msg, sprintf("Use `learnr::run_tutorial(package = \"%s\")` to list available tutorials in this package.", package))
+ msg <- paste(
+ msg,
+ sprintf(
+ "Use `learnr::run_tutorial(package = \"%s\")` to list available tutorials in this package.",
+ package
+ )
+ )
}
stop(errorCondition(msg, call = sys.call(which = n_parent)))
}
@@ -187,7 +218,9 @@ run_validate_tutorial_path <- function(path = NULL) {
}
run_validate_tutorial_dir <- function(path = NULL) {
- if (is.null(path)) return(list(valid = FALSE, dir = NULL))
+ if (is.null(path)) {
+ return(list(valid = FALSE, dir = NULL))
+ }
# remove trailing slash, otherwise file.exists() returns FALSE on Windows
# even if the directory exits. At this point we want to check that the input
@@ -204,7 +237,12 @@ run_validate_tutorial_dir <- function(path = NULL) {
run_validate_tutorial_file <- function(path) {
# A tutorial is valid if it's a scalar path to a single existing file that is a shiny rmd
- is_valid <- checkmate::test_character(path, len = 1, null.ok = FALSE, any.missing = FALSE) &&
+ is_valid <- checkmate::test_character(
+ path,
+ len = 1,
+ null.ok = FALSE,
+ any.missing = FALSE
+ ) &&
utils::file_test("-f", path) &&
run_check_is_shiny_rmd(path)
@@ -262,7 +300,10 @@ run_find_tutorial_rmd <- function(path, stop_if_not = FALSE) {
if (length(rmds) == 0) {
if (isTRUE(stop_if_not)) {
- stop.("No `shiny_prerenderd` or `shinyrmd` R Markdown files found in the directory ", path)
+ stop.(
+ "No `shiny_prerenderd` or `shinyrmd` R Markdown files found in the directory ",
+ path
+ )
}
return(NULL)
}
@@ -280,8 +321,10 @@ run_find_tutorial_rmd <- function(path, stop_if_not = FALSE) {
stop.(
"Unable to determine which of multiple R Markdown files is the primary app. ",
"Name the primary app `index` with extension `.Rmd` or `.qmd`.",
- "\ndirectory: ", path,
- "\n rmds: ", paste(rmds, collapse = ", ")
+ "\ndirectory: ",
+ path,
+ "\n rmds: ",
+ paste(rmds, collapse = ", ")
)
}
@@ -294,18 +337,21 @@ run_clean_tutorial_prerendered <- function(path) {
return(FALSE)
}
- tryCatch({
- rmarkdown::shiny_prerendered_clean(file.path(path, rmd))
- TRUE
- }, error = function(err) {
- msg <- sprintf(
- 'Could not clean shiny prerendered content. Error found while running `rmarkdown::shiny_prerendered_clean("%s")`:\n%s',
- file.path(path, rmd),
- conditionMessage(err)
- )
- message(msg)
- FALSE
- })
+ tryCatch(
+ {
+ rmarkdown::shiny_prerendered_clean(file.path(path, rmd))
+ TRUE
+ },
+ error = function(err) {
+ msg <- sprintf(
+ 'Could not clean shiny prerendered content. Error found while running `rmarkdown::shiny_prerendered_clean("%s")`:\n%s',
+ file.path(path, rmd),
+ conditionMessage(err)
+ )
+ message(msg)
+ FALSE
+ }
+ )
}
@@ -411,12 +457,18 @@ can_run_rstudio_job <- function(stop_if_not = FALSE) {
}
has_needed_pkgs <- vapply(
- c("rstudioapi", "httpuv"), requireNamespace, logical(1), quietly = TRUE
+ c("rstudioapi", "httpuv"),
+ requireNamespace,
+ logical(1),
+ quietly = TRUE
)
if (any(!has_needed_pkgs)) {
if (isTRUE(stop_if_not)) {
- rlang::check_installed(c("rstudioapi", "httpuv"), "Required to run a tutorial as an RStudio job")
+ rlang::check_installed(
+ c("rstudioapi", "httpuv"),
+ "Required to run a tutorial as an RStudio job"
+ )
}
return(FALSE)
}
@@ -425,7 +477,12 @@ can_run_rstudio_job <- function(stop_if_not = FALSE) {
rstudioapi::hasFun("runScriptJob")
}
-run_tutorial_as_job <- function(name, package = NULL, shiny_args = list(), clean = FALSE) {
+run_tutorial_as_job <- function(
+ name,
+ package = NULL,
+ shiny_args = list(),
+ clean = FALSE
+) {
if (!can_run_rstudio_job() || !requireNamespace("httpuv", quietly = TRUE)) {
stop("Cannot run tutorial as RStudio job")
}
@@ -436,18 +493,24 @@ run_tutorial_as_job <- function(name, package = NULL, shiny_args = list(), clean
shiny_args$launch.browser <- function(url) {
message("\n+", strrep("-", getOption("width", 60) * 0.9), "+")
- tryCatch({
- job_call_parent <- function(expr) {
- expr <- rlang::parse_expr(expr)
- utils::getFromNamespace("callRemote", "rstudioapi")(expr, .GlobalEnv)
+ tryCatch(
+ {
+ job_call_parent <- function(expr) {
+ expr <- rlang::parse_expr(expr)
+ utils::getFromNamespace("callRemote", "rstudioapi")(expr, .GlobalEnv)
+ }
+ job_call_parent(
+ sprintf(
+ 'getOption("shiny.launch.browser", utils::browseURL)("%s")',
+ url
+ )
+ )
+ message("\u2713 Opened tutorial available at ", url)
+ },
+ error = function(e) {
+ message("\u2713 Open the tutorial in your browser: ", url)
}
- job_call_parent(
- sprintf('getOption("shiny.launch.browser", utils::browseURL)("%s")', url)
- )
- message("\u2713 Opened tutorial available at ", url)
- }, error = function(e) {
- message("\u2713 Open the tutorial in your browser: ", url)
- })
+ )
message("! Stop or cancel this job to stop running the tutorial")
message("+", strrep("-", getOption("width", 60) * 0.9), "+\n")
}
diff --git a/R/storage.R b/R/storage.R
index 78d402b0f..cac1ce4f8 100644
--- a/R/storage.R
+++ b/R/storage.R
@@ -1,51 +1,66 @@
-
-
save_question_submission <- function(session, label, question, answer) {
save_object(
session = session,
object_id = label,
- tutorial_object("question_submission", list(
- api_version = 1,
- question = question,
- answer = answer
- ))
+ tutorial_object(
+ "question_submission",
+ list(
+ api_version = 1,
+ question = question,
+ answer = answer
+ )
+ )
)
}
save_reset_question_submission <- function(session, label, question) {
save_object(
session = session,
object_id = label,
- tutorial_object("question_submission", list(
- question = question,
- reset = TRUE
- ))
+ tutorial_object(
+ "question_submission",
+ list(
+ question = question,
+ reset = TRUE
+ )
+ )
)
}
-save_exercise_submission <- function(session, label, code, output, error_message, checked, feedback) {
-
+save_exercise_submission <- function(
+ session,
+ label,
+ code,
+ output,
+ error_message,
+ checked,
+ feedback
+) {
# for client storage we only forward error output. this is because we want
# to replay errors back into the client with no execution (in case they were
# timeout errors as a result of misbehaving code). for other outputs the client
# will just tickle the inputs to force re-execution of the outputs.
storage <- tutorial_storage(session)
if (identical(storage$type, "client")) {
- if (!is.null(error_message) && !identical(error_message, ""))
+ if (!is.null(error_message) && !identical(error_message, "")) {
output <- error_message_html(error_message)
- else
+ } else {
output <- NULL
+ }
}
# save object
save_object(
session = session,
object_id = label,
- tutorial_object("exercise_submission", list(
- code = code,
- output = output,
- checked = checked,
- feedback = feedback
- ))
+ tutorial_object(
+ "exercise_submission",
+ list(
+ code = code,
+ output = output,
+ checked = checked,
+ feedback = feedback
+ )
+ )
)
}
@@ -62,10 +77,13 @@ save_video_progress <- function(session, video_url, time, total_time) {
save_object(
session = session,
object_id = video_url,
- tutorial_object("video_progress", list(
- time = time,
- total_time = total_time
- ))
+ tutorial_object(
+ "video_progress",
+ list(
+ time = time,
+ total_time = total_time
+ )
+ )
)
}
@@ -81,10 +99,11 @@ save_client_state <- function(session, data) {
get_client_state <- function(session) {
object <- get_object(session, client_state_object_id)
- if (!is.null(object))
+ if (!is.null(object)) {
object$data
- else
+ } else {
list()
+ }
}
get_exercise_submission <- function(session, label) {
@@ -93,7 +112,6 @@ get_exercise_submission <- function(session, label) {
get_all_state_objects <- function(session, exercise_output = TRUE) {
-
# get all of the objects
objects <- get_objects(session)
@@ -118,7 +136,10 @@ filter_state_objects <- function(state_objects, types) {
}
submissions_from_state_objects <- function(state_objects) {
- filtered_submissions <- filter_state_objects(state_objects, c("question_submission", "exercise_submission"))
+ filtered_submissions <- filter_state_objects(
+ state_objects,
+ c("question_submission", "exercise_submission")
+ )
Filter(x = filtered_submissions, function(object) {
# only return answered question, not reset questions
if (object$type == "question_submission") {
@@ -139,7 +160,6 @@ section_skipped_progress_from_state_objects <- function(state_objects) {
progress_events_from_state_objects <- function(state_objects) {
-
# first submissions
submissions <- submissions_from_state_objects(state_objects)
progress_events <- lapply(submissions, function(submission) {
@@ -148,38 +168,46 @@ progress_events_from_state_objects <- function(state_objects) {
)
if (submission$type == "question_submission") {
data$answer <- submission$data$answer
- }
- else if (submission$type == "exercise_submission") {
- if (!is.null(submission$data$feedback))
+ } else if (submission$type == "exercise_submission") {
+ if (!is.null(submission$data$feedback)) {
correct <- submission$data$feedback$correct
- else
+ } else {
correct <- TRUE
+ }
data$correct <- correct
}
- list(event = submission$type,
- data = data)
+ list(event = submission$type, data = data)
})
# now sections skipped
- section_skipped_progress <- section_skipped_progress_from_state_objects(state_objects)
- section_skipped_progress_events <- lapply(section_skipped_progress, function(skipped) {
- list(event = "section_skipped",
- data = list(
- sectionId = ns_unwrap("section_skipped", skipped$id)
- ))
- })
+ section_skipped_progress <- section_skipped_progress_from_state_objects(
+ state_objects
+ )
+ section_skipped_progress_events <- lapply(
+ section_skipped_progress,
+ function(skipped) {
+ list(
+ event = "section_skipped",
+ data = list(
+ sectionId = ns_unwrap("section_skipped", skipped$id)
+ )
+ )
+ }
+ )
progress_events <- append(progress_events, section_skipped_progress_events)
# now video_progress
video_progress <- video_progress_from_state_objects(state_objects)
video_progress_events <- lapply(video_progress, function(progress) {
- list(event = "video_progress",
- data = list(
- video_url = progress$id,
- time = progress$data$time,
- total_time = progress$data$total_time
- ))
+ list(
+ event = "video_progress",
+ data = list(
+ video_url = progress$id,
+ time = progress$data$time,
+ total_time = progress$data$total_time
+ )
+ )
})
progress_events <- append(progress_events, video_progress_events)
@@ -192,7 +220,13 @@ save_object <- function(session, object_id, data) {
tutorial_version <- read_request(session, "tutorial.tutorial_version")
user_id <- read_request(session, "tutorial.user_id")
data$id <- object_id
- tutorial_storage(session)$save_object(tutorial_id, tutorial_version, user_id, object_id, data)
+ tutorial_storage(session)$save_object(
+ tutorial_id,
+ tutorial_version,
+ user_id,
+ object_id,
+ data
+ )
}
@@ -221,7 +255,12 @@ get_object <- function(session, object_id) {
tutorial_id <- read_request(session, "tutorial.tutorial_id")
tutorial_version <- read_request(session, "tutorial.tutorial_version")
user_id <- read_request(session, "tutorial.user_id")
- object <- tutorial_storage(session)$get_object(tutorial_id, tutorial_version, user_id, object_id)
+ object <- tutorial_storage(session)$get_object(
+ tutorial_id,
+ tutorial_version,
+ user_id,
+ object_id
+ )
update_object(object)
}
@@ -229,7 +268,11 @@ get_objects <- function(session) {
tutorial_id <- read_request(session, "tutorial.tutorial_id")
tutorial_version <- read_request(session, "tutorial.tutorial_version")
user_id <- read_request(session, "tutorial.user_id")
- objects <- tutorial_storage(session)$get_objects(tutorial_id, tutorial_version, user_id)
+ objects <- tutorial_storage(session)$get_objects(
+ tutorial_id,
+ tutorial_version,
+ user_id
+ )
lapply(objects, update_object)
}
@@ -237,17 +280,23 @@ remove_all_objects <- function(session) {
tutorial_id <- read_request(session, "tutorial.tutorial_id")
tutorial_version <- read_request(session, "tutorial.tutorial_version")
user_id <- read_request(session, "tutorial.user_id")
- tutorial_storage(session)$remove_all_objects(tutorial_id, tutorial_version, user_id)
+ tutorial_storage(session)$remove_all_objects(
+ tutorial_id,
+ tutorial_version,
+ user_id
+ )
}
initialize_objects_from_client <- function(session, objects) {
tutorial_id <- read_request(session, "tutorial.tutorial_id")
tutorial_version <- read_request(session, "tutorial.tutorial_version")
user_id <- read_request(session, "tutorial.user_id")
- client_storage(session)$initialize_objects_from_client(tutorial_id,
- tutorial_version,
- user_id,
- objects)
+ client_storage(session)$initialize_objects_from_client(
+ tutorial_id,
+ tutorial_version,
+ user_id,
+ objects
+ )
}
# helper to form a tutor object (type + data)
@@ -269,7 +318,6 @@ ns_unwrap <- function(ns, id) {
# get the currently active storage handler
tutorial_storage <- function(session) {
-
# local storage implementation
local_storage <- filesystem_storage(
file.path(rappdirs::user_data_dir(), "R", "learnr", "tutorial", "storage")
@@ -283,22 +331,25 @@ tutorial_storage <- function(session) {
return(no_storage())
}
location <- read_request(session, "tutorial.http_location")
- if (is_localhost(location))
+ if (is_localhost(location)) {
local_storage
- else
+ } else {
client_storage(session)
+ }
}
# examine the option
storage <- getOption("tutorial.storage", default = "auto")
# resolve NULL to "none"
- if (is.null(storage))
+ if (is.null(storage)) {
storage <- "none"
+ }
# if it's a character vector then resolve it
if (is.character(storage)) {
- storage <- switch(storage,
+ storage <- switch(
+ storage,
auto = auto_storage(),
local = local_storage,
client = client_storage(session),
@@ -307,17 +358,23 @@ tutorial_storage <- function(session) {
}
# verify that storage is a list
- if (!is.list(storage))
- stop("tutorial.storage must be a 'auto', 'local', 'client', 'none' or a ",
- "list of storage functions")
+ if (!is.list(storage)) {
+ stop(
+ "tutorial.storage must be a 'auto', 'local', 'client', 'none' or a ",
+ "list of storage functions"
+ )
+ }
# validate storage interface
- if (is.null(storage$save_object))
+ if (is.null(storage$save_object)) {
stop("tutorial.storage must implement the save_object function")
- if (is.null(storage$get_object))
+ }
+ if (is.null(storage$get_object)) {
stop("tutorial.storage must implement the get_object function")
- if (is.null(storage$get_objects))
+ }
+ if (is.null(storage$get_objects)) {
stop("tutorial.storage must implements the get_objects function")
+ }
# return it
storage
@@ -337,7 +394,6 @@ tutorial_storage <- function(session) {
#'
#' @export
filesystem_storage <- function(dir, compress = TRUE) {
-
# helpers to transform ids into valid filesystem paths
id_to_filesystem_path <- function(id) {
id <- gsub("..", "", id, fixed = TRUE)
@@ -349,39 +405,55 @@ filesystem_storage <- function(dir, compress = TRUE) {
# get the path to storage (ensuring that the directory exists)
storage_path <- function(tutorial_id, tutorial_version, user_id) {
- path <- file.path(dir,
- id_to_filesystem_path(user_id),
- id_to_filesystem_path(tutorial_id),
- id_to_filesystem_path(tutorial_version))
- if (!utils::file_test("-d", path))
+ path <- file.path(
+ dir,
+ id_to_filesystem_path(user_id),
+ id_to_filesystem_path(tutorial_id),
+ id_to_filesystem_path(tutorial_version)
+ )
+ if (!utils::file_test("-d", path)) {
dir.create(path, recursive = TRUE)
+ }
path
}
# functions which implement storage via saving to RDS
list(
-
type = "local",
- save_object = function(tutorial_id, tutorial_version, user_id, object_id, data) {
- object_path <- file.path(storage_path(tutorial_id, tutorial_version, user_id),
- paste0(id_to_filesystem_path(object_id), ".rds"))
+ save_object = function(
+ tutorial_id,
+ tutorial_version,
+ user_id,
+ object_id,
+ data
+ ) {
+ object_path <- file.path(
+ storage_path(tutorial_id, tutorial_version, user_id),
+ paste0(id_to_filesystem_path(object_id), ".rds")
+ )
saveRDS(data, file = object_path, compress = compress)
},
get_object = function(tutorial_id, tutorial_version, user_id, object_id) {
- object_path <- file.path(storage_path(tutorial_id, tutorial_version, user_id),
- paste0(id_to_filesystem_path(object_id), ".rds"))
- if (file.exists(object_path))
+ object_path <- file.path(
+ storage_path(tutorial_id, tutorial_version, user_id),
+ paste0(id_to_filesystem_path(object_id), ".rds")
+ )
+ if (file.exists(object_path)) {
readRDS(object_path)
- else
+ } else {
NULL
+ }
},
get_objects = function(tutorial_id, tutorial_version, user_id) {
objects_path <- storage_path(tutorial_id, tutorial_version, user_id)
objects <- list()
- for (object_path in list.files(objects_path, pattern = utils::glob2rx("*.rds"))) {
+ for (object_path in list.files(
+ objects_path,
+ pattern = utils::glob2rx("*.rds")
+ )) {
object <- readRDS(file.path(objects_path, object_path))
object_id <- sub("\\.rds$", "", id_from_filesystem_path(object_path))
objects[[length(objects) + 1]] <- object
@@ -400,8 +472,6 @@ filesystem_storage <- function(dir, compress = TRUE) {
# this data is subsequently restored during initialize and stored in a per-session
# in memory table for retreival
client_storage <- function(session) {
-
-
# helper to form a unique tutorial context id (note that we don't utilize the user_id
# as there is no concept of server-side user in client_storage, user scope is 100%
# determined by connecting user agent)
@@ -411,7 +481,6 @@ client_storage <- function(session) {
# get a reference to the session object cache for a gvien tutorial context
object_store <- function(context_id) {
-
# create session objects on demand
session_objects <- read_request(session, "tutorial.session_objects")
if (is.null(session_objects)) {
@@ -420,8 +489,9 @@ client_storage <- function(session) {
}
# create entry for this context on demand
- if (!exists(context_id, envir = session_objects))
+ if (!exists(context_id, envir = session_objects)) {
assign(context_id, new.env(parent = emptyenv()), envir = session_objects)
+ }
store <- get(context_id, envir = session_objects)
# return reference to the store
@@ -429,11 +499,15 @@ client_storage <- function(session) {
}
list(
-
type = "client",
- save_object = function(tutorial_id, tutorial_version, user_id, object_id, data) {
-
+ save_object = function(
+ tutorial_id,
+ tutorial_version,
+ user_id,
+ object_id,
+ data
+ ) {
# save the object to our in-memory store
context_id <- tutorial_context_id(tutorial_id, tutorial_version)
store <- object_store(context_id)
@@ -442,28 +516,33 @@ client_storage <- function(session) {
assign(object_id, data, envir = store)
# broadcast to client
- session$sendCustomMessage("tutorial.store_object", list(
- context = context_id,
- id = object_id,
- data = base64_enc(serialize(data, connection = NULL))
- ))
+ session$sendCustomMessage(
+ "tutorial.store_object",
+ list(
+ context = context_id,
+ id = object_id,
+ data = base64_enc(serialize(data, connection = NULL))
+ )
+ )
},
get_object = function(tutorial_id, tutorial_version, user_id, object_id) {
context_id <- tutorial_context_id(tutorial_id, tutorial_version)
store <- object_store(context_id)
- if (exists(object_id, envir = store))
+ if (exists(object_id, envir = store)) {
get(object_id, envir = store)
- else
+ } else {
NULL
+ }
},
get_objects = function(tutorial_id, tutorial_version, user_id) {
context_id <- tutorial_context_id(tutorial_id, tutorial_version)
store <- object_store(context_id)
objects <- list()
- for (object in ls(store))
+ for (object in ls(store)) {
objects[[length(objects) + 1]] <- get(object, envir = store)
+ }
objects
},
@@ -475,7 +554,12 @@ client_storage <- function(session) {
},
# function called from initialize to prime object storage from the browser db
- initialize_objects_from_client = function(tutorial_id, tutorial_version, user_id, objects) {
+ initialize_objects_from_client = function(
+ tutorial_id,
+ tutorial_version,
+ user_id,
+ objects
+ ) {
context_id <- tutorial_context_id(tutorial_id, tutorial_version)
store <- object_store(context_id)
for (object_id in names(objects)) {
@@ -491,9 +575,19 @@ client_storage <- function(session) {
no_storage <- function() {
list(
type = "none",
- save_object = function(tutorial_id, tutorial_version, user_id, object_id, data) {},
- get_object = function(tutorial_id, tutorial_version, user_id, object_id) { NULL },
- get_objects = function(tutorial_id, tutorial_version, user_id) { list() },
+ save_object = function(
+ tutorial_id,
+ tutorial_version,
+ user_id,
+ object_id,
+ data
+ ) {},
+ get_object = function(tutorial_id, tutorial_version, user_id, object_id) {
+ NULL
+ },
+ get_objects = function(tutorial_id, tutorial_version, user_id) {
+ list()
+ },
remove_all_objects = function(tutorial_id, tutorial_version, user_id) {}
)
}
diff --git a/R/tutorial-format.R b/R/tutorial-format.R
index 0ae485c54..dad909a9e 100644
--- a/R/tutorial-format.R
+++ b/R/tutorial-format.R
@@ -59,7 +59,6 @@ tutorial <- function(
lib_dir = NULL,
...
) {
-
if ("anchor_sections" %in% names(list(...))) {
stop("learnr tutorials do not support the `anchor_sections` option.")
}
@@ -74,27 +73,41 @@ tutorial <- function(
args <- c(args, "--reference-location=section")
# template
- args <- c(args, "--template", rmarkdown::pandoc_path_arg(
- system.file("rmarkdown/templates/tutorial/resources/tutorial-format.htm",
- package = "learnr")
- ))
+ args <- c(
+ args,
+ "--template",
+ rmarkdown::pandoc_path_arg(
+ system.file(
+ "rmarkdown/templates/tutorial/resources/tutorial-format.htm",
+ package = "learnr"
+ )
+ )
+ )
# content includes
args <- c(args, rmarkdown::includes_to_pandoc_args(includes))
# pagedtables
if (identical(df_print, "paged")) {
- extra_dependencies <- append(extra_dependencies,
- list(rmarkdown::html_dependency_pagedtable()))
+ extra_dependencies <- append(
+ extra_dependencies,
+ list(rmarkdown::html_dependency_pagedtable())
+ )
}
# highlight
- rmarkdown_pandoc_html_highlight_args <- getFromNamespace("pandoc_html_highlight_args", "rmarkdown")
+ rmarkdown_pandoc_html_highlight_args <- getFromNamespace(
+ "pandoc_html_highlight_args",
+ "rmarkdown"
+ )
rmarkdown_is_highlightjs <- getFromNamespace("is_highlightjs", "rmarkdown")
args <- c(args, rmarkdown_pandoc_html_highlight_args("default", highlight))
# add highlight.js html_dependency if required
if (rmarkdown_is_highlightjs(highlight)) {
- extra_dependencies <- append(extra_dependencies, list(rmarkdown::html_dependency_highlightjs(highlight)))
+ extra_dependencies <- append(
+ extra_dependencies,
+ list(rmarkdown::html_dependency_highlightjs(highlight))
+ )
}
# ace theme
@@ -114,17 +127,23 @@ tutorial <- function(
# tutorial_html_dependency() within our list of dependencies to ensure that
# tutorial.js (and the API it provides) is always loaded prior to our
# tutorial-format.js file.
- extra_dependencies <- append(extra_dependencies, list(
- tutorial_html_dependency(),
- tutorial_i18n_html_dependency(language),
- htmltools::htmlDependency(
- name = "tutorial-format",
- version = utils::packageVersion("learnr"),
- src = system.file("rmarkdown/templates/tutorial/resources", package = "learnr"),
- script = "tutorial-format.js",
- stylesheet = stylesheets
+ extra_dependencies <- append(
+ extra_dependencies,
+ list(
+ tutorial_html_dependency(),
+ tutorial_i18n_html_dependency(language),
+ htmltools::htmlDependency(
+ name = "tutorial-format",
+ version = utils::packageVersion("learnr"),
+ src = system.file(
+ "rmarkdown/templates/tutorial/resources",
+ package = "learnr"
+ ),
+ script = "tutorial-format.js",
+ stylesheet = stylesheets
+ )
)
- ))
+ )
# additional pandoc variables specific to learnr
jsbool <- function(value) ifelse(value, "true", "false")
@@ -132,15 +151,26 @@ tutorial <- function(
args,
rmarkdown::pandoc_variable_arg("progressive", jsbool(progressive)),
rmarkdown::pandoc_variable_arg("allow-skip", jsbool(allow_skip)),
- rmarkdown::pandoc_variable_arg("learnr-version", utils::packageVersion("learnr"))
+ rmarkdown::pandoc_variable_arg(
+ "learnr-version",
+ utils::packageVersion("learnr")
+ )
)
# knitr and pandoc options
- knitr_options <- rmarkdown::knitr_options_html(fig_width, fig_height, fig_retina, keep_md = FALSE , dev)
- pandoc_options <- rmarkdown::pandoc_options(to = "html4",
+ knitr_options <- rmarkdown::knitr_options_html(
+ fig_width,
+ fig_height,
+ fig_retina,
+ keep_md = FALSE,
+ dev
+ )
+ pandoc_options <- rmarkdown::pandoc_options(
+ to = "html4",
from = rmarkdown::from_rmarkdown(fig_caption, md_extensions),
args = args,
- ext = ".html")
+ ext = ".html"
+ )
tutorial_opts <- tutorial_knitr_options()
knitr_options <- utils::modifyList(knitr_options, tutorial_opts)
@@ -163,9 +193,11 @@ tutorial <- function(
)
# return new output format
- rmarkdown::output_format(knitr = knitr_options,
- pandoc = pandoc_options,
- clean_supporting = FALSE,
- df_print = df_print,
- base_format = base_format)
+ rmarkdown::output_format(
+ knitr = knitr_options,
+ pandoc = pandoc_options,
+ clean_supporting = FALSE,
+ df_print = df_print,
+ base_format = base_format
+ )
}
diff --git a/R/tutorial-state.R b/R/tutorial-state.R
index 045b17971..781d63836 100644
--- a/R/tutorial-state.R
+++ b/R/tutorial-state.R
@@ -15,7 +15,7 @@ store_tutorial_cache <- function(name, object, overwrite = FALSE) {
if (!overwrite && name %in% names(tutorial_cache_env$objects)) {
return(FALSE)
}
- if (is.null(object)){
+ if (is.null(object)) {
return(FALSE)
}
tutorial_cache_env$objects[[name]] <- object
@@ -59,7 +59,7 @@ store_exercise_cache <- function(exercise, overwrite = FALSE) {
}
# Return the exercise object from the cache for a given label
-get_exercise_cache <- function(label = NULL){
+get_exercise_cache <- function(label = NULL) {
exercises <- get_tutorial_cache(type = "exercise")
if (is.null(label)) {
return(exercises)
@@ -78,13 +78,13 @@ clear_exercise_setup_chunks <- clear_exercise_cache_env
# Questions ---------------------------------------------------------------
-store_question_cache <- function(question, overwrite = FALSE){
+store_question_cache <- function(question, overwrite = FALSE) {
label <- question$label
store_tutorial_cache(name = label, object = question, overwrite = overwrite)
}
# Return a list of knitr chunks for a given exercise label (exercise + setup chunks).
-get_question_cache <- function(label = NULL){
+get_question_cache <- function(label = NULL) {
questions <- get_tutorial_cache(type = "question")
if (is.null(label)) {
return(questions)
@@ -136,7 +136,10 @@ clear_question_cache_env <- function() {
#'
#' @seealso [get_tutorial_info()]
#' @export
-get_tutorial_state <- function(label = NULL, session = getDefaultReactiveDomain()) {
+get_tutorial_state <- function(
+ label = NULL,
+ session = getDefaultReactiveDomain()
+) {
object_labels <- names(get_tutorial_cache())
if (is.null(label)) {
state <- shiny::reactiveValuesToList(session$userData$tutorial_state)
@@ -146,7 +149,11 @@ get_tutorial_state <- function(label = NULL, session = getDefaultReactiveDomain(
}
}
-set_tutorial_state <- function(label, data, session = getDefaultReactiveDomain()) {
+set_tutorial_state <- function(
+ label,
+ data,
+ session = getDefaultReactiveDomain()
+) {
stopifnot(is.character(label))
if (is.reactive(data)) {
data <- data()
@@ -264,7 +271,9 @@ get_tutorial_info <- function(
}
tutorial_language <-
- if (is.list(metadata$output) && "learnr::tutorial" %in% names(metadata$output)) {
+ if (
+ is.list(metadata$output) && "learnr::tutorial" %in% names(metadata$output)
+ ) {
language_front_matter <- metadata$output[["learnr::tutorial"]]$language
# get default tutorial language from the yaml header
i18n_process_language_options(language_front_matter)$language
@@ -276,7 +285,8 @@ get_tutorial_info <- function(
key,
"tutorial.tutorial_id" = metadata$tutorial$id %||%
withr::with_dir(dirname(tutorial_path), default_tutorial_id()),
- "tutorial.tutorial_version" = metadata$tutorial$version %||% default_tutorial_version(),
+ "tutorial.tutorial_version" = metadata$tutorial$version %||%
+ default_tutorial_version(),
"tutorial.user_id" = default_user_id(),
"tutorial.language" = tutorial_language %||% default_language(),
NULL
@@ -296,8 +306,16 @@ get_tutorial_info <- function(
)
}
-get_tutorial_exercises <- function(tutorial_path, session = getDefaultReactiveDomain(), ...) {
- info <- get_tutorial_info(tutorial_path = tutorial_path, session = session, ...)
+get_tutorial_exercises <- function(
+ tutorial_path,
+ session = getDefaultReactiveDomain(),
+ ...
+) {
+ info <- get_tutorial_info(
+ tutorial_path = tutorial_path,
+ session = session,
+ ...
+ )
items_exercises <- info$items[info$items$type == "exercise", ]
ex <- items_exercises$data
names(ex) <- items_exercises$label
@@ -328,7 +346,9 @@ describe_tutorial_items <- function() {
)
for (i in seq_along(items[["data"]])) {
- if (items[["type"]][[i]] != "exercise") next
+ if (items[["type"]][[i]] != "exercise") {
+ next
+ }
label <- items[["label"]][[i]]
code_chunks <- Filter(
@@ -357,7 +377,10 @@ prepare_tutorial_cache_from_source <- function(path_rmd, render_args = NULL) {
# 3. Evaluate the prerendered code to populate the tutorial cache
# 4. Clean up files on exit
path_rmd <- normalizePath(path_rmd)
- path_html <- file.path(dirname(path_rmd), basename(tempfile(fileext = ".html")))
+ path_html <- file.path(
+ dirname(path_rmd),
+ basename(tempfile(fileext = ".html"))
+ )
# remove html and supporting files on exit
withr::defer({
@@ -403,7 +426,8 @@ prepare_tutorial_cache_from_html <- function(path_html, path_rmd = NULL) {
is_cache_chunk <- vapply(
prerendered_chunks,
function(x) {
- as.character(x[[1]])[3] %in% c("store_exercise_cache", "question_prerendered_chunk")
+ as.character(x[[1]])[3] %in%
+ c("store_exercise_cache", "question_prerendered_chunk")
},
logical(1)
)
@@ -433,7 +457,10 @@ prepare_tutorial_cache_from_html <- function(path_html, path_rmd = NULL) {
if (length(idx_metadata_chunk) > 0) {
idx_metadata_chunk <- idx_metadata_chunk[[1]]
env <- rlang::env(session = NULL)
- metadata <- eval(prerendered_chunks[idx_metadata_chunk][["metadata"]], envir = env)
+ metadata <- eval(
+ prerendered_chunks[idx_metadata_chunk][["metadata"]],
+ envir = env
+ )
}
assign("metadata", metadata, envir = tutorial_cache_env)
diff --git a/R/tutorial_package_dependencies.R b/R/tutorial_package_dependencies.R
index f59f2e332..c91afa250 100644
--- a/R/tutorial_package_dependencies.R
+++ b/R/tutorial_package_dependencies.R
@@ -1,5 +1,4 @@
get_needed_pkgs <- function(dir) {
-
pkgs <- tutorial_dir_package_dependencies(dir)
pkgs[!pkgs %in% utils::installed.packages()]
@@ -10,28 +9,31 @@ format_needed_pkgs <- function(needed_pkgs) {
}
ask_pkgs_install <- function(needed_pkgs) {
- question <- sprintf("Would you like to install the following packages?\n%s",
- format_needed_pkgs(needed_pkgs))
+ question <- sprintf(
+ "Would you like to install the following packages?\n%s",
+ format_needed_pkgs(needed_pkgs)
+ )
- utils::menu(choices = c("yes", "no"),
- title = question)
+ utils::menu(choices = c("yes", "no"), title = question)
}
install_tutorial_dependencies <- function(dir) {
needed_pkgs <- get_needed_pkgs(dir)
- if(length(needed_pkgs) == 0) {
+ if (length(needed_pkgs) == 0) {
return(invisible(NULL))
}
- if(!interactive()) {
- stop("The following packages need to be installed:\n",
- format_needed_pkgs(needed_pkgs))
+ if (!interactive()) {
+ stop(
+ "The following packages need to be installed:\n",
+ format_needed_pkgs(needed_pkgs)
+ )
}
answer <- ask_pkgs_install(needed_pkgs)
- if(answer == 2) {
+ if (answer == 2) {
stop("The tutorial is missing required packages and cannot be rendered.")
}
@@ -39,8 +41,6 @@ install_tutorial_dependencies <- function(dir) {
}
-
-
#' List tutorial dependencies
#'
#' List the \R packages required to run a particular tutorial.
diff --git a/R/utils.R b/R/utils.R
index bc1c1002e..85c5b89aa 100644
--- a/R/utils.R
+++ b/R/utils.R
@@ -9,15 +9,18 @@
# is_installed
is_localhost <- function(location) {
- if (is.null(location))
+ if (is.null(location)) {
# caused when using devtools::load_all(), which is a localhost
TRUE
- else if (location$hostname %in% c("localhost", "127.0.0.1"))
+ } else if (location$hostname %in% c("localhost", "127.0.0.1")) {
TRUE
- else if (nzchar(Sys.getenv("RSTUDIO")) && grepl("/p/\\d+/", location$pathname))
+ } else if (
+ nzchar(Sys.getenv("RSTUDIO")) && grepl("/p/\\d+/", location$pathname)
+ ) {
TRUE
- else
+ } else {
FALSE
+ }
}
stop. <- function(...) {
@@ -98,7 +101,7 @@ py_learnr_utilities <- function() {
}
learnr_py <- system.file("internals", "learnr.py", package = "learnr")
- reticulate::py_run_file(learnr_py,convert = FALSE)[["__learnr__"]]
+ reticulate::py_run_file(learnr_py, convert = FALSE)[["__learnr__"]]
}
#' This clears the Python environment `py`.
@@ -150,7 +153,6 @@ str_match <- function(x, pattern) {
if_no_match_return_null(
regmatches(x, regexpr(pattern, x))
)
-
}
str_match_all <- function(x, pattern, ...) {
if_no_match_return_null(
@@ -158,11 +160,15 @@ str_match_all <- function(x, pattern, ...) {
)
}
str_replace <- function(x, pattern, replacement) {
- if (is.null(x)) return(NULL)
+ if (is.null(x)) {
+ return(NULL)
+ }
sub(pattern, replacement, x)
}
str_replace_all <- function(x, pattern, replacement) {
- if (is.null(x)) return(NULL)
+ if (is.null(x)) {
+ return(NULL)
+ }
if (!is.null(names(pattern))) {
for (i in seq_along(pattern)) {
diff --git a/R/zzz.R b/R/zzz.R
index b85bc2cbf..4f2fc273c 100644
--- a/R/zzz.R
+++ b/R/zzz.R
@@ -1,4 +1,3 @@
-
# install knitr hooks when package is attached to search path
.onAttach <- function(libname, pkgname) {
install_knitr_hooks()
@@ -21,7 +20,6 @@
x
})
-
if ("shinytest2" %in% loadedNamespaces()) {
register_shinytest_inputprocessor()
}
diff --git a/data-raw/i18n_translations.R b/data-raw/i18n_translations.R
index 82f20a69a..669f0669f 100644
--- a/data-raw/i18n_translations.R
+++ b/data-raw/i18n_translations.R
@@ -13,7 +13,6 @@ library(stringi)
# from {stringi}. I've kept this function in the source in case we need to
# switch back to our previous method.
reencode_utf8 <- function(x) {
-
# Ensure that we encode non-UTF-8 strings to UTF-8 in a
# two-step process: (1) to native encoding, and then (2) to UTF-8
if (Encoding(x) != 'UTF-8') {
@@ -37,15 +36,22 @@ reencode_utf8 <- function(x) {
FUN.VALUE = character(1),
USE.NAMES = FALSE,
FUN = function(x) {
-
bytes_nz <- x[min(which(x > 0)):length(x)]
if (length(bytes_nz) > 2) {
out <- paste("\\U", paste(as.hexmode(x), collapse = ""), sep = "")
} else if (length(bytes_nz) > 1) {
- out <- paste("\\u", paste(as.hexmode(bytes_nz), collapse = ""), sep = "")
+ out <- paste(
+ "\\u",
+ paste(as.hexmode(bytes_nz), collapse = ""),
+ sep = ""
+ )
} else if (length(bytes_nz) == 1 && bytes_nz > 127) {
- out <- paste("\\u", sprintf("%04s", paste(as.hexmode(bytes_nz)), collapse = ""), sep = "")
+ out <- paste(
+ "\\u",
+ sprintf("%04s", paste(as.hexmode(bytes_nz)), collapse = ""),
+ sep = ""
+ )
} else {
out <- rawToChar(as.raw(bytes_nz))
}
@@ -58,7 +64,9 @@ reencode_utf8 <- function(x) {
}
# Read raw translations ----
-translations_yml <- yaml::read_yaml(here::here("data-raw/i18n_translations.yml"))
+translations_yml <- yaml::read_yaml(here::here(
+ "data-raw/i18n_translations.yml"
+))
# Validate that language keys appear for every translation key ----
translations_lang_keys <-
@@ -71,8 +79,13 @@ translations_lang_set <- translations_lang_keys %>% reduce(union) %>% sort()
iwalk(translations_lang_keys, function(langs, key) {
if (!identical(sort(langs), translations_lang_set)) {
- missing_keys <- paste(setdiff(translations_lang_set, langs), collapse = ", ")
- cli::cli_alert_warning("{.code {key}} is missing language(s): {missing_keys}")
+ missing_keys <- paste(
+ setdiff(translations_lang_set, langs),
+ collapse = ", "
+ )
+ cli::cli_alert_warning(
+ "{.code {key}} is missing language(s): {missing_keys}"
+ )
}
})
@@ -91,11 +104,19 @@ translations_list <-
# Drop null keys again
map_depth(3, compact)
-saveRDS(translations_list, file = here("inst", "internals", "i18n_translations.rds"), version = 2)
+saveRDS(
+ translations_list,
+ file = here("inst", "internals", "i18n_translations.rds"),
+ version = 2
+)
i18n_random_phrases <-
here("data-raw", "i18n_random-phrases.yml") %>%
yaml::read_yaml() %>%
map_depth(2, map_chr, stri_enc_toutf8, validate = TRUE)
-saveRDS(i18n_random_phrases, file = here("inst", "internals", "i18n_random_phrases.rds"), version = 2)
+saveRDS(
+ i18n_random_phrases,
+ file = here("inst", "internals", "i18n_random_phrases.rds"),
+ version = 2
+)
diff --git a/inst/examples/apparmor/apparmor_evaluator.R b/inst/examples/apparmor/apparmor_evaluator.R
index c84c678f5..242db09c9 100644
--- a/inst/examples/apparmor/apparmor_evaluator.R
+++ b/inst/examples/apparmor/apparmor_evaluator.R
@@ -1,4 +1,3 @@
-
# Note: To use the "r-user" AppArmor profile you should add the following line
# to /etc/apparmor.d/rapparmor.d/r-user:
#
@@ -6,33 +5,30 @@
#
options(tutorial.exercise.evaluator.onstart = function(pid) {
-
# import RAppArmor
require(RAppArmor, quietly = TRUE)
# set process group to pid (allows kill of entire subtree in cleanup)
- setpgid();
-
+ setpgid()
+
# set nice priority
setpriority(10)
-
+
# set rlimits as appropriate
rlimit_nproc(1000)
- rlimit_as(1024*1024*1024)
-
+ rlimit_as(1024 * 1024 * 1024)
+
# change to r-user profile (see note above on required edit to r-user)
aa_change_profile("r-user")
})
options(tutorial.exercise.evaluator.oncleanup = function(pid) {
-
# import RAppArmor
require(RAppArmor, quietly = TRUE)
-
+
# kill entire process subtree. note that the second call works
# because the call to setpgid above sets our pgid (process group id)
# to our pid (process id)
kill(pid, tools::SIGKILL)
kill(-1 * pid, tools::SIGKILL)
})
-
diff --git a/inst/staticexports/knitr_engine_caption.R b/inst/staticexports/knitr_engine_caption.R
index 59f094c92..0ef911810 100644
--- a/inst/staticexports/knitr_engine_caption.R
+++ b/inst/staticexports/knitr_engine_caption.R
@@ -1,4 +1,3 @@
-
knitr_engine_caption <- function(engine = NULL) {
if (is.null(engine)) {
engine <- "r"
diff --git a/inst/staticexports/strings.R b/inst/staticexports/strings.R
index 8c35af8bf..a7b43184b 100644
--- a/inst/staticexports/strings.R
+++ b/inst/staticexports/strings.R
@@ -1,4 +1,3 @@
-
str_trim <- function(x, side = "both", character = "\\s") {
if (side %in% c("both", "left", "start")) {
rgx <- sprintf("^%s+", character)
diff --git a/tests/testthat.R b/tests/testthat.R
index 566a3a16e..1186567ee 100644
--- a/tests/testthat.R
+++ b/tests/testthat.R
@@ -1,4 +1,3 @@
-
if (requireNamespace("testthat")) {
library(testthat)
library(learnr)
diff --git a/tests/testthat/helpers-shinytest2.R b/tests/testthat/helpers-shinytest2.R
index 903a2f6aa..36f49bfde 100644
--- a/tests/testthat/helpers-shinytest2.R
+++ b/tests/testthat/helpers-shinytest2.R
@@ -94,7 +94,7 @@ get_editor_value <- function(selector, ...) {
}
editor_has_focus <- function(selector, ...) {
- if (length(c(...))) {
+ if (length(c(...))) {
selector <- paste(selector, paste(c(...), collapse = " "))
}
sprintf(
@@ -169,7 +169,7 @@ app_real_click <- function(app, selector, ...) {
chrome$Input$dispatchMouseEvent(
type = event,
x = dims$left + dims$width / 2,
- y = dims$top + dims$height / 2,
+ y = dims$top + dims$height / 2,
clickCount = 1,
pointerType = "mouse",
button = "left",
@@ -187,41 +187,56 @@ if (!"expect" %in% names(shinytest2::AppDriver$public_methods)) {
# invisible(self)
# })
- shinytest2::AppDriver$set("public", "expect", function(name, object, expected, ...) {
- stopifnot(length(name) == 1)
- name <- tolower(name)
- if (identical(name, "succeed")) {
- testthat::succeed(...)
- return(invisible(self))
- }
-
- allowed_expectactions <- c(
- "null", "true", "equal", "match", "false", "length", "no_match", "setequal"
- )
+ shinytest2::AppDriver$set(
+ "public",
+ "expect",
+ function(name, object, expected, ...) {
+ stopifnot(length(name) == 1)
+ name <- tolower(name)
+ if (identical(name, "succeed")) {
+ testthat::succeed(...)
+ return(invisible(self))
+ }
- if (!name %in% allowed_expectactions) {
- rlang::abort(sprintf(
- "'%s' is not one of the supported expectations: %s",
- name,
- paste(allowed_expectactions, collapse = ", ")
- ))
- }
+ allowed_expectactions <- c(
+ "null",
+ "true",
+ "equal",
+ "match",
+ "false",
+ "length",
+ "no_match",
+ "setequal"
+ )
+
+ if (!name %in% allowed_expectactions) {
+ rlang::abort(sprintf(
+ "'%s' is not one of the supported expectations: %s",
+ name,
+ paste(allowed_expectactions, collapse = ", ")
+ ))
+ }
- dots <- list(...)
- self_mask <- rlang::new_data_mask(self)
+ dots <- list(...)
+ self_mask <- rlang::new_data_mask(self)
- if (!missing(object)) {
- object <- rlang::enquo(object)
- dots$object <- rlang::eval_tidy(object, self_mask)
- }
- if (!missing(expected)) {
- expected <- rlang::enquo(expected)
- dots$expected <- rlang::eval_tidy(expected, self_mask)
- }
+ if (!missing(object)) {
+ object <- rlang::enquo(object)
+ dots$object <- rlang::eval_tidy(object, self_mask)
+ }
+ if (!missing(expected)) {
+ expected <- rlang::enquo(expected)
+ dots$expected <- rlang::eval_tidy(expected, self_mask)
+ }
- call <- rlang::call2(.fn = paste0("expect_", name), !!!dots, .ns = "testthat")
- rlang::eval_bare(call)
+ call <- rlang::call2(
+ .fn = paste0("expect_", name),
+ !!!dots,
+ .ns = "testthat"
+ )
+ rlang::eval_bare(call)
- invisible(self)
- })
+ invisible(self)
+ }
+ )
}
diff --git a/tests/testthat/helpers.R b/tests/testthat/helpers.R
index 95d5d7ae3..3af383152 100644
--- a/tests/testthat/helpers.R
+++ b/tests/testthat/helpers.R
@@ -1,4 +1,3 @@
-
# https://github.com/rstudio/rmarkdown/blob/2faee0040a39008a47bdf1ba840bf402cba15a65/tests/testthat/helpers.R
skip_if_not_pandoc <- function(ver = NULL) {
@@ -25,15 +24,22 @@ skip_if_pandoc <- function(ver = NULL) {
skip_on_ci_if_not_pr <- function() {
# Don't skip locally
- if (!nzchar(Sys.getenv("CI", ""))) return()
+ if (!nzchar(Sys.getenv("CI", ""))) {
+ return()
+ }
# If on CI, don't skip if envvar set by workflow is present
- if (nzchar(Sys.getenv("CI_IN_PR", ""))) return()
+ if (nzchar(Sys.getenv("CI_IN_PR", ""))) {
+ return()
+ }
# If on CI and not in a PR branch workflow... skip these tests
skip("Skipping on CI, tests run in PR checks only")
}
skip_if_not_py_available <- function() {
- skip_if_not(reticulate::py_available(initialize = TRUE), "Python not available on this system")
+ skip_if_not(
+ reticulate::py_available(initialize = TRUE),
+ "Python not available on this system"
+ )
}
expect_marked_as <- function(object, correct, messages = NULL) {
diff --git a/tests/testthat/test-auto-complete.R b/tests/testthat/test-auto-complete.R
index a47aaa076..deb9d380b 100644
--- a/tests/testthat/test-auto-complete.R
+++ b/tests/testthat/test-auto-complete.R
@@ -1,14 +1,19 @@
test_that("R auto complete finds runif vars", {
-
expect_equal(auto_complete_r("this_variable_will_not_be_found"), list())
- expect_equal(auto_complete_r("runif"), list(
- list("runif", TRUE)
- ))
- expect_equal(auto_complete_r("runif("), list(
- list("n = ", FALSE),
- list("min = ", FALSE),
- list("max = ", FALSE)
- ))
+ expect_equal(
+ auto_complete_r("runif"),
+ list(
+ list("runif", TRUE)
+ )
+ )
+ expect_equal(
+ auto_complete_r("runif("),
+ list(
+ list("n = ", FALSE),
+ list("min = ", FALSE),
+ list("max = ", FALSE)
+ )
+ )
})
test_that("R auto completions are not added when the line is a comment or quotes", {
@@ -47,15 +52,21 @@ test_that("Local env overrides global env", {
# Find functions defined within the test env
expect_equal(auto_complete_r("test_runif", NULL, NULL), list())
- expect_equal(auto_complete_r("test_runif", NULL, test_env), list(
- list("test_runif", TRUE)
- ))
+ expect_equal(
+ auto_complete_r("test_runif", NULL, test_env),
+ list(
+ list("test_runif", TRUE)
+ )
+ )
# Find custom runif function in a label's env
expect_equal(auto_complete_r("custom_runif", NULL, NULL), list())
- expect_equal(auto_complete_r("custom_runif", "my_label", test_env), list(
- list("custom_runif", TRUE)
- ))
+ expect_equal(
+ auto_complete_r("custom_runif", "my_label", test_env),
+ list(
+ list("custom_runif", TRUE)
+ )
+ )
expect_equal(auto_complete_r("custom_runif", "other_label", test_env), list())
# # Auto complete currently (and previously) returned both the global and local runif parameters
@@ -82,7 +93,9 @@ test_that("detect_comments()", {
expect_false(detect_comment("paste('# not a comment')"))
expect_false(detect_comment("paste('# \'still\' # not a comment')"))
expect_false(detect_comment("paste('# \"still\" # not a comment')"))
- expect_true(detect_comment("paste('# \"still\" # not a comment') # is a comment"))
+ expect_true(detect_comment(
+ "paste('# \"still\" # not a comment') # is a comment"
+ ))
expect_false(detect_comment('" \' # "'))
expect_true(detect_comment('" \' # " # runif'))
diff --git a/tests/testthat/test-available-tutorials.R b/tests/testthat/test-available-tutorials.R
index 2d1493fb0..b8fb6d23a 100644
--- a/tests/testthat/test-available-tutorials.R
+++ b/tests/testthat/test-available-tutorials.R
@@ -1,4 +1,3 @@
-
context("available tutorials")
test_that("Tutorial names are retrieved", {
@@ -7,7 +6,9 @@ test_that("Tutorial names are retrieved", {
expect_error(available_tutorials("not a package"), "No package found")
expect_error(available_tutorials("base"), "No tutorials found")
expect_true("hello" %in% available_tutorials("learnr")$name)
- expect_true("hello" %in% suppressMessages(run_tutorial(package = "learnr")$name))
+ expect_true(
+ "hello" %in% suppressMessages(run_tutorial(package = "learnr")$name)
+ )
expect_s3_class(available_tutorials("learnr"), "learnr_available_tutorials")
expect_error(run_tutorial("helloo", package = "learnr"), "\"hello\"")
diff --git a/tests/testthat/test-cookies.R b/tests/testthat/test-cookies.R
index b08b3383b..5ca5c5478 100644
--- a/tests/testthat/test-cookies.R
+++ b/tests/testthat/test-cookies.R
@@ -1,7 +1,8 @@
context("cookies")
test_that("cookies are properly serialized", {
- cookies <- structure(list(
+ cookies <- structure(
+ list(
domain = c("httpbin.org", "httpbin.org"),
flag = c(FALSE, FALSE),
path = c("/", "/"),
@@ -11,10 +12,13 @@ test_that("cookies are properly serialized", {
value = c("123", "ftw")
),
row.names = c(NA, -2L),
- class = "data.frame")
+ class = "data.frame"
+ )
f <- tempfile()
- on.exit({unlink(f)})
+ on.exit({
+ unlink(f)
+ })
write_cookies(cookies, f)
txt <- readLines(f)
@@ -22,4 +26,3 @@ test_that("cookies are properly serialized", {
expect_equal(txt[1], "httpbin.org\tFALSE\t/\tFALSE\t1587586247\tfoo\t123")
expect_equal(txt[2], "httpbin.org\tFALSE\t/\tFALSE\t0\tbar\tftw")
})
-
diff --git a/tests/testthat/test-dependency.R b/tests/testthat/test-dependency.R
index 7c75d225b..077b23415 100644
--- a/tests/testthat/test-dependency.R
+++ b/tests/testthat/test-dependency.R
@@ -1,4 +1,3 @@
-
context("dependency")
test_that("tutor html dependencies can be retreived", {
diff --git a/tests/testthat/test-duplicate_env.R b/tests/testthat/test-duplicate_env.R
index fdf661187..87ddaed75 100644
--- a/tests/testthat/test-duplicate_env.R
+++ b/tests/testthat/test-duplicate_env.R
@@ -1,8 +1,6 @@
-
context("duplicate_env")
test_that("it duplicates", {
-
e <- new.env(parent = baseenv())
e$x <- 1
e$.key <- "value"
diff --git a/tests/testthat/test-evaluators.R b/tests/testthat/test-evaluators.R
index 8892cb58b..c828558bb 100644
--- a/tests/testthat/test-evaluators.R
+++ b/tests/testthat/test-evaluators.R
@@ -1,10 +1,16 @@
test_that("forked_evaluator works as expected", {
skip_on_cran()
- skip_if(is_windows(), message = "Skipping forked evaluator testing on Windows")
+ skip_if(
+ is_windows(),
+ message = "Skipping forked evaluator testing on Windows"
+ )
skip_if(is_mac(), message = "Skipping forked evaluator testing on macOS")
ex <- mock_exercise("Sys.sleep(1)\n1:100", check = I("last_value"))
- forked_eval_ex <- forked_evaluator_factory(evaluate_exercise(ex, new.env()), 2)
+ forked_eval_ex <- forked_evaluator_factory(
+ evaluate_exercise(ex, new.env()),
+ 2
+ )
# not yet started
expect_equal(forked_eval_ex$completed(), NA)
@@ -34,9 +40,9 @@ pool <- curl::new_pool(total_con = 5, host_con = 5)
# skip these tests which makes that more complicated.
# @param responses - a list indexed by ` ` which maps to an httpuv
# response. e.g. list(`GET /` = list(status = 200L, headers = list(), body = "OK"))
-start_server <- function(responses, quiet = TRUE){
+start_server <- function(responses, quiet = TRUE) {
srv <- NULL
- result <- new.env(parent=emptyenv())
+ result <- new.env(parent = emptyenv())
result$reqs <- NULL
result$port <- httpuv::randomPort()
@@ -45,7 +51,7 @@ start_server <- function(responses, quiet = TRUE){
cat("Starting server on port", result$port, "\n")
}
- req_to_id <- function(req){
+ req_to_id <- function(req) {
paste(req$REQUEST_METHOD, req$PATH_INFO)
}
@@ -56,15 +62,14 @@ start_server <- function(responses, quiet = TRUE){
quiet = quiet,
app = list(
call = function(req) {
-
body <- req$rook.input$read()
- result$reqs[[ length(result$reqs) + 1 ]] <<- list(req = req, body=body)
+ result$reqs[[length(result$reqs) + 1]] <<- list(req = req, body = body)
# See if this method + path has a defined response
id <- req_to_id(req)
- if (!is.null(responses[[id]])){
+ if (!is.null(responses[[id]])) {
res <- responses[[id]]
- if (is.function(res)){
+ if (is.function(res)) {
# Invoke
return(res())
} else {
@@ -91,41 +96,49 @@ start_server <- function(responses, quiet = TRUE){
test_that("initiate_external_session works", {
testthat::skip_on_cran()
- responses <- list(`POST /learnr/` = list(
- status = 200L,
- headers = list(
- 'Content-Type' = 'application/json'
- ),
- body = '{"id": "abcd1234"}'
- ))
+ responses <- list(
+ `POST /learnr/` = list(
+ status = 200L,
+ headers = list(
+ 'Content-Type' = 'application/json'
+ ),
+ body = '{"id": "abcd1234"}'
+ )
+ )
srv <- start_server(responses)
withr::defer(srv$stop())
failed <- FALSE
sess_ids <- NULL
- cb <- function(result){
+ cb <- function(result) {
sess_ids <<- c(sess_ids, result$id)
}
- err_cb <- function(res){
+ err_cb <- function(res) {
print(res)
testthat::fail("Unexpected error from initiate_external_session")
failed <<- TRUE
}
# Initiate a handful of sessions all at once
- initiate_external_session(pool, paste0(srv$url, "/learnr/"), "") %>% then(cb, err_cb)
- initiate_external_session(pool, paste0(srv$url, "/learnr/"), "") %>% then(cb, err_cb)
- initiate_external_session(pool, paste0(srv$url, "/learnr/"), "") %>% then(cb, err_cb)
-
- while(!failed && length(sess_ids) < 3){
+ initiate_external_session(pool, paste0(srv$url, "/learnr/"), "") %>%
+ then(cb, err_cb)
+ initiate_external_session(pool, paste0(srv$url, "/learnr/"), "") %>%
+ then(cb, err_cb)
+ initiate_external_session(pool, paste0(srv$url, "/learnr/"), "") %>%
+ then(cb, err_cb)
+
+ while (!failed && length(sess_ids) < 3) {
later::run_now()
}
expect_equal(failed, FALSE)
expect_equal(sess_ids, rep("abcd1234", 3))
- expect_equal(jsonlite::fromJSON(rawToChar(srv$reqs[[1]]$body)), list(global_setup = ""))
+ expect_equal(
+ jsonlite::fromJSON(rawToChar(srv$reqs[[1]]$body)),
+ list(global_setup = "")
+ )
})
test_that("initiate_external_session doesn't wait on all requests", {
@@ -136,22 +149,24 @@ test_that("initiate_external_session doesn't wait on all requests", {
testthat::skip_on_cran()
- responses <- list(`POST /learnr/` = list(
- status = 200L,
- headers = list(
- 'Content-Type' = 'application/json'
- ),
- body = '{"id": "abcd1234"}'
- ))
+ responses <- list(
+ `POST /learnr/` = list(
+ status = 200L,
+ headers = list(
+ 'Content-Type' = 'application/json'
+ ),
+ body = '{"id": "abcd1234"}'
+ )
+ )
srv <- start_server(responses)
withr::defer(srv$stop())
result <- NULL
- cb <- function(result){
+ cb <- function(result) {
result <<- TRUE
}
- err_cb <- function(res){
+ err_cb <- function(res) {
print(res)
testthat::fail("Unexpected error from initiate_external_session")
result <<- FALSE
@@ -160,47 +175,57 @@ test_that("initiate_external_session doesn't wait on all requests", {
start <- Sys.time()
# Trigger a slow (2s) request
- curl::curl_fetch_multi("http://www.httpbin.org/delay/2", done = function(res){ expect_gt(difftime(Sys.time(), start, units="secs"), 2) }, pool = pool)
+ curl::curl_fetch_multi(
+ "http://www.httpbin.org/delay/2",
+ done = function(res) {
+ expect_gt(difftime(Sys.time(), start, units = "secs"), 2)
+ },
+ pool = pool
+ )
# Initiate a session
- initiate_external_session(pool, paste0(srv$url, "/learnr/"), "") %>% then(cb, err_cb)
+ initiate_external_session(pool, paste0(srv$url, "/learnr/"), "") %>%
+ then(cb, err_cb)
- while(is.null(result)){
+ while (is.null(result)) {
later::run_now()
}
expect_equal(result, TRUE)
# Should return before the slow request returns
- expect_lt(difftime(Sys.time(), start, units="secs"), 2)
+ expect_lt(difftime(Sys.time(), start, units = "secs"), 2)
})
test_that("initiate_external_session fails with bad status", {
testthat::skip_on_cran()
- responses <- list(`POST /learnr/` = list(
- status = 500L,
- headers = list(
- 'Content-Type' = 'application/json'
- ),
- body = '{"id": "abcd1234"}'
- ))
+ responses <- list(
+ `POST /learnr/` = list(
+ status = 500L,
+ headers = list(
+ 'Content-Type' = 'application/json'
+ ),
+ body = '{"id": "abcd1234"}'
+ )
+ )
srv <- start_server(responses)
withr::defer(srv$stop())
done <- FALSE
- cb <- function(sid, cookiefile){
+ cb <- function(sid, cookiefile) {
testthat::fail("Expected failure but got success")
done <<- TRUE
}
- err_cb <- function(res){
+ err_cb <- function(res) {
done <<- TRUE
}
- initiate_external_session(pool, paste0(srv$url, "/learnr/"), "") %>% then(cb, err_cb)
+ initiate_external_session(pool, paste0(srv$url, "/learnr/"), "") %>%
+ then(cb, err_cb)
- while(!done){
+ while (!done) {
later::run_now()
}
@@ -211,30 +236,33 @@ test_that("initiate_external_session fails with bad status", {
test_that("initiate_external_session fails with invalid JSON", {
testthat::skip_on_cran()
- responses <- list(`POST /learnr/` = list(
- status = 200L,
- headers = list(
- 'Content-Type' = 'application/json'
- ),
- body = 'this is not the JSON you seek'
- ))
+ responses <- list(
+ `POST /learnr/` = list(
+ status = 200L,
+ headers = list(
+ 'Content-Type' = 'application/json'
+ ),
+ body = 'this is not the JSON you seek'
+ )
+ )
srv <- start_server(responses)
withr::defer(srv$stop())
done <- FALSE
- cb <- function(sid, cookiefile){
+ cb <- function(sid, cookiefile) {
testthat::fail("Expected failure but got success")
done <<- TRUE
}
- err_cb <- function(res){
+ err_cb <- function(res) {
done <<- TRUE
}
expect_output({
- initiate_external_session(pool, paste0(srv$url, "/learnr/"), "") %>% then(cb, err_cb)
+ initiate_external_session(pool, paste0(srv$url, "/learnr/"), "") %>%
+ then(cb, err_cb)
- while(!done){
+ while (!done) {
later::run_now()
}
})
@@ -243,13 +271,15 @@ test_that("initiate_external_session fails with invalid JSON", {
test_that("initiate_external_session fails with failed curl", {
testthat::skip_on_cran()
- responses <- list(`POST /learnr/` = list(
- status = 200L,
- headers = list(
- 'Content-Type' = 'application/json'
- ),
- body = '{"id": "abcd1234"}'
- ))
+ responses <- list(
+ `POST /learnr/` = list(
+ status = 200L,
+ headers = list(
+ 'Content-Type' = 'application/json'
+ ),
+ body = '{"id": "abcd1234"}'
+ )
+ )
# Start and stop the server as a way to obtain a port number that's likely
# inactive.
@@ -257,17 +287,18 @@ test_that("initiate_external_session fails with failed curl", {
srv$stop()
done <- FALSE
- cb <- function(sid, cookiefile){
+ cb <- function(sid, cookiefile) {
testthat::fail("Expected failure but got success")
done <<- TRUE
}
- err_cb <- function(res){
+ err_cb <- function(res) {
done <<- TRUE
}
- initiate_external_session(pool, paste0(srv$url, "/learnr/"), "") %>% then(cb, err_cb)
+ initiate_external_session(pool, paste0(srv$url, "/learnr/"), "") %>%
+ then(cb, err_cb)
- while(!done){
+ while (!done) {
later::run_now()
}
@@ -279,8 +310,10 @@ test_that("external_evaluator works", {
testthat::skip_on_cran()
tf <- withr::local_tempfile()
- mock_initiate <- function(pool, url, global_setup){
- promises::promise(function(resolve, reject){ resolve(list(id="abcd1234", cookieFile=tf)) })
+ mock_initiate <- function(pool, url, global_setup) {
+ promises::promise(function(resolve, reject) {
+ resolve(list(id = "abcd1234", cookieFile = tf))
+ })
}
mockResult <- list(html_output = "hi")
@@ -302,20 +335,32 @@ test_that("external_evaluator works", {
re <- internal_external_evaluator(srv$url, 5, mock_initiate)
- mockSession <- list(onSessionEnded = function(callback){})
+ mockSession <- list(onSessionEnded = function(callback) {})
# Start a couple of sessions concurrently
e <- re(NULL, 30, list(options = list(exercise.timelimit = 5)), mockSession)
# Simulate a session that already has an evaluator ID stashed
- e2 <- re(NULL, 30, list(options = list(exercise.timelimit = 5)),
- list(onSessionEnded = function(callback){}, userData =
- list(`.external_evaluator_session_id` =
- promises::promise(function(resolve, reject){ resolve(list(id="efgh5678", cookieFile=tf)) }))))
+ e2 <- re(
+ NULL,
+ 30,
+ list(options = list(exercise.timelimit = 5)),
+ list(
+ onSessionEnded = function(callback) {},
+ userData = list(
+ `.external_evaluator_session_id` = promises::promise(function(
+ resolve,
+ reject
+ ) {
+ resolve(list(id = "efgh5678", cookieFile = tf))
+ })
+ )
+ )
+ )
e$start()
e2$start()
- while(!e$completed() || !e2$completed()) {
+ while (!e$completed() || !e2$completed()) {
later::run_now()
}
@@ -337,8 +382,10 @@ test_that("external_evaluator works", {
})
test_that("external_evaluator handles initiate failures", {
- mock_initiate <- function(pool, url, global_setup){
- promises::promise(function(resolve, reject){ reject(list()) })
+ mock_initiate <- function(pool, url, global_setup) {
+ promises::promise(function(resolve, reject) {
+ reject(list())
+ })
}
re <- internal_external_evaluator("http://doesntmatter", 5, mock_initiate)
@@ -348,7 +395,7 @@ test_that("external_evaluator handles initiate failures", {
expect_output({
e$start()
- while(!e$completed()) {
+ while (!e$completed()) {
later::run_now()
}
})
@@ -386,18 +433,25 @@ test_that("bad statuses or invalid json are handled sanely", {
### Test with a bad status
tf <- withr::local_tempfile()
- mockInit <- promise(function(resolve, reject){ resolve(list(id="badstatus", cookieFile=tf)) })
- re <- internal_external_evaluator(srv$url, 5,
- function(pool, url, global_setup){ mockInit })
+ mockInit <- promise(function(resolve, reject) {
+ resolve(list(id = "badstatus", cookieFile = tf))
+ })
+ re <- internal_external_evaluator(
+ srv$url,
+ 5,
+ function(pool, url, global_setup) {
+ mockInit
+ }
+ )
# Start a session
- mockSession <- list(onSessionEnded = function(callback){})
+ mockSession <- list(onSessionEnded = function(callback) {})
e <- re(NULL, 30, list(options = list(exercise.timelimit = 5)), mockSession)
expect_output({
e$start()
- while(!e$completed()) {
+ while (!e$completed()) {
later::run_now()
}
})
@@ -407,8 +461,15 @@ test_that("bad statuses or invalid json are handled sanely", {
### Test with invalid JSON
tf <- withr::local_tempfile()
- re <- internal_external_evaluator(srv$url, 5,
- function(pool, url, global_setup){ promises::promise(function(resolve, reject){ resolve(list(id="invalidjson", cookieFile=tf)) }) })
+ re <- internal_external_evaluator(
+ srv$url,
+ 5,
+ function(pool, url, global_setup) {
+ promises::promise(function(resolve, reject) {
+ resolve(list(id = "invalidjson", cookieFile = tf))
+ })
+ }
+ )
# Start a session
e <- re(NULL, 30, list(options = list(exercise.timelimit = 5)), mockSession)
@@ -416,7 +477,7 @@ test_that("bad statuses or invalid json are handled sanely", {
expect_output({
e$start()
- while(!e$completed()) {
+ while (!e$completed()) {
later::run_now()
}
})
diff --git a/tests/testthat/test-events.R b/tests/testthat/test-events.R
index 740fe1b1b..7b2abc45b 100644
--- a/tests/testthat/test-events.R
+++ b/tests/testthat/test-events.R
@@ -1,26 +1,29 @@
test_that("Event handlers", {
# Check that session, event, data are passed to callback.
result <- NULL
- cancel <- event_register_handler("foo",
- function(session, event, data) { result <<- list(session, event, data) }
- )
+ cancel <- event_register_handler("foo", function(session, event, data) {
+ result <<- list(session, event, data)
+ })
on.exit(cancel(), add = TRUE)
event_trigger("session_obj", "foo", "data")
expect_identical(result, list("session_obj", "foo", "data"))
cancel()
-
# Testing multiple event handlers for same event, checking for order
x <- numeric()
cancel1 <- event_register_handler(
"foo",
- function(session, event, data) { x <<- c(x, 1) }
+ function(session, event, data) {
+ x <<- c(x, 1)
+ }
)
on.exit(cancel1(), add = TRUE)
cancel2 <- event_register_handler(
"foo",
- function(session, event, data) { x <<- c(x, 2) }
+ function(session, event, data) {
+ x <<- c(x, 2)
+ }
)
on.exit(cancel2(), add = TRUE)
@@ -61,7 +64,9 @@ test_that("Errors are converted to warnings", {
g <- function() stop("error in g")
cancel1 <- event_register_handler("foo", function(session, event, data) f())
on.exit(cancel1(), add = TRUE)
- cancel2 <- event_register_handler("foo", function(session, event, data) n <<- n + 1)
+ cancel2 <- event_register_handler("foo", function(session, event, data) {
+ n <<- n + 1
+ })
on.exit(cancel2(), add = TRUE)
expect_warning(event_trigger(NULL, "foo", NA), "error in g")
diff --git a/tests/testthat/test-exercise.R b/tests/testthat/test-exercise.R
index 383d42de4..fcd7314dc 100644
--- a/tests/testthat/test-exercise.R
+++ b/tests/testthat/test-exercise.R
@@ -1,4 +1,3 @@
-
# exercise_code_chunks() --------------------------------------------------
test_that("exercise_code_chunks_prep() returns setup/user chunks", {
@@ -121,7 +120,8 @@ test_that("render_exercise() returns envir_result up to error", {
exercise_result <- withr::with_tempdir(
rlang::catch_cnd(
- render_exercise(exercise, new.env()), "learnr_render_exercise_error"
+ render_exercise(exercise, new.env()),
+ "learnr_render_exercise_error"
)
)
@@ -243,8 +243,8 @@ test_that("evaluate_exercise() returns an internal error when `render_exercise()
skip_if_not_pandoc("1.14")
local_edition(2)
- with_mock(
- "learnr:::render_exercise" = function(...) stop("render error"),
+ with_mocked_bindings(
+ render_exercise = function(...) stop("render error"),
expect_warning(
res <- evaluate_exercise(mock_exercise(), new.env())
)
@@ -284,7 +284,10 @@ test_that("render_exercise() cleans up exercise_prep files even when setup fails
exercise <- mock_exercise(
user_code = c("writeLines('nope', 'nope.txt')", "dir()"),
# setup chunk throws an error
- chunks = list(mock_chunk("ex-setup", c("rlang::abort('setup-error', dir = dir())"))),
+ chunks = list(mock_chunk(
+ "ex-setup",
+ c("rlang::abort('setup-error', dir = dir())")
+ )),
# get file listing after error in setup chunk happens
error_check = I("dir()")
)
@@ -298,7 +301,7 @@ test_that("render_exercise() cleans up exercise_prep files even when setup fails
list(
before = before,
during = res$feedback$error$dir,
- after = dir()
+ after = dir()
)
}),
"exercise_prep.Rmd"
@@ -391,7 +394,12 @@ test_that("serialized exercises produce equivalent evaluate_exercise() results",
)
# From internal_external_evaluator() in R/evaluators.R
- exercise_serialized <- jsonlite::toJSON(exercise, auto_unbox = TRUE, null = "null", force = TRUE)
+ exercise_serialized <- jsonlite::toJSON(
+ exercise,
+ auto_unbox = TRUE,
+ null = "null",
+ force = TRUE
+ )
# use parse_json() for safest parsing of serialized JSON (simplifyVector = FALSE)
exercise_unserialized <- jsonlite::parse_json(exercise_serialized)
@@ -508,7 +516,10 @@ test_that("exercise_result() doesn't drop html dependencies from `html_output`",
)
res <- exercise_result(html_output = html_output)
expect_equal(as.character(res$html_output), as.character(html_output))
- expect_equal(htmltools::htmlDependencies(res$html_output), list(clipboardjs_html_dependency()))
+ expect_equal(
+ htmltools::htmlDependencies(res$html_output),
+ list(clipboardjs_html_dependency())
+ )
})
test_that("exercise_result_as_html() creates html for learnr", {
@@ -575,8 +586,7 @@ test_that("filter_dependencies() excludes non-list knit_meta objects", {
skip_if_not_pandoc("1.14")
ex <- mock_exercise(
- user_code =
- "htmltools::tagList(
+ user_code = "htmltools::tagList(
htmltools::tags$head(htmltools::tags$style(\".leaflet-container {backround:#FFF}\")),
idb_html_dependency()
)"
@@ -663,7 +673,7 @@ test_that("data/ - files in data/ directory can be accessed", {
dir.create("data")
writeLines("ORIGINAL", "data/test.txt")
- ex <- mock_exercise(user_code = 'readLines("data/test.txt")', check = TRUE)
+ ex <- mock_exercise(user_code = 'readLines("data/test.txt")', check = TRUE)
res <- evaluate_exercise(ex, envir = new.env())
expect_equal(res$feedback$checker_args$last_value, "ORIGINAL")
})
@@ -672,7 +682,7 @@ test_that("data/ - no issues if data directory does not exist", {
skip_if_not_pandoc("1.14")
withr::local_dir(withr::local_tempdir())
- ex <- mock_exercise(user_code = '"SUCCESS"', check = TRUE)
+ ex <- mock_exercise(user_code = '"SUCCESS"', check = TRUE)
res <- evaluate_exercise(ex, envir = new.env())
expect_equal(res$feedback$checker_args$last_value, "SUCCESS")
})
@@ -693,7 +703,7 @@ test_that("data/ - original files are modified by exercise code", {
)
res <- evaluate_exercise(ex, envir = new.env())
expect_equal(res$feedback$checker_args$last_value, "MODIFIED")
- expect_equal(readLines("data/test.txt"), "ORIGINAL")
+ expect_equal(readLines("data/test.txt"), "ORIGINAL")
})
test_that("data/ - specify alternate data directory with envvar", {
@@ -706,7 +716,7 @@ test_that("data/ - specify alternate data directory with envvar", {
dir.create("envvar")
writeLines("ENVVAR", "envvar/test.txt")
- ex <- mock_exercise(user_code = 'readLines("data/test.txt")', check = TRUE)
+ ex <- mock_exercise(user_code = 'readLines("data/test.txt")', check = TRUE)
res <- evaluate_exercise(ex, envir = new.env())
expect_equal(res$feedback$checker_args$last_value, "ENVVAR")
@@ -719,8 +729,8 @@ test_that("data/ - specify alternate data directory with envvar", {
)
res <- evaluate_exercise(ex, envir = new.env())
expect_equal(res$feedback$checker_args$last_value, "MODIFIED")
- expect_equal(readLines("data/test.txt"), "DEFAULT")
- expect_equal(readLines("envvar/test.txt"), "ENVVAR")
+ expect_equal(readLines("data/test.txt"), "DEFAULT")
+ expect_equal(readLines("envvar/test.txt"), "ENVVAR")
})
test_that("data/ - errors if envvar directory does not exist", {
@@ -747,16 +757,16 @@ test_that("data/ - specify alternate data directory with `options()`", {
dir.create("nested/structure/data", recursive = TRUE)
writeLines("NESTED", "nested/structure/test.txt")
- ex <- mock_exercise(user_code = 'readLines("data/test.txt")', check = TRUE)
+ ex <- mock_exercise(user_code = 'readLines("data/test.txt")', check = TRUE)
res <- evaluate_exercise(ex, envir = new.env())
- expect_equal(res$feedback$checker_args$last_value, "DEFAULT")
- expect_equal(readLines("data/test.txt"), "DEFAULT")
+ expect_equal(res$feedback$checker_args$last_value, "DEFAULT")
+ expect_equal(readLines("data/test.txt"), "DEFAULT")
expect_equal(readLines("nested/structure/test.txt"), "NESTED")
ex <- mock_exercise(
- user_code = 'readLines("data/test.txt")',
+ user_code = 'readLines("data/test.txt")',
global_setup = 'options(tutorial.data_dir = "nested/structure")',
- check = TRUE
+ check = TRUE
)
res <- evaluate_exercise(ex, new.env(), evaluate_global_setup = TRUE)
expect_equal(res$feedback$checker_args$last_value, "NESTED")
@@ -767,11 +777,11 @@ test_that("data/ - specify alternate data directory with `options()`", {
readLines("data/test.txt")
',
global_setup = 'options(tutorial.data_dir = "nested/structure")',
- check = TRUE
+ check = TRUE
)
res <- evaluate_exercise(ex, new.env(), evaluate_global_setup = TRUE)
- expect_equal(res$feedback$checker_args$last_value, "MODIFIED")
- expect_equal(readLines("data/test.txt"), "DEFAULT")
+ expect_equal(res$feedback$checker_args$last_value, "MODIFIED")
+ expect_equal(readLines("data/test.txt"), "DEFAULT")
expect_equal(readLines("nested/structure/test.txt"), "NESTED")
})
@@ -780,7 +790,7 @@ test_that("data/ - errors if `options()` directory does not exist", {
withr::local_dir(withr::local_tempdir())
ex <- mock_exercise(
- user_code = 'readLines("data/test.txt")',
+ user_code = 'readLines("data/test.txt")',
global_setup = 'options(tutorial.data_dir = "nested/structure")'
)
expect_error(
@@ -802,9 +812,9 @@ test_that("data/ - data directory option has precendence over envvar", {
writeLines("ENVVAR", "envvar/test.txt")
ex <- mock_exercise(
- user_code = 'readLines("data/test.txt")',
+ user_code = 'readLines("data/test.txt")',
global_setup = 'options(tutorial.data_dir = "nested/structure")',
- check = TRUE
+ check = TRUE
)
res <- evaluate_exercise(ex, new.env(), evaluate_global_setup = TRUE)
expect_equal(res$feedback$checker_args$last_value, "NESTED")
@@ -823,7 +833,7 @@ test_that("options() are protected from student modification", {
)
output <- evaluate_exercise(ex, envir = new.env())
expect_match(output$html_output, "USER", fixed = TRUE)
- expect_match(getOption("test"), "WITHR", fixed = TRUE)
+ expect_match(getOption("test"), "WITHR", fixed = TRUE)
})
test_that("options() can be set in setup chunk", {
@@ -831,26 +841,30 @@ test_that("options() can be set in setup chunk", {
withr::local_options(test = "WITHR")
ex <- mock_exercise(
- user_code = "getOption('test')",
- chunks = list(mock_chunk("setup", "options(test = 'SETUP')")),
+ user_code = "getOption('test')",
+ chunks = list(mock_chunk("setup", "options(test = 'SETUP')")),
setup_label = "setup"
)
output <- evaluate_exercise(
- ex, envir = new.env(), evaluate_global_setup = TRUE
+ ex,
+ envir = new.env(),
+ evaluate_global_setup = TRUE
)
expect_match(output$html_output, "SETUP", fixed = TRUE)
- expect_match(getOption("test"), "WITHR", fixed = TRUE)
+ expect_match(getOption("test"), "WITHR", fixed = TRUE)
ex <- mock_exercise(
- user_code = "options(test = 'USER')\ngetOption('test')",
- chunks = list(mock_chunk("setup", "options(test = 'SETUP')")),
+ user_code = "options(test = 'USER')\ngetOption('test')",
+ chunks = list(mock_chunk("setup", "options(test = 'SETUP')")),
setup_label = "setup"
)
output <- evaluate_exercise(
- ex, envir = new.env(), evaluate_global_setup = TRUE
+ ex,
+ envir = new.env(),
+ evaluate_global_setup = TRUE
)
expect_match(output$html_output, "USER", fixed = TRUE)
- expect_match(getOption("test"), "WITHR", fixed = TRUE)
+ expect_match(getOption("test"), "WITHR", fixed = TRUE)
})
test_that("options() can be set in global setup chunk", {
@@ -858,36 +872,42 @@ test_that("options() can be set in global setup chunk", {
withr::local_options(test = "WITHR")
ex <- mock_exercise(
- user_code = "getOption('test')",
+ user_code = "getOption('test')",
global_setup = "options(test = 'GLOBAL')"
)
output <- evaluate_exercise(
- ex, envir = new.env(), evaluate_global_setup = TRUE
+ ex,
+ envir = new.env(),
+ evaluate_global_setup = TRUE
)
expect_match(output$html_output, "GLOBAL", fixed = TRUE)
- expect_match(getOption("test"), "WITHR", fixed = TRUE)
+ expect_match(getOption("test"), "WITHR", fixed = TRUE)
ex <- mock_exercise(
- user_code = "options(test = 'USER')\ngetOption('test')",
+ user_code = "options(test = 'USER')\ngetOption('test')",
global_setup = "options(test = 'GLOBAL')"
)
output <- evaluate_exercise(
- ex, envir = new.env(), evaluate_global_setup = TRUE
+ ex,
+ envir = new.env(),
+ evaluate_global_setup = TRUE
)
- expect_match(output$html_output, "USER", fixed = TRUE)
- expect_match(getOption("test"), "WITHR", fixed = TRUE)
+ expect_match(output$html_output, "USER", fixed = TRUE)
+ expect_match(getOption("test"), "WITHR", fixed = TRUE)
ex <- mock_exercise(
- user_code = "getOption('test')",
+ user_code = "getOption('test')",
global_setup = "options(test = 'GLOBAL')",
- chunks = list(mock_chunk("setup", "options(test = 'SETUP')")),
- setup_label = "setup"
+ chunks = list(mock_chunk("setup", "options(test = 'SETUP')")),
+ setup_label = "setup"
)
output <- evaluate_exercise(
- ex, envir = new.env(), evaluate_global_setup = TRUE
+ ex,
+ envir = new.env(),
+ evaluate_global_setup = TRUE
)
expect_match(output$html_output, "SETUP", fixed = TRUE)
- expect_match(getOption("test"), "WITHR", fixed = TRUE)
+ expect_match(getOption("test"), "WITHR", fixed = TRUE)
})
test_that("envvars are protected from student modification", {
@@ -901,7 +921,7 @@ test_that("envvars are protected from student modification", {
)
output <- evaluate_exercise(ex, envir = new.env())
expect_match(output$html_output, "USER", fixed = TRUE)
- expect_match(Sys.getenv("TEST"), "WITHR", fixed = TRUE)
+ expect_match(Sys.getenv("TEST"), "WITHR", fixed = TRUE)
})
test_that("options are protected from both user and author modification", {
@@ -963,51 +983,69 @@ test_that("env vars are protected from both user and author modification", {
test_that("evaluate_exercise() returns a message if code contains ___", {
skip_if_not_pandoc("1.14")
- ex <- mock_exercise(user_code = '____("test")')
+ ex <- mock_exercise(user_code = '____("test")')
result <- evaluate_exercise(ex, new.env())
expect_equal(result$feedback, exercise_check_code_for_blanks(ex)$feedback)
expect_match(result$feedback$message, ""count":1")
expect_match(result$feedback$message, "This exercise contains 1 blank.")
- expect_match(result$feedback$message, "Please replace ____ with valid code.")
+ expect_match(
+ result$feedback$message,
+ "Please replace ____ with valid code."
+ )
- ex <- mock_exercise(user_code = '____(____)')
+ ex <- mock_exercise(user_code = '____(____)')
result <- evaluate_exercise(ex, new.env())
expect_equal(result$feedback, exercise_check_code_for_blanks(ex)$feedback)
expect_match(result$feedback$message, ""count":2")
expect_match(result$feedback$message, "This exercise contains 2 blanks.")
- expect_match(result$feedback$message, "Please replace ____ with valid code.")
+ expect_match(
+ result$feedback$message,
+ "Please replace ____ with valid code."
+ )
- ex <- mock_exercise(user_code = '____("____")')
+ ex <- mock_exercise(user_code = '____("____")')
result <- evaluate_exercise(ex, new.env())
expect_equal(result$feedback, exercise_check_code_for_blanks(ex)$feedback)
expect_match(result$feedback$message, ""count":2")
expect_match(result$feedback$message, "This exercise contains 2 blanks.")
- expect_match(result$feedback$message, "Please replace ____ with valid code.")
+ expect_match(
+ result$feedback$message,
+ "Please replace ____ with valid code."
+ )
})
test_that("setting a different blank for the blank checker", {
skip_if_not_pandoc("1.14")
- ex <- mock_exercise(user_code = '####("test")', exercise.blanks = "###")
+ ex <- mock_exercise(user_code = '####("test")', exercise.blanks = "###")
result <- evaluate_exercise(ex, new.env())
expect_equal(result$feedback, exercise_check_code_for_blanks(ex)$feedback)
expect_match(result$feedback$message, ""count":1")
expect_match(result$feedback$message, "This exercise contains 1 blank.")
- expect_match(result$feedback$message, "Please replace ### with valid code.")
+ expect_match(
+ result$feedback$message,
+ "Please replace ### with valid code."
+ )
- ex <- mock_exercise(user_code = '####(####)', exercise.blanks = "###")
+ ex <- mock_exercise(user_code = '####(####)', exercise.blanks = "###")
result <- evaluate_exercise(ex, new.env())
expect_equal(result$feedback, exercise_check_code_for_blanks(ex)$feedback)
expect_match(result$feedback$message, ""count":2")
expect_match(result$feedback$message, "This exercise contains 2 blanks.")
- expect_match(result$feedback$message, "Please replace ### with valid code.")
+ expect_match(
+ result$feedback$message,
+ "Please replace ### with valid code."
+ )
- ex <- mock_exercise(user_code = '####("####")', exercise.blanks = "###")
+ ex <- mock_exercise(user_code = '####("####")', exercise.blanks = "###")
result <- evaluate_exercise(ex, new.env())
expect_equal(result$feedback, exercise_check_code_for_blanks(ex)$feedback)
expect_match(result$feedback$message, ""count":2")
expect_match(result$feedback$message, "This exercise contains 2 blanks.")
- expect_match(result$feedback$message, "Please replace ### with valid code.")
+ expect_match(
+ result$feedback$message,
+ "Please replace ### with valid code."
+ )
})
test_that("setting a different blank for the blank checker in global setup", {
@@ -1017,7 +1055,7 @@ test_that("setting a different blank for the blank checker in global setup", {
withr::defer(knitr::opts_chunk$set(exercise.blanks = NULL))
ex <- mock_exercise(
- user_code = '####("test")',
+ user_code = '####("test")',
global_setup = 'knitr::opts_chunk$set(exercise.blanks = "###")'
)
result <- evaluate_exercise(ex, new.env(), evaluate_global_setup = TRUE)
@@ -1025,14 +1063,17 @@ test_that("setting a different blank for the blank checker in global setup", {
expect_match(result$feedback$message, ""count":1")
expect_match(result$feedback$message, "This exercise contains 1 blank.")
- expect_match(result$feedback$message, "Please replace ### with valid code.")
+ expect_match(
+ result$feedback$message,
+ "Please replace ### with valid code."
+ )
})
test_that("setting a regex blank for the blank checker", {
skip_if_not_pandoc("1.14")
ex <- mock_exercise(
- user_code = '..function..("..string..")',
+ user_code = '..function..("..string..")',
exercise.blanks = "\\.\\.\\S+?\\.\\."
)
result <- evaluate_exercise(ex, new.env(), evaluate_global_setup = TRUE)
@@ -1040,49 +1081,63 @@ test_that("setting a regex blank for the blank checker", {
expect_match(result$feedback$message, ""count":2")
expect_match(result$feedback$message, "This exercise contains 2 blanks.")
- expect_match(result$feedback$message, "Please replace ..function.. and ..string.. with valid code.")
+ expect_match(
+ result$feedback$message,
+ "Please replace ..function.. and ..string.. with valid code."
+ )
})
test_that("use underscores as blanks if exercise.blanks is TRUE", {
skip_if_not_pandoc("1.14")
ex <- mock_exercise(
- user_code = 'print("____")', exercise.blanks = TRUE
+ user_code = 'print("____")',
+ exercise.blanks = TRUE
)
result <- evaluate_exercise(ex, new.env())
expect_equal(result$feedback, exercise_check_code_for_blanks(ex)$feedback)
expect_match(result$feedback$message, ""count":1")
expect_match(result$feedback$message, "This exercise contains 1 blank.")
- expect_match(result$feedback$message, "Please replace ____ with valid code.")
+ expect_match(
+ result$feedback$message,
+ "Please replace ____ with valid code."
+ )
ex <- mock_exercise(
- user_code = '____("test")', exercise.blanks = TRUE
+ user_code = '____("test")',
+ exercise.blanks = TRUE
)
result <- evaluate_exercise(ex, new.env())
expect_equal(result$feedback, exercise_check_code_for_blanks(ex)$feedback)
expect_match(result$feedback$message, ""count":1")
expect_match(result$feedback$message, "This exercise contains 1 blank.")
- expect_match(result$feedback$message, "Please replace ____ with valid code.")
+ expect_match(
+ result$feedback$message,
+ "Please replace ____ with valid code."
+ )
})
test_that("default message if exercise.blanks is FALSE", {
skip_if_not_pandoc("1.14")
ex <- mock_exercise(
- user_code = 'print("____")', exercise.blanks = FALSE
+ user_code = 'print("____")',
+ exercise.blanks = FALSE
)
result <- evaluate_exercise(ex, new.env())
expect_null(result$feedback$message)
expect_null(exercise_check_code_for_blanks(ex))
ex <- mock_exercise(
- user_code = '____("test")', exercise.blanks = FALSE
+ user_code = '____("test")',
+ exercise.blanks = FALSE
)
result <- evaluate_exercise(ex, new.env())
expect_null(exercise_check_code_for_blanks(ex))
expect_match(result$feedback$message, "text.unparsable")
expect_match(
- result$feedback$message, i18n_translations()$en$translation$text$unparsable,
+ result$feedback$message,
+ i18n_translations()$en$translation$text$unparsable,
fixed = TRUE
)
expect_equal(result$feedback, exercise_check_code_is_parsable(ex)$feedback)
@@ -1099,7 +1154,8 @@ test_that("evaluate_exercise() returns a message if code is unparsable", {
expect_equal(result$feedback, exercise_check_code_is_parsable(ex)$feedback)
expect_match(result$feedback$message, "text.unparsable")
expect_match(
- result$feedback$message, i18n_translations()$en$translation$text$unparsable,
+ result$feedback$message,
+ i18n_translations()$en$translation$text$unparsable,
fixed = TRUE
)
expect_match(result$error_message, "unexpected end of input")
@@ -1109,7 +1165,8 @@ test_that("evaluate_exercise() returns a message if code is unparsable", {
expect_equal(result$feedback, exercise_check_code_is_parsable(ex)$feedback)
expect_match(result$feedback$message, "text.unparsable")
expect_match(
- result$feedback$message, i18n_translations()$en$translation$text$unparsable,
+ result$feedback$message,
+ i18n_translations()$en$translation$text$unparsable,
fixed = TRUE
)
expect_match(result$error_message, "unexpected INCOMPLETE_STRING")
@@ -1119,7 +1176,8 @@ test_that("evaluate_exercise() returns a message if code is unparsable", {
expect_equal(result$feedback, exercise_check_code_is_parsable(ex)$feedback)
expect_match(result$feedback$message, "text.unparsable")
expect_match(
- result$feedback$message, i18n_translations()$en$translation$text$unparsable,
+ result$feedback$message,
+ i18n_translations()$en$translation$text$unparsable,
fixed = TRUE
)
expect_match(result$error_message, "unexpected symbol")
@@ -1148,7 +1206,10 @@ test_that("exericse_check_code_is_parsable() gives error checker a 'parse_error'
ex <- mock_exercise(user_code = 'print("test"', error_check = I("last_value"))
result <- evaluate_exercise(ex, new.env())
- expect_s3_class(result$feedback$checker_result, class = c("parse_error", "condition"))
+ expect_s3_class(
+ result$feedback$checker_result,
+ class = c("parse_error", "condition")
+ )
})
test_that("Errors with global setup code result in an internal error", {
@@ -1161,7 +1222,10 @@ test_that("Errors with global setup code result in an internal error", {
)
expect_null(res$error_message)
- expect_match(res$feedback$message, "internal error occurred while setting up the tutorial")
+ expect_match(
+ res$feedback$message,
+ "internal error occurred while setting up the tutorial"
+ )
expect_s3_class(res$feedback$error, "error")
expect_match(conditionMessage(res$feedback$error), "boom")
})
@@ -1224,8 +1288,7 @@ test_that("evaluate_exercise() does not return a message for parsable non-ASCII
# Non-ASCII variable name
ex <- mock_exercise(
- user_code =
- '\u03bc\u03b5\u03c4\u03b1\u03b2\u03bb\u03b7\u03c4\u03ae <- "What?"'
+ user_code = '\u03bc\u03b5\u03c4\u03b1\u03b2\u03bb\u03b7\u03c4\u03ae <- "What?"'
)
result <- evaluate_exercise(ex, new.env())
expect_null(result$feedback)
@@ -1260,7 +1323,6 @@ test_that("Exercise timelimit error is returned when exercise takes too long", {
})
-
# Sensitive env vars and options are masked from user -----------------------
test_that("Shiny session is diabled", {
@@ -1280,14 +1342,16 @@ test_that("Shiny session is diabled", {
test_that("Sensitive env vars and options are masked", {
skip_if_not_pandoc("1.14")
- ex <- mock_exercise(user_code = paste(
- "list(",
- " Sys.getenv('CONNECT_API_KEY', 'USER_LOCAL_CONNECT_API_KEY'),",
- " Sys.getenv('CONNECT_SERVER', 'USER_LOCAL_CONNECT_SERVER'),",
- " getOption('shiny.sharedSecret', 'USER_LOCAL_sharedSecret')",
- ")",
- sep = "\n"
- ))
+ ex <- mock_exercise(
+ user_code = paste(
+ "list(",
+ " Sys.getenv('CONNECT_API_KEY', 'USER_LOCAL_CONNECT_API_KEY'),",
+ " Sys.getenv('CONNECT_SERVER', 'USER_LOCAL_CONNECT_SERVER'),",
+ " getOption('shiny.sharedSecret', 'USER_LOCAL_sharedSecret')",
+ ")",
+ sep = "\n"
+ )
+ )
env_connect <- list(
CONNECT_API_KEY = "T_CONNECT_API_KEY",
@@ -1374,7 +1438,9 @@ test_that("SQL exercises - without explicit `output.var`", {
res <- res_sql_engine$feedback$checker_args
# snapshots
- expect_snapshot(writeLines(render_exercise_rmd_user(render_exercise_prepare(ex_sql_engine))))
+ expect_snapshot(writeLines(render_exercise_rmd_user(render_exercise_prepare(
+ ex_sql_engine
+ ))))
# connection exists in envir_prep
expect_true(exists("db_con", res$envir_prep, inherits = FALSE))
@@ -1423,7 +1489,9 @@ test_that("SQL exercises - with explicit `output.var`", {
res <- res_sql_engine$feedback$checker_args
# snapshots
- expect_snapshot(writeLines(render_exercise_rmd_user(render_exercise_prepare(ex_sql_engine))))
+ expect_snapshot(writeLines(render_exercise_rmd_user(render_exercise_prepare(
+ ex_sql_engine
+ ))))
# connection exists in envir_prep
expect_true(exists("db_con", res$envir_prep, inherits = FALSE))
@@ -1462,9 +1530,16 @@ test_that("Python exercises - simple example", {
# envir_prep and envir_result should be different objects
envir_prep_py <- get0(".__py__", envir = res$envir_prep, ifnotfound = NULL)
- envir_result_py <- get0(".__py__", envir = res$envir_result, ifnotfound = NULL)
+ envir_result_py <- get0(
+ ".__py__",
+ envir = res$envir_result,
+ ifnotfound = NULL
+ )
expect_false(
- identical(reticulate::py_id(envir_prep_py), reticulate::py_id(envir_result_py))
+ identical(
+ reticulate::py_id(envir_prep_py),
+ reticulate::py_id(envir_result_py)
+ )
)
})
@@ -1484,7 +1559,10 @@ test_that("Python exercises - assignment example", {
res <- withr::with_tempdir(render_exercise(ex_py, new.env()))
# TODO: invisible values should be more explicit
- expect_equal(reticulate::py_to_r(res$last_value), "__reticulate_placeholder__")
+ expect_equal(
+ reticulate::py_to_r(res$last_value),
+ "__reticulate_placeholder__"
+ )
expect_null(res$evaluate_result)
expect_true(exists('.__py__', res$envir_prep))
expect_true(exists('.__py__', res$envir_result))
@@ -1492,9 +1570,16 @@ test_that("Python exercises - assignment example", {
expect_equal(result$x, 6)
envir_prep_py <- get0(".__py__", envir = res$envir_prep, ifnotfound = NULL)
- envir_result_py <- get0(".__py__", envir = res$envir_result, ifnotfound = NULL)
+ envir_result_py <- get0(
+ ".__py__",
+ envir = res$envir_result,
+ ifnotfound = NULL
+ )
expect_false(
- identical(reticulate::py_id(envir_prep_py), reticulate::py_id(envir_result_py))
+ identical(
+ reticulate::py_id(envir_prep_py),
+ reticulate::py_id(envir_result_py)
+ )
)
})
diff --git a/tests/testthat/test-feedback.R b/tests/testthat/test-feedback.R
index 683a6faa7..7e66d79c2 100644
--- a/tests/testthat/test-feedback.R
+++ b/tests/testthat/test-feedback.R
@@ -21,7 +21,9 @@ test_that("feedback message must be character or tag or tagList", {
expect_silent(feedback_validated(fdbck("good")))
expect_silent(feedback_validated(fdbck(htmltools::HTML("good"))))
expect_silent(feedback_validated(fdbck(htmltools::p("good"))))
- expect_silent(feedback_validated(fdbck(htmltools::tagList(htmltools::p("good")))))
+ expect_silent(feedback_validated(fdbck(htmltools::tagList(htmltools::p(
+ "good"
+ )))))
})
test_that("feedback type must be one of the acceptable values", {
@@ -29,12 +31,18 @@ test_that("feedback type must be one of the acceptable values", {
expect_equal(feedback_validated(fdbck(correct = TRUE))$type, "success")
expect_equal(feedback_validated(fdbck(correct = FALSE))$type, "error")
- expect_equal(feedback_validated(fdbck(type = c("info", "error")))$type, "info")
+ expect_equal(
+ feedback_validated(fdbck(type = c("info", "error")))$type,
+ "info"
+ )
})
test_that("feedback location must be one of the acceptable values", {
expect_error(feedback_validated(fdbck(location = "--bad--")), "location")
expect_equal(feedback_validated(fdbck())$location, "append")
- expect_equal(feedback_validated(fdbck(location = c("replace", "prepend")))$location, "replace")
+ expect_equal(
+ feedback_validated(fdbck(location = c("replace", "prepend")))$location,
+ "replace"
+ )
})
diff --git a/tests/testthat/test-i18n.R b/tests/testthat/test-i18n.R
index fba314f96..bbc40e5df 100644
--- a/tests/testthat/test-i18n.R
+++ b/tests/testthat/test-i18n.R
@@ -55,7 +55,7 @@ test_that("i18n_process_language_options() multiple customizations", {
),
en = list(
button = list(runcode = "EN run"),
- text= list(areyousure = "EN sure")
+ text = list(areyousure = "EN sure")
)
))
@@ -169,7 +169,9 @@ test_that("i18n_process_language_options() warns if a language is not a single c
test_that("i18n_process_language_options() warns unexpected keys are present", {
expect_warning(
- i18n_process_language_options(list(en = list(foo = list(), button = list()))),
+ i18n_process_language_options(list(
+ en = list(foo = list(), button = list())
+ )),
"foo"
)
@@ -200,7 +202,11 @@ test_that("i18n_span() returns an i18n span", {
expect_s3_class(span, "character")
expect_match(span, 'data-i18n="KEY"')
expect_match(span, ">DEFAULT")
- expect_match(span, 'data-i18n-opts="{"interp":"STRING"}"', fixed = TRUE)
+ expect_match(
+ span,
+ 'data-i18n-opts="{"interp":"STRING"}"',
+ fixed = TRUE
+ )
})
test_that("i18n_set_language_option() changes message language", {
@@ -253,14 +259,20 @@ test_that("i18n_set_language_option() sets up language inheritance", {
ex <- mock_exercise(user_code = "mean$x")
ex$tutorial$language <- "pt"
result <- evaluate_exercise(ex, new.env())
- expect_equal(result$error_message, "objeto de tipo 'closure' não possível dividir em subconjuntos")
+ expect_equal(
+ result$error_message,
+ "objeto de tipo 'closure' não possível dividir em subconjuntos"
+ )
ex <- mock_exercise(
user_code = "mean$x",
global_setup = "i18n_set_language_option('pt')"
)
result <- evaluate_exercise(ex, new.env(), evaluate_global_setup = TRUE)
- expect_equal(result$error_message, "objeto de tipo 'closure' não possível dividir em subconjuntos")
+ expect_equal(
+ result$error_message,
+ "objeto de tipo 'closure' não possível dividir em subconjuntos"
+ )
ex <- mock_exercise(
user_code = c(
diff --git a/tests/testthat/test-install-dependencies.R b/tests/testthat/test-install-dependencies.R
index b8f81c42b..104d96eae 100644
--- a/tests/testthat/test-install-dependencies.R
+++ b/tests/testthat/test-install-dependencies.R
@@ -3,9 +3,11 @@ context("install tutorial dependencies")
create_test_tutorial <- function(code) {
tutorial_dir <- file.path(tempdir(), "tutorial-deps")
dir.create(tutorial_dir)
- tutorial_path <- tempfile("tutorial-deps",
- tmpdir = tutorial_dir,
- fileext = ".R")
+ tutorial_path <- tempfile(
+ "tutorial-deps",
+ tmpdir = tutorial_dir,
+ fileext = ".R"
+ )
writeLines(code, con = tutorial_path)
invisible(tutorial_dir)
}
@@ -29,20 +31,6 @@ test_that("tutorial dependency check returns NULL for no dependencies", {
expect_silent(install_tutorial_dependencies(tutorial_dir))
})
-# test_that("tutorial dependency check works (interactive)", {
-# skip_if_not(interactive())
-#
-# tutorial_dir <- create_test_tutorial("library(pkg1)\npkg2::n()")
-# on.exit(unlink(tutorial_dir, recursive = TRUE), add = TRUE)
-#
-# expect_error(
-# with_mock(
-# ask_pkgs_install = function(x) 2,
-# install_tutorial_dependencies(tutorial_dir)
-# )
-# )
-# })
-
test_that("tutorial dependency check works (not interactive)", {
skip_if(interactive())
diff --git a/tests/testthat/test-knitr-hooks.R b/tests/testthat/test-knitr-hooks.R
index efa4ecb23..563b5c777 100644
--- a/tests/testthat/test-knitr-hooks.R
+++ b/tests/testthat/test-knitr-hooks.R
@@ -18,13 +18,21 @@ test_that("*-error-check chunks require *-check chunks", {
on.exit(unlink(tmpfile))
expect_error(
- rmarkdown::render(test_path("setup-chunks", "error-check-chunk_bad.Rmd"), output_file = tmpfile, quiet = TRUE),
+ rmarkdown::render(
+ test_path("setup-chunks", "error-check-chunk_bad.Rmd"),
+ output_file = tmpfile,
+ quiet = TRUE
+ ),
"ex-check",
fixed = TRUE
)
expect_silent(
- rmarkdown::render(test_path("setup-chunks", "error-check-chunk_good.Rmd"), output_file = tmpfile, quiet = TRUE)
+ rmarkdown::render(
+ test_path("setup-chunks", "error-check-chunk_good.Rmd"),
+ output_file = tmpfile,
+ quiet = TRUE
+ )
)
})
@@ -35,37 +43,65 @@ test_that("Detection of chained setup cycle works", {
on.exit(unlink(tmpfile))
expect_error(
- rmarkdown::render(test_path("setup-chunks", "setup-cycle.Rmd"), output_file = tmpfile, quiet = TRUE),
+ rmarkdown::render(
+ test_path("setup-chunks", "setup-cycle.Rmd"),
+ output_file = tmpfile,
+ quiet = TRUE
+ ),
"dataA => dataC => dataB => dataA",
fixed = TRUE
)
expect_error(
- rmarkdown::render(test_path("setup-chunks", "setup-cycle-self.Rmd"), output_file = tmpfile, quiet = TRUE),
+ rmarkdown::render(
+ test_path("setup-chunks", "setup-cycle-self.Rmd"),
+ output_file = tmpfile,
+ quiet = TRUE
+ ),
"dataA => dataA",
fixed = TRUE
)
expect_error(
- rmarkdown::render(test_path("setup-chunks", "setup-cycle-two.Rmd"), output_file = tmpfile, quiet = TRUE),
+ rmarkdown::render(
+ test_path("setup-chunks", "setup-cycle-two.Rmd"),
+ output_file = tmpfile,
+ quiet = TRUE
+ ),
"dataA => dataB => dataA",
fixed = TRUE
)
expect_error(
- rmarkdown::render(test_path("setup-chunks", "exercise-cycle-default-setup.Rmd"), output_file = tmpfile, quiet = TRUE),
+ rmarkdown::render(
+ test_path("setup-chunks", "exercise-cycle-default-setup.Rmd"),
+ output_file = tmpfile,
+ quiet = TRUE
+ ),
"data1 => data1-setup => data1",
fixed = TRUE
)
expect_error(
- rmarkdown::render(test_path("setup-chunks", "exercise-cycle.Rmd"), output_file = tmpfile, quiet = TRUE),
+ rmarkdown::render(
+ test_path("setup-chunks", "exercise-cycle.Rmd"),
+ output_file = tmpfile,
+ quiet = TRUE
+ ),
"data1 => data3 => data2 => data1",
fixed = TRUE
)
expect_error(
- rmarkdown::render(test_path("setup-chunks", "exercise-cycle-self.Rmd"), output_file = tmpfile, quiet = TRUE),
+ rmarkdown::render(
+ test_path("setup-chunks", "exercise-cycle-self.Rmd"),
+ output_file = tmpfile,
+ quiet = TRUE
+ ),
"data1 => data1",
fixed = TRUE
)
expect_error(
- rmarkdown::render(test_path("setup-chunks", "exercise-cycle-two.Rmd"), output_file = tmpfile, quiet = TRUE),
+ rmarkdown::render(
+ test_path("setup-chunks", "exercise-cycle-two.Rmd"),
+ output_file = tmpfile,
+ quiet = TRUE
+ ),
"data1 => data2 => data1",
fixed = TRUE
)
@@ -77,8 +113,16 @@ test_that("Empty exercise code still creates an exercise", {
# empty and full exercises are the same, except that "full" has empty lines
# in the exercise chunk. They should result in identical exercises.
- rmd_empty <- test_path("tutorials", "knitr-hooks_empty-exercise", "empty-exercise.Rmd")
- rmd_full <- test_path("tutorials", "knitr-hooks_empty-exercise", "full-exercise.Rmd")
+ rmd_empty <- test_path(
+ "tutorials",
+ "knitr-hooks_empty-exercise",
+ "empty-exercise.Rmd"
+ )
+ rmd_full <- test_path(
+ "tutorials",
+ "knitr-hooks_empty-exercise",
+ "full-exercise.Rmd"
+ )
ex_empty <- get_tutorial_exercises(rmd_empty)
ex_full <- get_tutorial_exercises(rmd_full)
@@ -93,7 +137,11 @@ test_that("Empty exercises with duplicate labels throw an error", {
skip_if_not_pandoc("1.14")
local_edition(3)
- rmd <- test_path("tutorials", "knitr-hooks_empty-exercise", "duplicate-label.Rmd")
+ rmd <- test_path(
+ "tutorials",
+ "knitr-hooks_empty-exercise",
+ "duplicate-label.Rmd"
+ )
expect_error(expect_message(get_tutorial_exercises(rmd), "duplicate"))
})
diff --git a/tests/testthat/test-mock_exercise.R b/tests/testthat/test-mock_exercise.R
index 4dc41b939..5b672f2f9 100644
--- a/tests/testthat/test-mock_exercise.R
+++ b/tests/testthat/test-mock_exercise.R
@@ -9,10 +9,22 @@ test_that("exercise mocks: mock_prep_setup()", {
expect_equal(mock_prep_setup(chunks, "setup-1"), "x <- 1")
# random order
- expect_equal(mock_prep_setup(chunks[3:1], "setup-3"), "x <- 1\ny <- 2\nz <- 3")
- expect_equal(mock_prep_setup(chunks[c(1, 3, 2)], "setup-3"), "x <- 1\ny <- 2\nz <- 3")
- expect_equal(mock_prep_setup(chunks[c(2, 3, 1)], "setup-3"), "x <- 1\ny <- 2\nz <- 3")
- expect_equal(mock_prep_setup(chunks[c(2, 1, 3)], "setup-3"), "x <- 1\ny <- 2\nz <- 3")
+ expect_equal(
+ mock_prep_setup(chunks[3:1], "setup-3"),
+ "x <- 1\ny <- 2\nz <- 3"
+ )
+ expect_equal(
+ mock_prep_setup(chunks[c(1, 3, 2)], "setup-3"),
+ "x <- 1\ny <- 2\nz <- 3"
+ )
+ expect_equal(
+ mock_prep_setup(chunks[c(2, 3, 1)], "setup-3"),
+ "x <- 1\ny <- 2\nz <- 3"
+ )
+ expect_equal(
+ mock_prep_setup(chunks[c(2, 1, 3)], "setup-3"),
+ "x <- 1\ny <- 2\nz <- 3"
+ )
# checks that setup chunk is in chunks
expect_error(mock_prep_setup(chunks, "setup-Z"), "setup-Z")
diff --git a/tests/testthat/test-mutate_tags.R b/tests/testthat/test-mutate_tags.R
index 8638d9ee7..1a3af163e 100644
--- a/tests/testthat/test-mutate_tags.R
+++ b/tests/testthat/test-mutate_tags.R
@@ -1,7 +1,13 @@
has_class <- function(el, .class, ...) {
class_idx <- which(names(el$attribs) == "class")
- if (!length(class_idx)) return(FALSE)
- el_class <- vapply(class_idx, function(i) el$attribs[[i]], FUN.VALUE = character(1))
+ if (!length(class_idx)) {
+ return(FALSE)
+ }
+ el_class <- vapply(
+ class_idx,
+ function(i) el$attribs[[i]],
+ FUN.VALUE = character(1)
+ )
grepl(.class, paste(el_class, collapse = " "), ...)
}
@@ -74,4 +80,4 @@ test_that("finalize_question() works with a shiny.tag.list, too", {
expect_true(has_class(q_ui_final[[1]], "disabled"))
expect_true(has_class(q_ui_final[[2]], "question-final"))
expect_true(has_class(q_ui_final[[2]], "disabled"))
-})
\ No newline at end of file
+})
diff --git a/tests/testthat/test-options-reveal_solution.R b/tests/testthat/test-options-reveal_solution.R
index 03ec56bbc..322a40a7d 100644
--- a/tests/testthat/test-options-reveal_solution.R
+++ b/tests/testthat/test-options-reveal_solution.R
@@ -13,11 +13,14 @@ render_tutorial_with_reveal_solution <- function(opt_string) {
tut_html <- rmarkdown::render(tut_rmd, quiet = TRUE)
# overwrite exit handler to remove all tutorial files
- on.exit({
- rmarkdown::shiny_prerendered_clean(tut_rmd)
- unlink(tut_html)
- unlink(tut_rmd)
- }, add = FALSE)
+ on.exit(
+ {
+ rmarkdown::shiny_prerendered_clean(tut_rmd)
+ unlink(tut_html)
+ unlink(tut_rmd)
+ },
+ add = FALSE
+ )
paste(readLines(tut_html), collapse = "\n")
}
@@ -32,7 +35,9 @@ var_show_solution <- "# SHOWN VAR SOLUTION aba888"
test_that("Solutions are revealed or hidden with tutorial_options()", {
skip_if_not(rmarkdown::pandoc_available())
- ex_show <- render_tutorial_with_reveal_solution("tutorial_options(exercise.reveal_solution = TRUE)")
+ ex_show <- render_tutorial_with_reveal_solution(
+ "tutorial_options(exercise.reveal_solution = TRUE)"
+ )
expect_match(ex_show, default_solution, fixed = TRUE)
expect_failure(expect_match(ex_show, hidden_solution, fixed = TRUE))
expect_match(ex_show, shown_solution, fixed = TRUE)
@@ -40,7 +45,9 @@ test_that("Solutions are revealed or hidden with tutorial_options()", {
expect_failure(expect_match(ex_show, var_hide_solution, fixed = TRUE))
expect_match(ex_show, var_show_solution, fixed = TRUE)
- ex_hide <- render_tutorial_with_reveal_solution("tutorial_options(exercise.reveal_solution = FALSE)")
+ ex_hide <- render_tutorial_with_reveal_solution(
+ "tutorial_options(exercise.reveal_solution = FALSE)"
+ )
expect_failure(expect_match(ex_hide, default_solution, fixed = TRUE))
expect_failure(expect_match(ex_hide, hidden_solution, fixed = TRUE))
expect_match(ex_hide, shown_solution, fixed = TRUE)
@@ -52,7 +59,9 @@ test_that("Solutions are revealed or hidden with tutorial_options()", {
test_that("Solutions are revealed or hidden with global option", {
skip_if_not(rmarkdown::pandoc_available())
- ex_show <- render_tutorial_with_reveal_solution("options(tutorial.exercise.reveal_solution = TRUE)")
+ ex_show <- render_tutorial_with_reveal_solution(
+ "options(tutorial.exercise.reveal_solution = TRUE)"
+ )
expect_match(ex_show, default_solution, fixed = TRUE)
expect_failure(expect_match(ex_show, hidden_solution, fixed = TRUE))
expect_match(ex_show, shown_solution, fixed = TRUE)
@@ -60,7 +69,9 @@ test_that("Solutions are revealed or hidden with global option", {
expect_failure(expect_match(ex_show, var_hide_solution, fixed = TRUE))
expect_match(ex_show, var_show_solution, fixed = TRUE)
- ex_hide <- render_tutorial_with_reveal_solution("options(tutorial.exercise.reveal_solution = FALSE)")
+ ex_hide <- render_tutorial_with_reveal_solution(
+ "options(tutorial.exercise.reveal_solution = FALSE)"
+ )
expect_failure(expect_match(ex_hide, default_solution, fixed = TRUE))
expect_failure(expect_match(ex_hide, hidden_solution, fixed = TRUE))
expect_match(ex_hide, shown_solution, fixed = TRUE)
diff --git a/tests/testthat/test-options.R b/tests/testthat/test-options.R
index 62117cf5c..3c27d7f7f 100644
--- a/tests/testthat/test-options.R
+++ b/tests/testthat/test-options.R
@@ -1,4 +1,3 @@
-
context("options")
test_that("tutor options set knitr options", {
@@ -10,4 +9,3 @@ test_that("tutor options don't set knitr options when excluded from the call", {
tutorial_options(exercise.cap = "Caption")
expect_equal(knitr::opts_chunk$get("exercise.eval"), NULL)
})
-
diff --git a/tests/testthat/test-praise.R b/tests/testthat/test-praise.R
index c7047620a..f89acff6d 100644
--- a/tests/testthat/test-praise.R
+++ b/tests/testthat/test-praise.R
@@ -1,16 +1,25 @@
test_that("random_phrases()", {
expect_error(random_phrases("foo"), "should be one of")
expect_warning(
- expect_equal(random_phrases("praise", "foo"), random_phrases("praise", "en"))
+ expect_equal(
+ random_phrases("praise", "foo"),
+ random_phrases("praise", "en")
+ )
)
knitr::opts_knit$set("tutorial.language" = "en")
expect_equal(random_phrases("praise"), random_phrases("praise", "en"))
- expect_equal(random_phrases("encouragement"), random_phrases("encouragement", "en"))
+ expect_equal(
+ random_phrases("encouragement"),
+ random_phrases("encouragement", "en")
+ )
knitr::opts_knit$set("tutorial.language" = NULL)
expect_equal(random_phrases("praise", "testing"), "RANDOM PRAISE.")
- expect_equal(random_phrases("encouragement", "testing"), "RANDOM ENCOURAGEMENT.")
+ expect_equal(
+ random_phrases("encouragement", "testing"),
+ "RANDOM ENCOURAGEMENT."
+ )
})
test_that("random_phrases_add()", {
@@ -24,7 +33,10 @@ test_that("random_phrases_add()", {
expect_equal(random_phrases("encouragement", "bogus"), c("Go 1", "Go 2"))
random_phrases_add("bogus", encouragement = "Go 3")
- expect_equal(random_phrases("encouragement", "bogus"), c("Go 1", "Go 2", "Go 3"))
+ expect_equal(
+ random_phrases("encouragement", "bogus"),
+ c("Go 1", "Go 2", "Go 3")
+ )
expect_error(random_phrases_add("bogus", list("bad")))
expect_error(random_phrases_add("bogus", 1:4))
diff --git a/tests/testthat/test-question_answers.R b/tests/testthat/test-question_answers.R
index c095ab55d..8a097a1b3 100644
--- a/tests/testthat/test-question_answers.R
+++ b/tests/testthat/test-question_answers.R
@@ -1,5 +1,4 @@
test_that("no message-correct", {
-
q <- question(
"test",
answer("A", correct = TRUE),
@@ -10,18 +9,21 @@ test_that("no message-correct", {
ans <- question_is_correct(q, c("A"))
- out <- question_messages(q, ans$messages, ans$correct, (!isTRUE(q$allow_retry)) || ans$correct)
+ out <- question_messages(
+ q,
+ ans$messages,
+ ans$correct,
+ (!isTRUE(q$allow_retry)) || ans$correct
+ )
expect_s3_class(out, "shiny.tag.list")
expect_equivalent(as.character(out[[1]]$children[[1]]), "test-correct")
expect_true(is.null(out$children[[2]]))
expect_true(is.null(out$children[[3]]))
-
})
test_that("no message-incorrect", {
-
q <- question(
"test",
answer("A", correct = TRUE),
@@ -32,18 +34,21 @@ test_that("no message-incorrect", {
ans <- question_is_correct(q, c("B"))
- out <- question_messages(q, ans$messages, ans$correct, (!isTRUE(q$allow_retry)) || ans$correct)
+ out <- question_messages(
+ q,
+ ans$messages,
+ ans$correct,
+ (!isTRUE(q$allow_retry)) || ans$correct
+ )
expect_s3_class(out, "shiny.tag.list")
expect_equivalent(as.character(out[[1]]$children[[1]]), "test-incorrect")
expect_true(is.null(out$children[[2]]))
expect_true(is.null(out$children[[3]]))
-
})
test_that("all messages-correct", {
-
q <- question(
"test",
answer("A", correct = TRUE, message = "msg **1**"),
@@ -56,18 +61,27 @@ test_that("all messages-correct", {
ans <- question_is_correct(q, c("A"))
- out <- question_messages(q, ans$messages, ans$correct, (!isTRUE(q$allow_retry)) || ans$correct)
+ out <- question_messages(
+ q,
+ ans$messages,
+ ans$correct,
+ (!isTRUE(q$allow_retry)) || ans$correct
+ )
expect_s3_class(out, "shiny.tag.list")
- expect_equivalent(as.character(out[[1]]$children[[1]][[1]][[1]]), "test-correct")
- expect_equivalent(as.character(out[[1]]$children[[1]][[1]][[3]]), "msg 1")
+ expect_equivalent(
+ as.character(out[[1]]$children[[1]][[1]][[1]]),
+ "test-correct"
+ )
+ expect_equivalent(
+ as.character(out[[1]]$children[[1]][[1]][[3]]),
+ "msg 1"
+ )
expect_equivalent(as.character(out[[2]]$children[[1]]), "test-message")
expect_equivalent(as.character(out[[3]]$children[[1]]), "test-post")
-
})
test_that("all messages-incorrect", {
-
q <- question(
"test",
answer("A", correct = TRUE, message = "msg **1**"),
@@ -80,20 +94,28 @@ test_that("all messages-incorrect", {
ans <- question_is_correct(q, c("B"))
- out <- question_messages(q, ans$messages, ans$correct, (!isTRUE(q$allow_retry)) || ans$correct)
+ out <- question_messages(
+ q,
+ ans$messages,
+ ans$correct,
+ (!isTRUE(q$allow_retry)) || ans$correct
+ )
expect_s3_class(out, "shiny.tag.list")
- expect_equivalent(as.character(out[[1]]$children[[1]][[1]][[1]]), "test-incorrect")
- expect_equivalent(as.character(out[[1]]$children[[1]][[1]][[3]]), "msg 2")
+ expect_equivalent(
+ as.character(out[[1]]$children[[1]][[1]][[1]]),
+ "test-incorrect"
+ )
+ expect_equivalent(
+ as.character(out[[1]]$children[[1]][[1]][[3]]),
+ "msg 2"
+ )
expect_equivalent(as.character(out[[2]]$children[[1]]), "test-message")
expect_equivalent(as.character(out[[3]]$children[[1]]), "test-post")
-
})
-
test_that("custom message", {
-
q <- question(
"test",
answer("A", correct = TRUE, message = htmltools::tags$div("_Test_")),
@@ -104,22 +126,34 @@ test_that("custom message", {
ans <- question_is_correct(q, c("A"))
- out <- question_messages(q, ans$messages, ans$correct, (!isTRUE(q$allow_retry)) || ans$correct)
+ out <- question_messages(
+ q,
+ ans$messages,
+ ans$correct,
+ (!isTRUE(q$allow_retry)) || ans$correct
+ )
expect_s3_class(out, "shiny.tag.list")
- expect_equivalent(as.character(out[[1]]$children[[1]][[1]][[1]]), "test-correct")
- expect_equivalent(as.character(out[[1]]$children[[1]][[1]][[3]]$children), "_Test_")
+ expect_equivalent(
+ as.character(out[[1]]$children[[1]][[1]][[1]]),
+ "test-correct"
+ )
+ expect_equivalent(
+ as.character(out[[1]]$children[[1]][[1]][[3]]$children),
+ "_Test_"
+ )
expect_true(is.null(out$children[[2]]))
expect_true(is.null(out$children[[3]]))
-
})
test_that("answer options must have unique values (option)", {
expect_error(
- answer_values(list(answers = list(
- answer("same"),
- answer("same")
- )))
+ answer_values(list(
+ answers = list(
+ answer("same"),
+ answer("same")
+ )
+ ))
)
})
@@ -161,7 +195,7 @@ test_that("answer functions: filtering and splitting", {
answer("apple", TRUE, "correct"),
answer_fn(function(x) "F1", "f1"),
answer("banana", FALSE, "incorrect"),
- answer_fn(~ "F2", "f2"),
+ answer_fn(~"F2", "f2"),
answer("mango", FALSE, "also incorrect")
)
diff --git a/tests/testthat/test-question_checkbox.R b/tests/testthat/test-question_checkbox.R
index 49386ce27..5c88854d7 100644
--- a/tests/testthat/test-question_checkbox.R
+++ b/tests/testthat/test-question_checkbox.R
@@ -1,6 +1,4 @@
-
test_that("question_checkbox() does not include correct messages for incorrect answer", {
-
q <- question_checkbox(
"test",
answer("A", correct = TRUE, message = "msg **1**"),
@@ -36,7 +34,6 @@ test_that("question_checkbox() does not include correct messages for incorrect a
})
test_that("question_checkbox() message depends on whether allow_retry = TRUE", {
-
incorrect_message <- "incorrect"
try_again_message <- "try_again"
diff --git a/tests/testthat/test-question_radio.R b/tests/testthat/test-question_radio.R
index 5b659c12f..0d32b5ac8 100644
--- a/tests/testthat/test-question_radio.R
+++ b/tests/testthat/test-question_radio.R
@@ -2,8 +2,8 @@ test_that("question_radio() throws an error when using only answer_fn() answers"
expect_error(
question_radio(
"test",
- answer_fn(~ "one"),
- answer_fn(~ "two")
+ answer_fn(~"one"),
+ answer_fn(~"two")
)
)
})
@@ -12,7 +12,7 @@ test_that("question_radio() throws an error if it doesn't include a correct answ
expect_error(
question_radio(
"test",
- answer_fn(~ "one"),
+ answer_fn(~"one"),
answer("two", correct = FALSE)
)
)
@@ -29,7 +29,7 @@ test_that("question_radio() warns when using answer_fn() answers", {
expect_warning(
q_fn <- question_radio(
"test",
- answer_fn(~ "one"),
+ answer_fn(~"one"),
answer("two", correct = TRUE)
)
)
diff --git a/tests/testthat/test-question_text.R b/tests/testthat/test-question_text.R
index 5ff8fde12..4b2838c65 100644
--- a/tests/testthat/test-question_text.R
+++ b/tests/testthat/test-question_text.R
@@ -1,15 +1,24 @@
test_that("question text uses textAreaInput if rows or cols are provided", {
ans <- answer("", TRUE)
- q_textArea_rows <- question_ui_initialize(question_text("A", ans, rows = 3), "")
+ q_textArea_rows <- question_ui_initialize(
+ question_text("A", ans, rows = 3),
+ ""
+ )
expect_equal(q_textArea_rows$children[[2]]$name, "textarea")
expect_equal(q_textArea_rows$children[[2]]$attribs$rows, 3)
- q_textArea_cols <- question_ui_initialize(question_text("A", ans, cols = 40), "")
+ q_textArea_cols <- question_ui_initialize(
+ question_text("A", ans, cols = 40),
+ ""
+ )
expect_equal(q_textArea_cols$children[[2]]$name, "textarea")
expect_equal(q_textArea_cols$children[[2]]$attribs$cols, 40)
- q_textArea <- question_ui_initialize(question_text("A", ans, rows = 4, cols = 30), "")
+ q_textArea <- question_ui_initialize(
+ question_text("A", ans, rows = 4, cols = 30),
+ ""
+ )
expect_equal(q_textArea$children[[2]]$name, "textarea")
expect_equal(q_textArea$children[[2]]$attribs$rows, 4)
expect_equal(q_textArea$children[[2]]$attribs$cols, 30)
@@ -101,5 +110,3 @@ test_that("question_text() requires some text input", {
expect_error(question_is_correct(q, ""), "text")
})
})
-
-
diff --git a/tests/testthat/test-quiz.R b/tests/testthat/test-quiz.R
index 4a361e515..f93330bda 100644
--- a/tests/testthat/test-quiz.R
+++ b/tests/testthat/test-quiz.R
@@ -1,4 +1,3 @@
-
# Test quiz() -------------------------------------------------------------
create_question <- function() {
@@ -22,7 +21,6 @@ test_that("quiz questions can be created", {
expect_type(a$correct, "logical")
expect_type(a$message, "NULL")
-
expect_s3_class(q, "learnr_radio")
expect_s3_class(q, "tutorial_question")
@@ -76,7 +74,6 @@ test_that("questions can be aggregated via quiz", {
# Test question() ---------------------------------------------------------
-
test_that("bad ellipses are found", {
expect_silent(
question("title", answer("5", correct = TRUE))
@@ -88,11 +85,17 @@ test_that("bad ellipses are found", {
test_that("loading placeholder is correctly generated for HTML question texts", {
expect_silent(
- q1 <- question(htmltools::tags$p("Did this work?"), answer("yes", correct = TRUE))
+ q1 <- question(
+ htmltools::tags$p("Did this work?"),
+ answer("yes", correct = TRUE)
+ )
)
expect_silent(
- q2 <- question(htmltools::HTML("Did this work?
"), answer("yes", correct = TRUE))
+ q2 <- question(
+ htmltools::HTML("Did this work?
"),
+ answer("yes", correct = TRUE)
+ )
)
expect_equal(q1$loading, q2$loading)
@@ -102,16 +105,20 @@ test_that("loading placeholder is correctly generated for HTML question texts",
'Does this equal two?
1 + 1
-
', answer("yes", correct = TRUE)
+',
+ answer("yes", correct = TRUE)
)
)
expect_silent(
question(
- htmltools::HTML('Does this equal two?
+ htmltools::HTML(
+ 'Does this equal two?
1 + 1
-
'), answer("yes", correct = TRUE)
+'
+ ),
+ answer("yes", correct = TRUE)
)
)
@@ -125,13 +132,12 @@ test_that("loading placeholder is correctly generated for HTML question texts",
"```",
sep = "\n"
),
- answer(2, correct =TRUE)
+ answer(2, correct = TRUE)
)
)
})
test_that("question() message depends on whether type is checkbox", {
-
q_radio <- question(
"test",
answer("A", correct = TRUE),
diff --git a/tests/testthat/test-run.R b/tests/testthat/test-run.R
index fb7240cfc..0605d4cb4 100644
--- a/tests/testthat/test-run.R
+++ b/tests/testthat/test-run.R
@@ -19,13 +19,28 @@ test_that("run_tutorial() with bad inputs", {
test_that("validating and finding tutorials", {
# value when nothing is provided
expect_equal(run_validate_tutorial_dir(NULL), list(valid = FALSE, dir = NULL))
- expect_equal(run_validate_tutorial_file(NULL), list(valid = FALSE, dir = NULL))
- expect_equal(run_validate_tutorial_path(NULL), list(valid = FALSE, dir = NULL))
+ expect_equal(
+ run_validate_tutorial_file(NULL),
+ list(valid = FALSE, dir = NULL)
+ )
+ expect_equal(
+ run_validate_tutorial_path(NULL),
+ list(valid = FALSE, dir = NULL)
+ )
# returns name if not an existing file
- expect_equal(run_validate_tutorial_dir("foo"), list(valid = FALSE, dir = "foo"))
- expect_equal(run_validate_tutorial_file("foo"), list(valid = FALSE, dir = "foo"))
- expect_equal(run_validate_tutorial_path("foo"), list(valid = FALSE, dir = "foo"))
+ expect_equal(
+ run_validate_tutorial_dir("foo"),
+ list(valid = FALSE, dir = "foo")
+ )
+ expect_equal(
+ run_validate_tutorial_file("foo"),
+ list(valid = FALSE, dir = "foo")
+ )
+ expect_equal(
+ run_validate_tutorial_path("foo"),
+ list(valid = FALSE, dir = "foo")
+ )
expect_null(run_find_tutorial_rmd("foo"))
tmpdir <- tempfile()
@@ -162,4 +177,3 @@ test_that("safe() executes code expression directly and programmatically", {
safe(cat(!!x, file = !!file))
expect_equal(readLines(file), "3")
})
-
diff --git a/tests/testthat/test-shinytest2-hints.R b/tests/testthat/test-shinytest2-hints.R
index 48d5be8d4..f53c5d8c4 100644
--- a/tests/testthat/test-shinytest2-hints.R
+++ b/tests/testthat/test-shinytest2-hints.R
@@ -33,39 +33,31 @@ describe("sequential hints", {
id <- "one"
it("shows hint when hint button is clicked", {
- app$
- wait_for_js(selector_exists(exercise_selector_hint_btn(id)))$
- click(selector = exercise_selector_hint_btn(id))$
- wait_for_js(check_popover_exists(id))$
- expect("succeed")
+ app$wait_for_js(selector_exists(exercise_selector_hint_btn(id)))$click(
+ selector = exercise_selector_hint_btn(id)
+ )$wait_for_js(check_popover_exists(id))$expect("succeed")
})
it("doesn't have a next hint button", {
- app$
- wait_for_js(
- selector_doesnt_exist(
- exercise_selector_hint_popover(id),
- ".btn-tutorial-hint"
- )
- )$
- expect("succeed")
+ app$wait_for_js(
+ selector_doesnt_exist(
+ exercise_selector_hint_popover(id),
+ ".btn-tutorial-hint"
+ )
+ )$expect("succeed")
})
it("shows the correct hint in the editor", {
- app$
- expect("equal", get_js(get_popover_editor_value(id)), "# one hint")
-
+ app$expect("equal", get_js(get_popover_editor_value(id)), "# one hint")
hint_text <- app$get_js(get_popover_editor_value(id))
expect_equal(hint_text, "# one hint")
})
it("hides the popover when clicking on the hint button again", {
- app$
- wait_for_js(check_popover_exists(id))$
- click(selector = exercise_selector_hint_btn(id))$
- wait_for_js(check_popover_closed(id))$
- expect("succeed")
+ app$wait_for_js(check_popover_exists(id))$click(
+ selector = exercise_selector_hint_btn(id)
+ )$wait_for_js(check_popover_closed(id))$expect("succeed")
})
})
@@ -73,11 +65,9 @@ describe("sequential hints", {
id <- "two"
it("shows hints when hint button is clicked", {
- app$
- wait_for_js(selector_exists(exercise_selector_hint_btn(id)))$
- click(selector = exercise_selector_hint_btn(id))$
- wait_for_js(check_popover_exists(id))$
- expect("succeed")
+ app$wait_for_js(selector_exists(exercise_selector_hint_btn(id)))$click(
+ selector = exercise_selector_hint_btn(id)
+ )$wait_for_js(check_popover_exists(id))$expect("succeed")
})
next_hint_button <- paste(
@@ -86,9 +76,7 @@ describe("sequential hints", {
)
it("has a next hint button", {
- app$
- wait_for_js(selector_exists(next_hint_button))$
- expect("succeed")
+ app$wait_for_js(selector_exists(next_hint_button))$expect("succeed")
})
it("shows the first hint in the editor", {
@@ -96,36 +84,36 @@ describe("sequential hints", {
})
it("shows the next hint when clicking on the next hint button", {
- app$
- click(selector = next_hint_button)$
- expect("equal", get_js(get_popover_editor_value(id)), "# second hint")
+ app$click(selector = next_hint_button)$expect(
+ "equal",
+ get_js(get_popover_editor_value(id)),
+ "# second hint"
+ )
})
it("disables the next hint button when the last hint is shown", {
- app$
- expect(
- "true",
- "disabled" %in% unlist(get_js(selector_classlist(next_hint_button)))
- )$
- expect(
- "true",
- get_js(selector_attributes(next_hint_button))$disabled %in%
+ app$expect(
+ "true",
+ "disabled" %in% unlist(get_js(selector_classlist(next_hint_button)))
+ )$expect(
+ "true",
+ get_js(selector_attributes(next_hint_button))$disabled %in%
c("true", "disabled", "")
- )
+ )
})
it("doesn't do anything when disabled hint button is clicked", {
- app$
- click(selector = next_hint_button)$
- expect("equal", get_js(get_popover_editor_value(id)), "# second hint")
+ app$click(selector = next_hint_button)$expect(
+ "equal",
+ get_js(get_popover_editor_value(id)),
+ "# second hint"
+ )
})
it("hides the hints when clicking on the hint button again", {
- app$
- wait_for_js(check_popover_exists(id))$
- click(selector = exercise_selector_hint_btn(id))$
- wait_for_js(check_popover_closed(id))$
- expect("succeed")
+ app$wait_for_js(check_popover_exists(id))$click(
+ selector = exercise_selector_hint_btn(id)
+ )$wait_for_js(check_popover_closed(id))$expect("succeed")
})
})
@@ -133,11 +121,9 @@ describe("sequential hints", {
id <- "three"
it("shows hints when hint button is clicked", {
- app$
- wait_for_js(selector_exists(exercise_selector_hint_btn(id)))$
- click(selector = exercise_selector_hint_btn(id))$
- wait_for_js(check_popover_exists(id))$
- expect("succeed")
+ app$wait_for_js(selector_exists(exercise_selector_hint_btn(id)))$click(
+ selector = exercise_selector_hint_btn(id)
+ )$wait_for_js(check_popover_exists(id))$expect("succeed")
})
next_hint_button <- paste(
@@ -146,57 +132,62 @@ describe("sequential hints", {
)
it("has a next hint button", {
- app$
- wait_for_js(selector_exists(next_hint_button))$
- expect("succeed")
+ app$wait_for_js(selector_exists(next_hint_button))$expect("succeed")
})
it("shows the first hint in the editor", {
- app$expect("equal", get_js(get_popover_editor_value(id)), "# 3 - first hint")
+ app$expect(
+ "equal",
+ get_js(get_popover_editor_value(id)),
+ "# 3 - first hint"
+ )
})
it("shows the next hint when clicking on the next hint button", {
- app$
- click(selector = next_hint_button)$
- wait_for_js(check_popover_exists(id))$
- expect("succeed")$
- expect("equal", get_js(get_popover_editor_value(id)), "# 3 - second hint")
+ app$click(selector = next_hint_button)$wait_for_js(check_popover_exists(
+ id
+ ))$expect("succeed")$expect(
+ "equal",
+ get_js(get_popover_editor_value(id)),
+ "# 3 - second hint"
+ )
})
it("shows the solution after the last hint", {
- app$
- click(selector = next_hint_button)$
- wait_for_js(check_popover_exists(id))$
- expect("succeed")$
- expect("equal", get_js(get_popover_editor_value(id)), "2 + 2")
+ app$click(selector = next_hint_button)$wait_for_js(check_popover_exists(
+ id
+ ))$expect("succeed")$expect(
+ "equal",
+ get_js(get_popover_editor_value(id)),
+ "2 + 2"
+ )
})
it("adds disabled class and attribute when the next hint button is shown", {
- app$
- expect(
- "true",
- "disabled" %in% unlist(get_js(selector_classlist(next_hint_button)))
- )$
- expect(
- "true",
- get_js(selector_attributes(next_hint_button))$disabled %in% c("true", "disabled", "")
- )
+ app$expect(
+ "true",
+ "disabled" %in% unlist(get_js(selector_classlist(next_hint_button)))
+ )$expect(
+ "true",
+ get_js(selector_attributes(next_hint_button))$disabled %in%
+ c("true", "disabled", "")
+ )
})
it("doesn't do anything when disabled hint button is clicked", {
- app$
- click(selector = next_hint_button)$
- wait_for_js(check_popover_exists(id))$
- expect("succeed")$
- expect("equal", get_js(get_popover_editor_value(id)), "2 + 2")
+ app$click(selector = next_hint_button)$wait_for_js(check_popover_exists(
+ id
+ ))$expect("succeed")$expect(
+ "equal",
+ get_js(get_popover_editor_value(id)),
+ "2 + 2"
+ )
})
it("hides the hints when clicking on the hint button again", {
- app$
- wait_for_js(check_popover_exists(id))$
- click(selector = exercise_selector_hint_btn(id))$
- wait_for_js(check_popover_closed(id))$
- expect("succeed")
+ app$wait_for_js(check_popover_exists(id))$click(
+ selector = exercise_selector_hint_btn(id)
+ )$wait_for_js(check_popover_closed(id))$expect("succeed")
})
})
})
@@ -214,10 +205,9 @@ describe("copy button", {
}
# Reset tutorial via "Start Over" button
- app$
- click(selector = ".resetButton")$
- wait_for_js(selector_exists(".bootbox .bootbox-accept"))$
- click(selector = ".bootbox .bootbox-accept")
+ app$click(selector = ".resetButton")$wait_for_js(selector_exists(
+ ".bootbox .bootbox-accept"
+ ))$click(selector = ".bootbox .bootbox-accept")
# Wait for page reload to complete
chrome$Page$loadEventFired()
@@ -236,26 +226,26 @@ describe("copy button", {
)
it("clicks hint button to open hint popover", {
- app$
- wait_for_js(check_popover_closed(id), timeout = 5000)$
- click(selector = exercise_selector_hint_btn(id))$
- wait_for_js(check_popover_exists(id))$
- expect("succeed", "hint popover exists")$
- wait_for_js(
- selector_exists(
- exercise_selector_hint_popover(id),
- ".btn-tutorial-copy-solution"
- )
- )$
- expect("succeed", "hint popover has copy solution button")$
- wait_for_js(
- selector_exists(exercise_selector_hint_popover(id), ".ace_editor")
- )$
- expect("succeed", "popover has editor with hint")
+ app$wait_for_js(check_popover_closed(id), timeout = 5000)$click(
+ selector = exercise_selector_hint_btn(id)
+ )$wait_for_js(check_popover_exists(id))$expect(
+ "succeed",
+ "hint popover exists"
+ )$wait_for_js(
+ selector_exists(
+ exercise_selector_hint_popover(id),
+ ".btn-tutorial-copy-solution"
+ )
+ )$expect("succeed", "hint popover has copy solution button")$wait_for_js(
+ selector_exists(exercise_selector_hint_popover(id), ".ace_editor")
+ )$expect("succeed", "popover has editor with hint")
})
it("hint text in editor matches expectations", {
- app$expect("true", get_js(get_popover_editor_value(id)) %in% hint_text_expected)
+ app$expect(
+ "true",
+ get_js(get_popover_editor_value(id)) %in% hint_text_expected
+ )
})
it("clicks copy solution button to copy hint and close popover", {
@@ -264,9 +254,12 @@ describe("copy button", {
".btn-tutorial-copy-solution"
)
- app_real_click(app, copy_btn)$
- wait_for_js(check_popover_closed(id))$
- expect("true", get_js('navigator.clipboard.readText()') %in% hint_text_expected)
+ app_real_click(app, copy_btn)$wait_for_js(check_popover_closed(
+ id
+ ))$expect(
+ "true",
+ get_js('navigator.clipboard.readText()') %in% hint_text_expected
+ )
})
it("pastes the copied text into the editor", {
@@ -278,29 +271,27 @@ describe("copy button", {
",
exercise_selector_editor(id)
)
- )$
- expect(
- "true",
- trimws(app$get_js(get_editor_value(exercise_selector_editor(id)))) %in%
- hint_text_expected
- )
+ )$expect(
+ "true",
+ trimws(app$get_js(get_editor_value(exercise_selector_editor(id)))) %in%
+ hint_text_expected
+ )
})
it("evaluates the pasted hint text correctly", {
- app$
- click(selector = exercise_selector_run_btn(id))$
- wait_for_js(exercise_has_output(id))$
- expect(
- "equal",
- get_html(
- selector = paste(exercise_selector_output(id), "pre code"),
- outer_html = FALSE
- ),
- get_html(
- selector = "#section-ex1-expected-output pre code",
- outer_html = FALSE
- )
+ app$click(
+ selector = exercise_selector_run_btn(id)
+ )$wait_for_js(exercise_has_output(id))$expect(
+ "equal",
+ get_html(
+ selector = paste(exercise_selector_output(id), "pre code"),
+ outer_html = FALSE
+ ),
+ get_html(
+ selector = "#section-ex1-expected-output pre code",
+ outer_html = FALSE
)
+ )
})
})
@@ -312,26 +303,26 @@ describe("copy button", {
)
it("clicks hint button to open hint popover", {
- app$
- wait_for_js(check_popover_closed(id), timeout = 5000)$
- click(selector = exercise_selector_hint_btn(id))$
- wait_for_js(check_popover_exists(id))$
- expect("succeed", "hint popover exists")$
- wait_for_js(
- selector_exists(
- exercise_selector_hint_popover(id),
- ".btn-tutorial-copy-solution"
- )
- )$
- expect("succeed", "hint popover has copy solution button")$
- wait_for_js(
- selector_exists(exercise_selector_hint_popover(id), ".ace_editor")
- )$
- expect("succeed", "popover has editor with hint")
+ app$wait_for_js(check_popover_closed(id), timeout = 5000)$click(
+ selector = exercise_selector_hint_btn(id)
+ )$wait_for_js(check_popover_exists(id))$expect(
+ "succeed",
+ "hint popover exists"
+ )$wait_for_js(
+ selector_exists(
+ exercise_selector_hint_popover(id),
+ ".btn-tutorial-copy-solution"
+ )
+ )$expect("succeed", "hint popover has copy solution button")$wait_for_js(
+ selector_exists(exercise_selector_hint_popover(id), ".ace_editor")
+ )$expect("succeed", "popover has editor with hint")
})
it("hint text in editor matches expectations", {
- app$expect("true", get_js(get_popover_editor_value(id)) %in% solution_text_expected)
+ app$expect(
+ "true",
+ get_js(get_popover_editor_value(id)) %in% solution_text_expected
+ )
})
it("clicks copy solution button to copy hint and close popover", {
@@ -340,9 +331,12 @@ describe("copy button", {
".btn-tutorial-copy-solution"
)
- app_real_click(app, copy_btn)$
- wait_for_js(check_popover_closed(id))$
- expect("true", get_js('navigator.clipboard.readText()') %in% solution_text_expected)
+ app_real_click(app, copy_btn)$wait_for_js(check_popover_closed(
+ id
+ ))$expect(
+ "true",
+ get_js('navigator.clipboard.readText()') %in% solution_text_expected
+ )
})
it("pastes the copied text into the editor", {
@@ -354,29 +348,27 @@ describe("copy button", {
",
exercise_selector_editor(id)
)
- )$
- expect(
- "true",
- trimws(app$get_js(get_editor_value(exercise_selector_editor(id)))) %in%
- solution_text_expected
- )
+ )$expect(
+ "true",
+ trimws(app$get_js(get_editor_value(exercise_selector_editor(id)))) %in%
+ solution_text_expected
+ )
})
it("evaluates the pasted hint text correctly", {
- app$
- click(selector = exercise_selector_run_btn(id))$
- wait_for_js(exercise_has_output(id))$
- expect(
- "equal",
- get_html(
- selector = paste(exercise_selector_output(id), "pre code"),
- outer_html = FALSE
- ),
- get_html(
- selector = "#section-ex2-expected-output pre code",
- outer_html = FALSE
- )
+ app$click(
+ selector = exercise_selector_run_btn(id)
+ )$wait_for_js(exercise_has_output(id))$expect(
+ "equal",
+ get_html(
+ selector = paste(exercise_selector_output(id), "pre code"),
+ outer_html = FALSE
+ ),
+ get_html(
+ selector = "#section-ex2-expected-output pre code",
+ outer_html = FALSE
)
+ )
})
})
})
@@ -398,30 +390,32 @@ describe("div hints", {
})
it("has a hidden hint div", {
- app$
- wait_for_js(selector_exists(div))$
- expect(
- "equal",
- get_js(selector_computed_style(div))$display,
- "none"
- )
+ app$wait_for_js(selector_exists(div))$expect(
+ "equal",
+ get_js(selector_computed_style(div))$display,
+ "none"
+ )
})
it("reveals hint when hint button is clicked", {
- app$
- click(selector = btn)$
- wait_for_js(selector_exists(hint_panel, ".tutorial-hint"))$
- expect(
- "equal",
- trimws(get_html(paste(hint_panel, ".tutorial-hint"), outer_html = FALSE)),
- "This is the HTML hint.
"
- )
+ app$click(selector = btn)$wait_for_js(selector_exists(
+ hint_panel,
+ ".tutorial-hint"
+ ))$expect(
+ "equal",
+ trimws(get_html(
+ paste(hint_panel, ".tutorial-hint"),
+ outer_html = FALSE
+ )),
+ "This is the HTML hint.
"
+ )
})
it("hides the hint when the button is clicked again", {
- app$
- click(selector = btn)$
- wait_for_js(selector_doesnt_exist(hint_panel, ".tutorial-hint"))
+ app$click(selector = btn)$wait_for_js(selector_doesnt_exist(
+ hint_panel,
+ ".tutorial-hint"
+ ))
})
})
@@ -435,30 +429,32 @@ describe("div hints", {
})
it("has a hidden hint div", {
- app$
- wait_for_js(selector_exists(div))$
- expect(
- "equal",
- get_js(selector_computed_style(div))$display,
- "none"
- )
+ app$wait_for_js(selector_exists(div))$expect(
+ "equal",
+ get_js(selector_computed_style(div))$display,
+ "none"
+ )
})
it("reveals hint when hint button is clicked", {
- app$
- click(selector = btn)$
- wait_for_js(selector_exists(hint_panel, ".tutorial-hint"))$
- expect(
- "equal",
- trimws(get_html(paste(hint_panel, ".tutorial-hint"), outer_html = FALSE)),
- "This is the md hint.
"
- )
+ app$click(selector = btn)$wait_for_js(selector_exists(
+ hint_panel,
+ ".tutorial-hint"
+ ))$expect(
+ "equal",
+ trimws(get_html(
+ paste(hint_panel, ".tutorial-hint"),
+ outer_html = FALSE
+ )),
+ "This is the md hint.
"
+ )
})
it("hides the hint when the button is clicked again", {
- app$
- click(selector = btn)$
- wait_for_js(selector_doesnt_exist(hint_panel, ".tutorial-hint"))
+ app$click(selector = btn)$wait_for_js(selector_doesnt_exist(
+ hint_panel,
+ ".tutorial-hint"
+ ))
})
})
})
diff --git a/tests/testthat/test-storage.R b/tests/testthat/test-storage.R
index 4d43eb106..2ca091c1e 100644
--- a/tests/testthat/test-storage.R
+++ b/tests/testthat/test-storage.R
@@ -1,4 +1,3 @@
-
context("storage")
test_that("filesystem storage can be created", {
@@ -8,8 +7,19 @@ test_that("filesystem storage can be created", {
test_that("objects cna be saved into filesystem storage", {
fs <- filesystem_storage(tempfile())
- fs$save_object("tutorial_id", "tutorial_version", "user_id", "object_id", "data")
- obj <- fs$get_object("tutorial_id", "tutorial_version", "user_id", "object_id")
+ fs$save_object(
+ "tutorial_id",
+ "tutorial_version",
+ "user_id",
+ "object_id",
+ "data"
+ )
+ obj <- fs$get_object(
+ "tutorial_id",
+ "tutorial_version",
+ "user_id",
+ "object_id"
+ )
expect_equal(obj, "data")
fs$remove_all_objects("tutorial_id", "tutorial_version", "user_id")
-})
\ No newline at end of file
+})
diff --git a/tests/testthat/test-tutorial-state.R b/tests/testthat/test-tutorial-state.R
index 48fa76b20..d8f341494 100644
--- a/tests/testthat/test-tutorial-state.R
+++ b/tests/testthat/test-tutorial-state.R
@@ -1,11 +1,13 @@
-
test_that("store works", {
# First write works
expect_equal(store_tutorial_cache("myName", c("code", "here"), FALSE), TRUE)
expect_equal(tutorial_cache_env$objects[["myName"]], c("code", "here"))
# Second write without overwrite is a no-op
- expect_equal(store_tutorial_cache("myName", c("updated", "code"), FALSE), FALSE)
+ expect_equal(
+ store_tutorial_cache("myName", c("updated", "code"), FALSE),
+ FALSE
+ )
expect_equal(tutorial_cache_env$objects[["myName"]], c("code", "here"))
# Overwrite returns true
@@ -49,11 +51,21 @@ test_that("get_tutorial_info() returns structured tutorial cache", {
expect_equal(all[exercises], get_exercise_cache())
expect_equal(all$`two-plus-two`, get_exercise_cache("two-plus-two"))
- expect_true(all(vapply(all[exercises], inherits, logical(1), "tutorial_exercise")))
+ expect_true(all(vapply(
+ all[exercises],
+ inherits,
+ logical(1),
+ "tutorial_exercise"
+ )))
expect_equal(all[questions], get_question_cache())
expect_equal(all$`quiz-2`, get_question_cache("quiz-2"))
- expect_true(all(vapply(all[questions], inherits, logical(1), "tutorial_question")))
+ expect_true(all(vapply(
+ all[questions],
+ inherits,
+ logical(1),
+ "tutorial_question"
+ )))
# exercises have the same `global_setup`
expect_equal(all$`two-plus-two`$global_setup, all$`add-function`$global_setup)
@@ -65,7 +77,10 @@ test_that("get_tutorial_info() returns structured tutorial cache", {
test_that("setup-global-exercise chunk is used for global_setup", {
skip_if_not_pandoc("1.14")
- prepare_tutorial_cache_from_source(test_path("setup-chunks", "exercise-global-setup.Rmd"))
+ prepare_tutorial_cache_from_source(test_path(
+ "setup-chunks",
+ "exercise-global-setup.Rmd"
+ ))
withr::defer(clear_tutorial_cache())
all <- get_tutorial_cache()
@@ -73,9 +88,16 @@ test_that("setup-global-exercise chunk is used for global_setup", {
expect_equal(as.character(all$data1$global_setup), "global <- 0")
# check that the correct chunk was used for the `global_setup`
# NOTE: this may change if the knitr hooks are refactored
- expect_equal(attr(all$data1$global_setup, "chunk_opts")$label, "setup-global-exercise")
-
- ex <- mock_exercise(user_code = "global", label = "data1", check = I("global"))
+ expect_equal(
+ attr(all$data1$global_setup, "chunk_opts")$label,
+ "setup-global-exercise"
+ )
+
+ ex <- mock_exercise(
+ user_code = "global",
+ label = "data1",
+ check = I("global")
+ )
ex$chunks <- all$data1$chunks
ex$global_setup <- all$data1$global_setup
ex$setup <- all$data1$setup
diff --git a/tools/deploy_tutorials.R b/tools/deploy_tutorials.R
index fc7de7304..ab86e2b76 100644
--- a/tools/deploy_tutorials.R
+++ b/tools/deploy_tutorials.R
@@ -1,5 +1,6 @@
-
-if (!requireNamespace("remotes")) install.packages("remotes")
+if (!requireNamespace("remotes")) {
+ install.packages("remotes")
+}
# install rsconnect
remotes::install_cran("rsconnect")
@@ -13,7 +14,7 @@ remotes::install_cran("renv")
remotes::install_cran(
setdiff(
unique(renv::dependencies("inst/tutorials/")$Package),
- unname(installed.packages()[,"Package"])
+ unname(installed.packages()[, "Package"])
)
)
diff --git a/tools/deploy_tutorials_on_ci.R b/tools/deploy_tutorials_on_ci.R
index 5b3344fca..a646e7c0a 100644
--- a/tools/deploy_tutorials_on_ci.R
+++ b/tools/deploy_tutorials_on_ci.R
@@ -1,4 +1,3 @@
-
if (!requireNamespace("remotes")) {
install.packages("remotes")
}
@@ -6,8 +5,8 @@ remotes::install_cran("rsconnect")
# Set the account info for deployment.
rsconnect::setAccountInfo(
- name = Sys.getenv("SHINYAPPS_NAME"), # learnr-examples
- token = Sys.getenv("SHINYAPPS_TOKEN"),
+ name = Sys.getenv("SHINYAPPS_NAME"), # learnr-examples
+ token = Sys.getenv("SHINYAPPS_TOKEN"),
secret = Sys.getenv("SHINYAPPS_SECRET")
)
diff --git a/tools/deploy_tutorials_on_local.R b/tools/deploy_tutorials_on_local.R
index db7f6552a..76c257f34 100644
--- a/tools/deploy_tutorials_on_local.R
+++ b/tools/deploy_tutorials_on_local.R
@@ -1,5 +1,3 @@
-
-
if (!requireNamespace("remotes")) {
install.packages("remotes")
}
diff --git a/tools/update-ace.R b/tools/update-ace.R
index 95a2a8bc4..3d6ae392a 100644
--- a/tools/update-ace.R
+++ b/tools/update-ace.R
@@ -1,67 +1,82 @@
-
(function() {
-owd <- getwd()
-on.exit({setwd(owd)})
-
-
-ROOT <- rprojroot::find_package_root_file()
-ACE_VERSION <- "1.10.1"
-ACE_FILES <- c(
- "ace.js",
- "ext-language_tools.js",
- "mode-css.js",
- "mode-html.js",
- "mode-javascript.js",
- "mode-julia.js",
- "mode-plain_text.js",
- "mode-python.js",
- "mode-r.js",
- "mode-rdoc.js",
- "mode-rhtml.js",
- "mode-sql.js",
- "mode-text.js",
- "mode-xml.js"
-)
-ACE_THEME_PREFIX <- "theme-"
-
-url <- sprintf(
- "https://github.com/ajaxorg/ace-builds/archive/v%s.tar.gz",
- ACE_VERSION
-)
+ owd <- getwd()
+ on.exit({
+ setwd(owd)
+ })
-destfile <- tempfile("ace-tarball-")
-on.exit({unlink(destfile)}, add = TRUE)
-download.file(url, destfile = destfile)
+ ROOT <- rprojroot::find_package_root_file()
+ ACE_VERSION <- "1.10.1"
+ ACE_FILES <- c(
+ "ace.js",
+ "ext-language_tools.js",
+ "mode-css.js",
+ "mode-html.js",
+ "mode-javascript.js",
+ "mode-julia.js",
+ "mode-plain_text.js",
+ "mode-python.js",
+ "mode-r.js",
+ "mode-rdoc.js",
+ "mode-rhtml.js",
+ "mode-sql.js",
+ "mode-text.js",
+ "mode-xml.js"
+ )
+ ACE_THEME_PREFIX <- "theme-"
+ url <- sprintf(
+ "https://github.com/ajaxorg/ace-builds/archive/v%s.tar.gz",
+ ACE_VERSION
+ )
-exdir <- tempfile("ace-")
-on.exit({unlink(exdir, recursive = TRUE)}, add = TRUE)
-dir.create(exdir)
-untar(tarfile = destfile, exdir = exdir)
+ destfile <- tempfile("ace-tarball-")
+ on.exit(
+ {
+ unlink(destfile)
+ },
+ add = TRUE
+ )
+ download.file(url, destfile = destfile)
-setwd(exdir)
-setwd(sprintf("ace-builds-%s", ACE_VERSION))
+ exdir <- tempfile("ace-")
+ on.exit(
+ {
+ unlink(exdir, recursive = TRUE)
+ },
+ add = TRUE
+ )
+ dir.create(exdir)
+ untar(tarfile = destfile, exdir = exdir)
+ setwd(exdir)
+ setwd(sprintf("ace-builds-%s", ACE_VERSION))
-source <- c(
- file.path("src-min", ACE_FILES),
- dir("src-min", pattern = ACE_THEME_PREFIX, full.names = TRUE)
-)
-contents <- paste(lapply(source, function(file) {
- readChar(file, file.info(file)$size, TRUE)
-}), collapse = "\n")
+ source <- c(
+ file.path("src-min", ACE_FILES),
+ dir("src-min", pattern = ACE_THEME_PREFIX, full.names = TRUE)
+ )
+ contents <- paste(
+ lapply(source, function(file) {
+ readChar(file, file.info(file)$size, TRUE)
+ }),
+ collapse = "\n"
+ )
-target <- file.path(ROOT, "inst/lib/ace/ace.js")
-writeLines(contents, con = target, sep = "\n", useBytes = TRUE)
+ target <- file.path(ROOT, "inst/lib/ace/ace.js")
+ writeLines(contents, con = target, sep = "\n", useBytes = TRUE)
-themes <- sub("^theme-", "", sub("\\.js$", "", dir("src", "^theme-")))
+ themes <- sub("^theme-", "", sub("\\.js$", "", dir("src", "^theme-")))
-metadata <- c(
- "# This file was autogenerated by 'tools/update-ace.R'",
- paste0("ACE_VERSION <- ", shQuote(ACE_VERSION, "cmd")),
- paste0("ACE_THEMES <- c(", paste0(shQuote(themes, "cmd"), collapse = ", "), ")")
-)
+ metadata <- c(
+ "# This file was autogenerated by 'tools/update-ace.R'",
+ paste0("ACE_VERSION <- ", shQuote(ACE_VERSION, "cmd")),
+ paste0(
+ "ACE_THEMES <- c(",
+ paste0(shQuote(themes, "cmd"), collapse = ", "),
+ ")"
+ )
+ )
-cat("Saving metadata:\n\n", paste0(metadata, collapse = '\n'), "\n")
-writeLines(metadata, con = file.path(ROOT, "R/ace.R"))
+ cat("Saving metadata:\n\n", paste0(metadata, collapse = '\n'), "\n")
+ writeLines(metadata, con = file.path(ROOT, "R/ace.R"))
})()