From f3006304e9cdd3acb5c4478efbeb75b304b10ed0 Mon Sep 17 00:00:00 2001 From: Garrick Aden-Buie Date: Mon, 1 Sep 2025 13:58:08 -0400 Subject: [PATCH 1/5] chore: remove unused test --- tests/testthat/test-install-dependencies.R | 14 -------------- 1 file changed, 14 deletions(-) diff --git a/tests/testthat/test-install-dependencies.R b/tests/testthat/test-install-dependencies.R index b8f81c42b..0b2d4aab7 100644 --- a/tests/testthat/test-install-dependencies.R +++ b/tests/testthat/test-install-dependencies.R @@ -29,20 +29,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()) From 497df8fa4293cb46788822977c3de105ee6ca96e Mon Sep 17 00:00:00 2001 From: Garrick Aden-Buie Date: Mon, 1 Sep 2025 13:58:25 -0400 Subject: [PATCH 2/5] fix: Use `with_mocked_bindings()` --- tests/testthat/test-exercise.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/tests/testthat/test-exercise.R b/tests/testthat/test-exercise.R index 383d42de4..04012da85 100644 --- a/tests/testthat/test-exercise.R +++ b/tests/testthat/test-exercise.R @@ -243,7 +243,7 @@ test_that("evaluate_exercise() returns an internal error when `render_exercise() skip_if_not_pandoc("1.14") local_edition(2) - with_mock( + with_mocked_bindings( "learnr:::render_exercise" = function(...) stop("render error"), expect_warning( res <- evaluate_exercise(mock_exercise(), new.env()) From 29fada887228869d2c435e81023709795cde13e7 Mon Sep 17 00:00:00 2001 From: Garrick Aden-Buie Date: Mon, 1 Sep 2025 13:59:09 -0400 Subject: [PATCH 3/5] chore: air format --- R/ace.R | 47 +- R/auto-complete.R | 57 +- R/available_tutorials.R | 58 +- R/debug_exercise_checker.R | 39 +- R/evaluators.R | 327 ++++++++---- R/events.R | 18 +- R/events_default.R | 59 +- R/events_record.R | 18 +- R/exercise.R | 504 ++++++++++++------ R/feedback.R | 38 +- R/html-dependencies.R | 4 +- R/html_selector.R | 27 +- R/http-handlers.R | 239 +++++---- R/i18n.R | 30 +- R/identifiers.R | 40 +- R/initialize.R | 27 +- R/knitr-hooks.R | 263 ++++++--- R/learnr_messages.R | 7 +- R/mock_exercise.R | 45 +- R/mutate_tags.R | 36 +- R/options.R | 28 +- R/praise.R | 28 +- R/question_answers.R | 26 +- R/question_checkbox.R | 11 +- R/question_methods.R | 8 +- R/question_numeric.R | 33 +- R/question_radio.R | 15 +- R/question_text.R | 30 +- R/quiz.R | 171 +++--- R/quiz_print.R | 85 ++- R/run.R | 201 ++++--- R/storage.R | 298 +++++++---- R/tutorial-format.R | 88 ++- R/tutorial-state.R | 55 +- R/tutorial_package_dependencies.R | 24 +- R/utils.R | 22 +- R/zzz.R | 2 - data-raw/i18n_translations.R | 39 +- inst/examples/apparmor/apparmor_evaluator.R | 16 +- inst/staticexports/knitr_engine_caption.R | 1 - inst/staticexports/strings.R | 1 - tests/testthat.R | 1 - tests/testthat/helpers-shinytest2.R | 83 +-- tests/testthat/helpers.R | 14 +- tests/testthat/test-auto-complete.R | 45 +- tests/testthat/test-available-tutorials.R | 5 +- tests/testthat/test-cookies.R | 11 +- tests/testthat/test-dependency.R | 1 - tests/testthat/test-duplicate_env.R | 2 - tests/testthat/test-evaluators.R | 239 +++++---- tests/testthat/test-events.R | 19 +- tests/testthat/test-exercise.R | 271 ++++++---- tests/testthat/test-feedback.R | 14 +- tests/testthat/test-i18n.R | 22 +- tests/testthat/test-install-dependencies.R | 8 +- tests/testthat/test-knitr-hooks.R | 72 ++- tests/testthat/test-mock_exercise.R | 20 +- tests/testthat/test-mutate_tags.R | 12 +- tests/testthat/test-options-reveal_solution.R | 29 +- tests/testthat/test-options.R | 2 - tests/testthat/test-praise.R | 20 +- tests/testthat/test-question_answers.R | 88 ++- tests/testthat/test-question_checkbox.R | 3 - tests/testthat/test-question_radio.R | 8 +- tests/testthat/test-question_text.R | 17 +- tests/testthat/test-quiz.R | 26 +- tests/testthat/test-run.R | 26 +- tests/testthat/test-shinytest2-hints.R | 406 +++++++------- tests/testthat/test-storage.R | 18 +- tests/testthat/test-tutorial-state.R | 38 +- tools/deploy_tutorials.R | 7 +- tools/deploy_tutorials_on_ci.R | 5 +- tools/deploy_tutorials_on_local.R | 2 - tools/update-ace.R | 125 +++-- 74 files changed, 3041 insertions(+), 1683 deletions(-) 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 ef2cfccc8..4fe6123d9 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("method not 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 04012da85..fd0c270e9 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" ) ) @@ -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 0b2d4aab7..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) } 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")) })() From c20783533fb697e77b4cbe97a489b90dd13932ce Mon Sep 17 00:00:00 2001 From: Garrick Aden-Buie Date: Mon, 1 Sep 2025 14:10:38 -0400 Subject: [PATCH 4/5] fix: syntax --- tests/testthat/test-exercise.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/tests/testthat/test-exercise.R b/tests/testthat/test-exercise.R index fd0c270e9..fcd7314dc 100644 --- a/tests/testthat/test-exercise.R +++ b/tests/testthat/test-exercise.R @@ -244,7 +244,7 @@ test_that("evaluate_exercise() returns an internal error when `render_exercise() local_edition(2) with_mocked_bindings( - "learnr:::render_exercise" = function(...) stop("render error"), + render_exercise = function(...) stop("render error"), expect_warning( res <- evaluate_exercise(mock_exercise(), new.env()) ) From 032db420b2ad42f30e687502f4a3bfaeab2afabe Mon Sep 17 00:00:00 2001 From: Garrick Aden-Buie Date: Wed, 12 Nov 2025 09:10:13 -0500 Subject: [PATCH 5/5] ci: Use ubuntu-latest --- .github/workflows/R-CMD-check.yaml | 14 +++++++------- 1 file changed, 7 insertions(+), 7 deletions(-) diff --git a/.github/workflows/R-CMD-check.yaml b/.github/workflows/R-CMD-check.yaml index 973a73536..19224bb56 100644 --- a/.github/workflows/R-CMD-check.yaml +++ b/.github/workflows/R-CMD-check.yaml @@ -27,12 +27,12 @@ jobs: config: - { os: macOS-latest, r: "release" } - { os: windows-latest, r: "release" } - - { os: ubuntu-20.04, r: "devel", http-user-agent: "release" } - - { os: ubuntu-20.04, r: "release" } - - { os: ubuntu-20.04, r: "oldrel-1" } - - { os: ubuntu-20.04, r: "oldrel-2" } - - { os: ubuntu-20.04, r: "oldrel-3" } - - { os: ubuntu-20.04, r: "oldrel-4" } + - { os: ubuntu-latest, r: "devel", http-user-agent: "release" } + - { os: ubuntu-latest, r: "release" } + - { os: ubuntu-latest, r: "oldrel-1" } + - { os: ubuntu-latest, r: "oldrel-2" } + - { os: ubuntu-latest, r: "oldrel-3" } + - { os: ubuntu-latest, r: "oldrel-4" } env: GITHUB_PAT: ${{ secrets.GITHUB_TOKEN }} @@ -71,7 +71,7 @@ jobs: - name: Schedule shinyapps.io deploy id: request-shinyapps-deploy - if: matrix.config.os == 'ubuntu-20.04' && matrix.config.r == 'release' + if: matrix.config.os == 'ubuntu-latest' && matrix.config.r == 'release' run: | echo "::set-output name=requested::true"