Support answer-functions (#657)

.Rbuildignore

@@ -39,3 +39,4 @@ rsconnect/
 ^\.eslintignore$
 ^\.vscode$
 ^inst/tutorials/*/*_files$
+^tests/manual$

DESCRIPTION

@@ -2,53 +2,28 @@ Type: Package
 Package: learnr
 Title: Interactive Tutorials for R
 Version: 0.10.1.9019
-Authors@R:
-    c(person(given = "Garrick",
-             family = "Aden-Buie",
-             role = c("aut", "cre"),
-             email = "[email protected]",
-             comment = c(ORCID = "0000-0002-7111-0077")),
-      person(given = "Barret",
-             family = "Schloerke",
-             role = "aut",
-             email = "[email protected]",
-             comment = c(ORCID = "0000-0001-9986-114X")),
-      person(given = "JJ",
-             family = "Allaire",
-             role = c("aut", "ccp"),
-             email = "[email protected]"),
-      person(given = "Alexander",
-             family = "Rossell Hayes",
-             role = "ctb",
-             email = "[email protected]",
-             comment = c(ORCID = "0000-0001-9412-0457")),
-      person(given = "Nischal",
-             family = "Shrestha",
-             role = "ctb",
-             email = "[email protected]",
-             comment = c(ORCID = "0000-0003-3321-1712")),
-      person(given = "Angela",
-             family = "Li",
-             role = "ctb",
-             email = "[email protected]",
-             comment = "vignette"),
-      person(given = "RStudio",
-             role = c("cph", "fnd")),
-      person(family = "Ajax.org B.V.",
-             role = c("ctb", "cph"),
-             comment = "Ace library"),
-      person(given = "Zeno",
-             family = "Rocha",
-             role = c("ctb", "cph"),
-             comment = "clipboard.js library"),
-      person(given = "Nick",
-             family = "Payne",
-             role = c("ctb", "cph"),
-             comment = "Bootbox library"),
-      person(given = "Jake",
-             family = "Archibald",
-             role = c("ctb", "cph"),
-             comment = "idb-keyval library"))
+Authors@R:c(
+    person("Garrick", "Aden-Buie", , "[email protected]", role = c("aut", "cre"),
+           comment = c(ORCID = "0000-0002-7111-0077")),
+    person("Barret", "Schloerke", , "[email protected]", role = "aut",
+           comment = c(ORCID = "0000-0001-9986-114X")),
+    person("JJ", "Allaire", , "[email protected]", role = c("aut", "ccp")),
+    person("Alexander", "Rossell Hayes", , "[email protected]", role = "ctb",
+           comment = c(ORCID = "0000-0001-9412-0457")),
+    person("Nischal", "Shrestha", , "[email protected]", role = "ctb",
+           comment = c(ORCID = "0000-0003-3321-1712")),
+    person("Angela", "Li", , "[email protected]", role = "ctb",
+           comment = "vignette"),
+    person("RStudio", role = c("cph", "fnd")),
+    person(, "Ajax.org B.V.", role = c("ctb", "cph"),
+           comment = "Ace library"),
+    person("Zeno", "Rocha", role = c("ctb", "cph"),
+           comment = "clipboard.js library"),
+    person("Nick", "Payne", role = c("ctb", "cph"),
+           comment = "Bootbox library"),
+    person("Jake", "Archibald", role = c("ctb", "cph"),
+           comment = "idb-keyval library")
+  )
 Description: Create interactive tutorials using R Markdown. Use a
     combination of narrative, figures, videos, exercises, and quizzes to
     create self-paced tutorials for learning about R and R packages.
@@ -65,6 +40,7 @@ Imports:
     htmlwidgets,
     jsonlite,
     knitr (>= 1.31),
+    lifecycle,
     markdown,
     parallel,
     promises,
@@ -74,6 +50,7 @@ Imports:
     rmarkdown (>= 1.12.0),
     rprojroot,
     shiny (>= 1.0),
+    stats,
     utils,
     withr
 Suggests:

NAMESPACE

@@ -31,6 +31,7 @@ S3method(question_ui_initialize,learnr_radio)
 S3method(question_ui_initialize,learnr_text)
 S3method(question_ui_try_again,default)
 export(answer)
+export(answer_fn)
 export(available_tutorials)
 export(correct)
 export(disable_all_tags)
@@ -85,6 +86,7 @@ importFrom(knitr,opts_chunk)
 importFrom(knitr,opts_hooks)
 importFrom(knitr,opts_knit)
 importFrom(knitr,spin)
+importFrom(lifecycle,deprecated)
 importFrom(markdown,markdownExtensions)
 importFrom(markdown,markdownToHTML)
 importFrom(promises,"%>%")
@@ -102,6 +104,5 @@ importFrom(shiny,req)
 importFrom(stats,runif)
 importFrom(utils,getFromNamespace)
 importFrom(utils,installed.packages)
-importFrom(utils,modifyList)
 importFrom(utils,write.table)
 importFrom(withr,with_envvar)

NEWS.md

@@ -102,6 +102,10 @@
 
 ### Questions
 
+-   Authors can now provide function-answers with `answer_fn()`. Authors can provide a function that takes a single argument that will be passed the student's question submission. This function decides if the question is correct and provides feedback by returning `correct()` or `incorrect()` with a feedback message (#657).
+
+-   A new `question_numeric()` question type allows authors to ask users to provide a number (#461).
+
 -   `question_text()` gains `rows` and `cols` parameters. If either is provided, a multi-line `textAreaInput()` is used for the text input (thanks @dtkaplan #455, #460).
 
 -   Correct/incorrect question markers are now configurable via CSS. You can change or style these markers using the `.tutorial-question .question-final .correct::before` and `.tutorial-question .question-final .incorrect::before` selectors. A new helper function, `finalize_question()`, can be used to apply the `.question-final` class to custom learnr questions (#531).
@@ -110,7 +114,7 @@
 
 -   Fixed unexpected behavior for `question_is_correct.learnr_text()` where `trim = FALSE`. Comparisons will now happen with the original input value, not the `HTML()` formatted answer value (#376).
 
--   When a quiz’s question or answer text are not characters, e.g. HTML, `{htmltools}` tags, numeric, etc., they are now cast to characters for the displayed answer text and the quiz’s default loading text (#450).
+-   When a quiz’s question or answer text are not characters, e.g. HTML, `{htmltools}` tags, numeric, etc., they are now cast to characters for the displayed answer text and the quiz’s default loading text (#450).
 
 ## Events and State
 

R/knitr-hooks.R

@@ -300,6 +300,11 @@ tutorial_knitr_options <- function() {
 
   # hook to amend output for exercise related chunks
   tutorial_knit_hook <- function(before, options, envir) {
+    if (!before) {
+      # Signal any messages added during the chunk evaluation. This exists so
+      # that we can direct messages to the console even if created inside a chunk
+      .learnr_messages$flush()
+    }
 
     # helper to produce an exercise wrapper div w/ the specified class
     exercise_wrapper_div <- function(suffix = NULL, extra_html = NULL) {
@@ -499,7 +504,9 @@ install_knitr_hooks <- function() {
 remove_knitr_hooks <- function() {
   knitr::opts_chunk$delete("tutorial")
   knitr::opts_hooks$delete("tutorial")
-  knitr::knit_hooks$delete("tutorial")
+  if (!is.null(knitr::knit_hooks$get("tutorial", default = TRUE))) {
+    knitr::knit_hooks$restore("tutorial")
+  }
 }
 
 exercise_server_chunk <- function(label) {

R/learnr-package.R

@@ -18,6 +18,7 @@
 #' @importFrom knitr opts_hooks
 #' @importFrom knitr opts_knit
 #' @importFrom knitr spin
+#' @importFrom lifecycle deprecated
 #' @importFrom markdown markdownExtensions
 #' @importFrom markdown markdownToHTML
 #' @importFrom rprojroot find_root
@@ -29,6 +30,7 @@
 #' @importFrom shiny reactive
 #' @importFrom shiny reactiveValues
 #' @importFrom shiny req
+#' @importFrom stats runif
 #' @importFrom withr with_envvar
 ## usethis namespace: end
 NULL

R/learnr_messages.R

@@ -0,0 +1,78 @@
+# {learnr} functions are intended to be written into R Markdown documents,
+# but there are certain times when we'd like to warn tutorial authors of
+# potential issues without the warning text appearing in the actual tutorial.
+# Since we can't ask users to set message = FALSE globally, we have to do our
+# own thing. Instead, we have a way to create messages that are automatically
+# added to a queue of items when knitting is in progress -- if we're not knitting
+# then we just emit the message immediately. Then we take advantage of the
+# `tutorial` knit hook that runs before and after each chunk in the tutorial.
+# In the after run, we flush the queue and re-signal the condition so that it
+# appears in the render console, thus avoiding writing to the tutorial HTML.
+
+.learnr_messages <- local({
+  queue <- list()
+  list(
+    peek = function() {
+      if (length(queue)) queue
+    },
+    flush = function() {
+      while(length(queue)) {
+        cnd <- queue[[1]]
+        if (inherits(cnd, "error")) {
+          # throw errors, they're immediate
+          rlang::cnd_signal(cnd)
+        } else {
+          # otherwise report condition as a message, but re-signal warnings
+          msg <- rlang::cnd_message(cnd)
+
+          if (inherits(cnd, "warning")) {
+            mgs <- paste0("Warning: ", msg)
+            rlang::cnd_signal(cnd)
+          }
+
+          rlang::inform(msg, class = "learnr_render_message")
+        }
+        queue[[1]] <<- NULL
+      }
+    },
+    add = function(cnd) {
+      queue <<- c(queue, list(cnd))
+      invisible(cnd)
+    }
+  )
+})
+
+learnr_render_message <- function(..., level = c("inform", "warn", "abort")) {
+  create_cnd <- switch(
+    tolower(level),
+    inform = rlang::inform,
+    warn = rlang::warn,
+    abort = rlang::abort
+  )
+  cnd <- rlang::catch_cnd(create_cnd(paste0(..., "\n"), "learnr_render_message"))
+
+  if (isTRUE(getOption('knitr.in.progress'))) {
+    .learnr_messages$add(cnd)
+  } else {
+    rlang::cnd_signal(cnd)
+  }
+}
+
+learnr_render_catch <- function(expr, env = rlang::caller_env()) {
+  cnd <- tryCatch(
+    rlang::eval_bare(expr, env),
+    error = identity,
+    warning = identity,
+    message = identity
+  )
+
+  if (!inherits(cnd, "condition")) {
+    return(invisible())
+  }
+
+  if (isTRUE(getOption('knitr.in.progress'))) {
+    .learnr_messages$add(cnd)
+  } else {
+    rlang::cnd_signal(cnd)
+  }
+}

R/praise.R

@@ -41,13 +41,15 @@ random_phrases <- function(type, language = NULL) {
   }
 
   warn_unsupported_language <- function(language, default = "en") {
+    # warns if requested language isn't supported,
+    # otherwise recurses to fall back to default
     if (is.null(language)) {
       return(warn_unsupported_language(default))
     }
     if (!language %in% names(.random_phrases[[type]])) {
-      warning(
+      learnr_render_message(
         "learnr doesn't know how to provide ", type, " in the language '", language, "'",
-        call. = FALSE
+        level = "warn"
       )
       return(warn_unsupported_language(default))
     }