# @staticimports inst/staticexports/
# knitr_engine_caption
detect_installed_knitr_hooks <- function() {
tutorial_chunk_opt <- knitr::opts_chunk$get("tutorial")
if (!(isTRUE(tutorial_chunk_opt) || identical(tutorial_chunk_opt, "TRUE"))) {
return(FALSE)
}
tutorial_opts_hook <- knitr::opts_hooks$get("tutorial")
if (!is.function(tutorial_opts_hook)) {
return(FALSE)
}
tutorial_knit_hook <- knitr::knit_hooks$get("tutorial")
is.function(tutorial_knit_hook)
}
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")
}
# helper to check for an exercise chunk
is_exercise_chunk <- function(options) {
isTRUE(options[["exercise"]])
}
is_chunk_empty_or_mismatched_exercise <- function(options) {
label <- options$label
if (is.null(get_knitr_chunk(label))) {
return(TRUE)
}
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())
}
if (!identical(options$exercise, chunk_opt_exercise)) {
# this looks like an exercise chunk, but knitr knows about a different
# chunk that isn't an exercise here. so there must be a problem (i.e. this
# 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)
rlang::abort(msg)
}
FALSE
}
# helper to find chunks that name a chunk as their setup chunk
exercise_chunks_for_setup_chunk <- function(label) {
label_query <- paste0("knitr::all_labels(exercise.setup == '", label, "')")
eval(parse(text = label_query))
}
ensure_knit_code_exists <- function(
current = knitr::opts_current$get(),
all = knitr::opts_chunk$get()
) {
label <- current$label
# Recreate chunk options: unique to chunk or different from default.
# Typically, we'd use `knit_code$get()` to find the chunk options defined
# directly on the chunk, but that returns `NULL` for empty chunks and
# doesn't include the chunk options. If we call this function in the options
# hooks, we have an opportunity to infer the chunk options.
chunk_opts <- current[setdiff(names(current), names(all))]
for (opt in names(all)) {
if (!identical(all[[opt]], current[[opt]])) {
chunk_opts[[opt]] <- current[[opt]]
}
}
n_lines <- current[["exercise.lines"]] %||% all[["exercise.lines"]] %||% 3L
code <- rep_len("", n_lines)
# https://github.com/yihui/knitr/blob/0f0c9c26/R/parser.R#L118
chunk <- list(structure(code, chunk_opts = chunk_opts))
names(chunk) <- label
knitr::knit_code$set(chunk)
}
# helper to check for an exercise support chunk
is_exercise_support_chunk <- function(
options,
type = c(
"setup",
"hint",
"hint-\\d+",
"solution",
"error-check",
"code-check",
"check",
"tests"
)
) {
# is this a support chunk using chunk labels to match with an exercise?
support_regex <- paste0("-(", paste(type, collapse = "|"), ")$")
if (grepl(support_regex, options$label)) {
exercise_label <- sub(support_regex, "", options$label)
label_query <- "knitr::all_labels(exercise == TRUE)"
all_exercise_labels <- eval(parse(text = label_query))
return(exercise_label %in% all_exercise_labels)
}
if ("setup" %in% type) {
if (identical(options$label, "setup-global-exercise")) {
return(TRUE)
}
# 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
if (is_referenced) {
find_parent_setup_chunks(options) # only used to check for cycles; the return value is not useful here
return(TRUE)
}
# 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, "'`",
call. = FALSE
)
}
}
FALSE
}
is_exercise_setup_chunk <- function(label) {
grepl("-setup$", label) || (length(exercise_chunks_for_setup_chunk(label)) > 0)
}
# helper function to grab the raw knitr chunk associated with a chunk label
get_knitr_chunk <- function(label) {
# Note: we directly call the knitr function in this case because we do not
# need to pass expressions which required delayed evaluation.
knitr::knit_code$get(label)
}
get_setup_global_exercise <- function() {
# setup-global-exercise is a special chunk name that will over-ride the
# global setup chunk, but only for external evaluators. This lets tutorials
# have separate setup code for the local shiny app and the remote evaluator.
knitr::knit_code$get("setup-global-exercise") %||%
knitr::knit_code$get("setup")
}
# helper function to find all the setup chunks associated with an exercise chunk
# 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))
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)
}
# 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, "'"))
setup_options <- attr(setup_chunk, "chunk_opts")
# serialize the options here so that the values are not evaluated when retrieved from learnr cache
current_setup_chunks <- if (is.null(setup_options)) {
list()
} else {
list(
list(
label = setup_label,
code = paste0(setup_chunk, collapse = "\n"),
opts = lapply(setup_options, dput_to_string),
engine = knitr_engine(setup_options$engine)
)
)
}
# recurse
append(find_parent_setup_chunks(setup_options, visited), current_setup_chunks)
}
# helper function to return a list of exercise chunk and its setup chunks
get_all_chunks <- function(options) {
# get the exercise chunk
exercise_chunk <- get_knitr_chunk(options$label)
exercise_options <- attr(exercise_chunk, "chunk_opts")
# serialize the exercise options here so that the values are not evaluated when retrieved from learnr cache
chunk_opts <- lapply(exercise_options, dput_to_string)
exercise_chunk <- paste0(exercise_chunk, collapse = "\n")
# append the setup chunks at the front
# retrieve the setup chunks associated with the exercise
# if there is no `exercise.setup` find one with "label-setup"
setup_chunks <-
if (!is.null(options$exercise.setup)) {
find_parent_setup_chunks(options)
} else if (!is.null(get_knitr_chunk(paste0(options$label, '-setup')))) {
options$exercise.setup <- paste0(options$label, '-setup')
find_parent_setup_chunks(options)
} else {
NULL
}
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))
if (is.null(exercise_chunk)) {
stop("Can not find exercise chunk for solution: `", solution_opts$label, "`")
}
# these are unevaluated options at this point
exercise_opts <- attr(exercise_chunk, "chunk_opts")
# get explicit opts on solution chunk since solution_opts was merged
# with the global knitr chunk options
sol_opts_user <- attr(get_knitr_chunk(solution_opts$label), "chunk_opts")
# 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()) %||%
# 2. the option explicitly set on the exercise chunk
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
getOption("tutorial.exercise.reveal_solution", TRUE)
isTRUE(reveal_solution)
}
# hook to turn off evaluation/highlighting for exercise related chunks
tutorial_opts_hook <- function(options) {
# ensure label is an unnamed string (yihui/knitr#2280)
options$label <- unname(options$label)
# check for chunk type
exercise_chunk <- is_exercise_chunk(options)
exercise_support_chunk <- is_exercise_support_chunk(options)
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)
}
# validate or ensure that the exercise chunk is 'defined'
if (exercise_chunk && is_chunk_empty_or_mismatched_exercise(options)) {
ensure_knit_code_exists(options)
}
# if this is an exercise chunk then set various options
if (exercise_chunk) {
# one time tutor initialization
initialize_tutorial()
options$echo <- TRUE
options$include <- TRUE
options$highlight <- FALSE
options$comment <- NA
if (!is.null(options$exercise.eval))
options$eval <- options$exercise.eval
else
options$eval <- FALSE
# exercises can be support chunks, but if it's an exercise it should be treated that way
return(options)
}
# if this is an exercise support chunk then force echo, but don't
# eval or highlight it
if (exercise_support_chunk) {
options$echo <- TRUE
options$include <- TRUE
options$eval <- FALSE
options$highlight <- FALSE
}
if (is_exercise_support_chunk(options, type = c("code-check", "error-check", "check", "tests"))) {
# completely suppress behind-the-scenes support chunks
options$include <- FALSE
}
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 ",
"exercise checker function is not configured for this tutorial. ",
"Please use `tutorial_options()` to define an `exercise.checker`."
)
}
}
if (is_exercise_support_chunk(options, type = "solution")) {
# only print solution if exercise.reveal_solution is TRUE
options$echo <- get_reveal_solution_option(options)
}
# if this is an exercise setup chunk then eval it if the corresponding
# exercise chunk is going to be executed
if (exercise_setup_chunk) {
# figure out the default behavior
exercise_eval <- knitr::opts_chunk$get('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))
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, "))")
default_reversed <- length(eval(parse(text = label_query))) > 0
if (default_reversed)
exercise_eval <- !exercise_eval
# set the eval property as appropriate
options$eval <- exercise_eval
options$echo <- FALSE
}
# If this is an -error-check function, then make sure that -check chunk is provided
if (
is_exercise_support_chunk(options, type = "error-check") &&
is.null(get_knitr_chunk(sub("-error", "", options$label)))
) {
stop(
"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.",
call. = FALSE
)
}
# return modified options
options
}
# 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) {
# before exercise
if (before) {
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)
diagnostics <- as.numeric(options$exercise.diagnostics %||% 1 > 0)
startover <- as.numeric(options$exercise.startover %||% 1 > 0)
paste0(
'<div class="tutorial-', class,
'" data-label="', options$label,
'" data-completion="', completion,
'" data-diagnostics="', diagnostics,
'" data-startover="', startover,
'" data-lines="', lines,
'" data-pipe="', htmltools::htmlEscape(exercise_option_pipe(options)),
'">'
)
}
# after exercise
else {
c(extra_html, '</div>')
}
}
# 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()
# inject ace and clipboardjs dependencies
knitr::knit_meta_add(list(
list(ace_html_dependency()),
list(clipboardjs_html_dependency())
))
# write server code
exercise_server_chunk(options$label)
}
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.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"))
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"))
# remove class of "knitr_strict_list" so (de)serializing works properly for external evaluators
class(options) <- NULL
# we collect all the setup code to make exercise compatible with old learnr
# note: this means that chained setup chunks will not work for non-R exercises
# Remove this after v0.13 is released
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)),
collapse = "\n"
)
}
this_exercise <- structure(
list(
label = options[["label"]],
global_setup = get_setup_global_exercise(),
setup = all_setup_code,
chunks = all_chunks,
code_check = code_check_chunk,
error_check = error_check_chunk,
check = check_chunk,
solution = solution,
tests = tests,
options = options[setdiff(names(options), "tutorial")],
engine = options$engine,
version = current_exercise_version
),
class = c(options$engine, "tutorial_exercise")
)
# serialize the list of chunks to server
rmarkdown::shiny_prerendered_chunk(
'server',
sprintf(
'learnr:::store_exercise_cache(%s)',
dput_to_string(this_exercise)
)
)
# script tag with knit options for this chunk
caption <-
if (!is.null(options$exercise.cap)) {
as.character(options$exercise.cap)
} else {
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")
if (file.exists(cap_engine_file)) {
as.character(htmltools::div(
class = "tutorial_engine_icon",
htmltools::HTML(readLines(cap_engine_file))
))
} else {
cap_engine_val <- knitr_engine_caption(options[["engine"]])
i18n_span(
"text.enginecap",
paste(cap_engine_val, "Code"),
opts = list(engine = cap_engine_val)
)
}
}
ui_options <- list(
engine = options$engine,
has_checker = (!is.null(check_chunk) || !is.null(code_check_chunk)),
caption = as.character(caption)
)
extra_html <- c('<script type="application/json" data-ui-opts="1">',
jsonlite::toJSON(ui_options, auto_unbox = TRUE),
'</script>')
}
# 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)) {
# 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
# send hint and solution to the browser
# these are visibly displayed in the UI
if (is_exercise_support_chunk(options, type = c("hint", "hint-\\d+"))) {
exercise_wrapper_div(suffix = "support")
} else if (is_exercise_support_chunk(options, type = "solution")) {
if (get_reveal_solution_option(options)) {
exercise_wrapper_div(suffix = "support")
}
}
}
}
list(
# learnr uses `tutorial` for options and hooks, and we also globally set the
# chunk option `tutorial = TRUE`. This allows the learnr tutorial hooks to
# visit every chunk without colliding with hooks or options set by other
# packages or Rmd formats.
opts_chunk = list(tutorial = TRUE),
opts_hooks = list(tutorial = tutorial_opts_hook),
knit_hooks = list(tutorial = tutorial_knit_hook)
)
}
install_knitr_hooks <- function() {
knit_opts <- tutorial_knitr_options()
knitr::opts_chunk$set(tutorial = knit_opts$opts_chunk$tutorial)
knitr::opts_hooks$set(tutorial = knit_opts$opts_hooks$tutorial)
knitr::knit_hooks$set(tutorial = knit_opts$knit_hooks$tutorial)
}
remove_knitr_hooks <- function() {
knitr::opts_chunk$delete("tutorial")
knitr::opts_hooks$delete("tutorial")
if (!is.null(knitr::knit_hooks$get("tutorial", default = TRUE))) {
knitr::knit_hooks$restore("tutorial")
}
}
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)
output$`tutorial-exercise-%s-output` <- renderUI({
`tutorial-exercise-%s-result`()
})', label, label, label, label))
}
verify_tutorial_chunk_label <- function() {
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)
}
not_valid_char_regex <- "[^a-zA-Z0-9_-]"
if (grepl(not_valid_char_regex, label)) {
stop(
"Code chunks labels for exercises or quiz questions must only be labeled using:",
"\n\tlower case letters: a-z",
"\n\tupper case letters: A-Z",
"\n\tnumbers case letters: 0-9",
"\n\tunderscore: _",
"\n\tdash: -",
"\n\nCurrent label: \"", label ,"\"",
"\n\nTry using: \"", gsub(not_valid_char_regex, "_", label) ,"\"",
call. = FALSE
)
}
}
exercise_option_pipe <- function(options = knitr::opts_chunk$get()) {
if (!is.null(options[["exercise.pipe"]])) {
return(options[["exercise.pipe"]])
}
if (getRversion() < "4.1.0") "%>%" else "|>"
}
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.