Add initial support for test cases

NEWS.md

@@ -54,6 +54,8 @@
 
 -   Authors can choose to reveal (default) or hide the solution to an exercise. Set `exercise.reveal_solution` in the chunk options of a `*-solution` chunk to choose whether or not the solution is revealed to the user. The option can also be set globally with `tutorial_options()`. In a future version of learnr, the default will likely be changed to hide solutions (#402).
 
+-   Exercises may now include `-tests` chunks. These chunks don't appear in the tutorial text but the code in them is stored in the internal exercise data. In the future, these chunks will be used to provide automated exercise testing (#664).
+
 -   Keyboard navigation and keyboard shortcuts for the interactive exercise code editor have been improved:
 
     -   To avoid trapping keyboard focus and to allow users to navigate through a tutorial with the keyboard, pressing <kbd>Esc</kbd> in an interactive exercise code editor now temporarily disables the use of <kbd>Tab</kbd> for indenting, making it possible for users to move to the next or previous element in the tutorial (#652).

R/evaluators.R

@@ -38,7 +38,7 @@ setup_forked_evaluator_factory <- function(max_forked_procs){
   running_exercises <- 0
 
   function(expr, timelimit, ...) {
-    if (is_macos()) {
+    if (is_mac()) {
       rlang::warn("Forked evaluators may not work as expected on MacOS")
     } else if (is_windows()) {
       rlang::warn("Forked evaluators may not work as expected on Windows")

R/exercise.R

@@ -69,7 +69,7 @@ setup_exercise_handler <- function(exercise_rx, session) {
       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_macos())
+      } else if (!is_windows() && !is_mac())
         evaluator_factory <- forked_evaluator_factory
       else
         evaluator_factory <- inline_evaluator
@@ -290,7 +290,7 @@ validate_exercise <- function(exercise, require_items = NULL) {
 }
 
 standardize_code <- function(code) {
-  if (inherits(code, "AsIs")) {
+  if (is_AsIs(code)) {
     return(code)
   }
   if (is.null(code) || !length(code)) {
@@ -1089,7 +1089,7 @@ exercise_result <- function(
 
   if (is.character(feedback$html) && any(nzchar(feedback$html))) {
     feedback$html <- htmltools::HTML(feedback$html)
-  } else if (!inherits(feedback$html, c("shiny.tag", "shiny.tag.list", "html"))) {
+  } else if (!is_html_any(feedback$html)) {
     feedback$html <- feedback_as_html(feedback)
   }
 
@@ -1261,7 +1261,7 @@ debug_exercise_checker <- function(
   ...
 ) {
   # Use I() around check_code to indicate that we want to evaluate the check code
-  checker_result <- if (inherits(check_code, "AsIs")) {
+  checker_result <- if (is_AsIs(check_code)) {
     local(eval(parse(text = check_code)))
   }
 

R/knitr-hooks.R

@@ -40,7 +40,8 @@ tutorial_knitr_options <- function() {
       "solution",
       "error-check",
       "code-check",
-      "check"
+      "check",
+      "tests"
     )
   ) {
     # is this a support chunk using chunk labels to match with an exercise?
@@ -236,7 +237,8 @@ tutorial_knitr_options <- function() {
       options$highlight <- FALSE
     }
 
-    if (is_exercise_support_chunk(options, type = c("code-check", "error-check", "check"))) {
+    if (is_exercise_support_chunk(options, type = c("code-check", "error-check", "check", "tests"))) {
+      # completely suppress behind-the-scenes support chunks
       options$include <- FALSE
     }
 
@@ -361,6 +363,7 @@ tutorial_knitr_options <- function() {
         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"))
+        test_cases <- get_knitr_chunk(paste0(options$label, "-tests"))
 
         # remove class of "knitr_strict_list" so (de)serializing works properly for external evaluators
         class(options) <- NULL
@@ -384,6 +387,7 @@ tutorial_knitr_options <- function() {
             error_check = error_check_chunk,
             check = check_chunk,
             solution  = solution,
+            test_cases = split_code_headers(test_cases, "test"),
             options = options[setdiff(names(options), "tutorial")],
             engine = options$engine
           ),

R/mock_exercise.R

@@ -6,9 +6,10 @@ mock_exercise <- function(
   global_setup = NULL,
   setup_label = NULL,
   solution_code = NULL,
-  code_check = NULL,  # code_check_chunk
-  error_check = NULL, # error_check_chunk
-  check = NULL,       # check_chunk
+  code_check = NULL,  # code_check chunk
+  error_check = NULL, # error_check chunk
+  check = NULL,       # check chunk
+  tests = NULL,       # tests chunk
   exercise.checker = dput_to_string(debug_exercise_checker),
   exercise.error.check.code = dput_to_string(debug_exercise_checker),
   exercise.df_print = "default",
@@ -74,6 +75,7 @@ mock_exercise <- function(
     code_check = code_check,
     error_check = error_check,
     check = check,
+    tests = split_code_headers(tests, "test"),
     options = utils::modifyList(default_options, list(...)),
     engine = engine,
     version = version

R/question_answers.R

@@ -36,7 +36,7 @@
 #' @describeIn answer Create an answer option
 #' @export
 answer <- function(text, correct = FALSE, message = NULL, label = text) {
-  if (!is_tags(message)) {
+  if (!is_html_tag(message)) {
     checkmate::assert_character(message, len = 1, null.ok = TRUE, any.missing = FALSE)
   }
 

R/quiz.R

@@ -223,10 +223,7 @@ question <- function(
 
 # render markdown (including equations) for quiz_text
 quiz_text <- function(text) {
-  if (inherits(text, "html")) {
-    return(text)
-  }
-  if (is_tags(text)) {
+  if (is_html_chr(text) || is_html_tag(text)) {
     return(text)
   }
   if (!is.null(text)) {

R/staticimports.R

@@ -0,0 +1,151 @@
+# Generated by staticimports; do not edit by hand.
+# ======================================================================
+# Imported from inst/staticexports/
+# ======================================================================
+
+is_AsIs <- function(x) {
+  inherits(x, "AsIs")
+}
+
+is_html_any <- function(x) {
+  is_html_tag(x) || is_html_chr(x)
+}
+
+is_html_chr <- function(x) {
+  is.character(x) && inherits(x, "html")
+}
+
+is_html_tag <- function(x) {
+  inherits(x, c("shiny.tag", "shiny.tag.list"))
+}
+
+split_code_headers <- function(code, prefix = "section") {
+  if (is.null(code)) {
+    return(NULL)
+  }
+
+  code <- paste(code, collapse = "\n")
+  code <- str_trim(code, character = "[\r\n]")
+  code <- strsplit(code, "\n")[[1]]
+
+  rgx_header <- "^(#+)([ -]*)(.+?)?\\s*----+$"
+  headers <- regmatches(code, regexec(rgx_header, code, perl = TRUE))
+  lines_headers <- which(vapply(headers, length, integer(1)) > 0)
+
+  if (length(lines_headers) > 0 && max(lines_headers) == length(code)) {
+    # nothing after last heading
+    lines_headers <- lines_headers[-length(lines_headers)]
+  }
+
+  if (!length(lines_headers)) {
+    return(list(paste(code, collapse = "\n")))
+  }
+
+  # header names are 3rd group, so 4th place in match since 1st is the whole match
+  header_names <- vapply(headers[lines_headers], `[[`, character(1), 4)
+  header_names <- str_trim(header_names)
+  if (any(!nzchar(header_names))) {
+    header_names[!nzchar(header_names)] <- sprintf(
+      paste0(prefix, "%02d"),
+      which(!nzchar(header_names))
+    )
+  }
+
+  rgx_header_line <- gsub("[$^]", "(^|\n|$)", rgx_header)
+  sections <- strsplit(paste(code, collapse = "\n"), rgx_header_line, perl = TRUE)[[1]]
+  if (length(sections) > length(header_names)) {
+    header_names <- c(paste0(prefix, "00"), header_names)
+  }
+  names(sections) <- header_names
+
+  # trim leading/trailing new lines from code section
+  sections <- str_trim(sections, character = "[\r\n]")
+  # drop any sections that don't have anything in them
+  sections <- sections[nzchar(str_trim(sections))]
+
+  as.list(sections)
+}
+
+str_trim <- function(x, side = "both", character = "\\s") {
+  if (side %in% c("both", "left", "start")) {
+    rgx <- sprintf("^%s+", character)
+    x <- sub(rgx, "", x)
+  }
+  if (side %in% c("both", "right", "end")) {
+    rgx <- sprintf("%s+$", character)
+    x <- sub(rgx, "", x)
+  }
+  x
+}
+# Generated by staticimports; do not edit by hand.
+# ======================================================================
+# Imported from pkg:staticimports
+# ======================================================================
+
+`%||%` <- function(a, b) {
+  if (is.null(a)) b else a
+}
+
+get_package_version <- function(pkg) {
+  # `utils::packageVersion()` can be slow, so first try the fast path of
+  # checking if the package is already loaded.
+  ns <- .getNamespace(pkg)
+  if (is.null(ns)) {
+    utils::packageVersion(pkg)
+  } else {
+    as.package_version(ns$.__NAMESPACE__.$spec[["version"]])
+  }
+}
+
+is_installed <- function(pkg, version = NULL) {
+  installed <- isNamespaceLoaded(pkg) || nzchar(system_file_cached(package = pkg))
+  if (is.null(version)) {
+    return(installed)
+  }
+  installed && isTRUE(get_package_version(pkg) >= version)
+}
+
+is_linux   <- function() Sys.info()[['sysname']] == 'Linux'
+
+is_mac     <- function() Sys.info()[['sysname']] == 'Darwin'
+
+is_windows <- function() .Platform$OS.type == "windows"
+
+os_name <- function() {
+  if (is_windows()) {
+    "win"
+  } else if (is_mac()) {
+    "mac"
+  } else if (is_linux()) {
+    "linux"
+  } else if (.Platform$OS.type == "unix") {
+    "unix"
+  } else {
+    "unknown"
+  }
+}
+
+# A wrapper for `system.file()`, which caches the results, because
+# `system.file()` can be slow. Note that because of caching, if
+# `system_file_cached()` is called on a package that isn't installed, then the
+# package is installed, and then `system_file_cached()` is called again, it will
+# still return "".
+system_file_cached <- local({
+  pkg_dir_cache <- character()
+
+  function(..., package = "base") {
+    if (!is.null(names(list(...)))) {
+      stop("All arguments other than `package` must be unnamed.")
+    }
+
+    not_cached <- is.na(match(package, names(pkg_dir_cache)))
+    if (not_cached) {
+      pkg_dir <- system.file(package = package)
+      pkg_dir_cache[[package]] <<- pkg_dir
+    } else {
+      pkg_dir <- pkg_dir_cache[[package]]
+    }
+
+    file.path(pkg_dir, ...)
+  }
+})

R/utils.R

@@ -1,13 +1,13 @@
-"%||%" <- function(x, y) if (is.null(x)) y else x
-
-is_windows <- function() {
-  .Platform$OS.type == 'windows'
-}
-
-is_macos <- function() {
-  Sys.info()[["sysname"]] == "Darwin"
-}
+# @staticimports inst/staticexports/
+#   split_code_headers
+#   str_trim
+#   is_AsIs
+#   is_html_tag is_html_chr is_html_any
 
+# @staticimports pkg:staticimports
+#   os_name
+#   %||%
+#   is_installed
 
 is_localhost <- function(location) {
   if (is.null(location))
@@ -60,16 +60,6 @@ if (getRversion() < package_version("3.6.0")) {
   }
 }
 
-str_trim <- function(x) {
-  sub(
-    "\\s+$", "",
-    sub(
-      "^\\s+", "",
-      as.character(x)
-    )
-  )
-}
-
 if_no_match_return_null <- function(x) {
   if (length(x) == 0) {
     NULL
@@ -113,25 +103,10 @@ str_extract <- function(x, pattern, ...) {
   unlist(regmatches(x, regexpr(pattern, x, ...)))
 }
 
-is_tags <- function(x) {
-  inherits(x, "shiny.tag") ||
-    inherits(x, "shiny.tag.list")
-}
-
 knitr_engine <- function(engine) {
   tolower(engine %||% "r")
 }
 
-is_installed <- function(package, version = NULL) {
-  if (system.file(package = package) == "") {
-    return(FALSE)
-  }
-  if (!is.null(version) && utils::packageVersion(package) < version) {
-    return(FALSE)
-  }
-  TRUE
-}
-
 timestamp_utc <- function() {
   strftime(Sys.time(), "%F %H:%M:%OS3 %Z", tz = "UTC")
 }

inst/staticexports/assertions.R

@@ -0,0 +1,15 @@
+is_AsIs <- function(x) {
+  inherits(x, "AsIs")
+}
+
+is_html_tag <- function(x) {
+  inherits(x, c("shiny.tag", "shiny.tag.list"))
+}
+
+is_html_chr <- function(x) {
+  is.character(x) && inherits(x, "html")
+}
+
+is_html_any <- function(x) {
+  is_html_tag(x) || is_html_chr(x)
+}