#' A checker function to use with \pkg{learnr}
#'
#' For exercise checking, \pkg{learnr} tutorials require a function that
#' \pkg{learnr} can use in the background to run the code in each "-check"
#' chunk and to format the results into a format that \pkg{learnr} can display.
#' To enable exercise checking in your learnr tutorial, attach \pkg{gradethis}
#' with `library(gradethis)`, or call `gradethis_setup()` in the setup chunk
#' of your tutorial. See `gradethis_demo()` to see an example learnr document
#' that uses `gradethis_exercise_checker()`.
#'
#' @examples
#' \dontrun{
#' gradethis_demo()
#' }
#'
#' @param label Label for exercise chunk
#' @param solution_code Code provided within the "-solution" chunk for the
#' exercise.
#' @param user_code R code submitted by the user
#' @param check_code Code provided within the "-check" (or "-code-check") chunk
#' for the exercise.
#' @param envir_result The R environment after the execution of the chunk.
#' @param evaluate_result The return value from the `evaluate::evaluate`
#' function.
#' @param envir_prep A copy of the R environment before the execution of the
#' chunk.
#' @param last_value The last value from evaluating the user's exercise
#' submission.
#' @param stage The current stage of exercise checking.
#' @param ... Extra arguments supplied by learnr
#' @param solution_eval_fn A function taking solution `code` and an `envir` (an
#' environment equivalent to `envir_prep`) and that will return the value of
#' the evaluated `code`. This callback function allows grading authors to
#' write custom solution evaluation functions for non-R exercise engines. The
#' result of the evaluated code should be an R object that will be accessible
#' to the grading code in [.solution] or [.solution_all].
#'
#' You may also provide a named list of solution evaluation functions to the
#' `gradethis.exercise_checker.solution_eval_fn` global option. The names of
#' the list should match the exercise engine for which the function should
#' be applied.
#'
#' For example, for a hypothetical exercise engine `echo` that simply echoes
#' the user's code, you could provide a `solution_eval_fn` that also just
#' echoes the solution code:
#'
#' ```
#' options(
#' gradethis.exercise_checker.solution_eval_fn = list(
#' echo = function(code, envir) {
#' code
#' }
#' )
#' )
#' ```
#'
#' Solution evaluation functions should determine if the solution code is
#' missing and if so throw an error with class `error_missing_solution` (see
#' [rlang::abort()] for help throwing this error).
#'
#' @return Returns a feedback object suitable for \pkg{learnr} tutorials with
#' the results of the exercise grading code.
#'
#' @seealso [gradethis_setup()], [grade_this()], [grade_this_code()]
#'
#' @export
gradethis_exercise_checker <- function(
label = NULL,
solution_code = NULL,
user_code = NULL,
check_code = NULL,
envir_result = NULL,
evaluate_result = NULL,
envir_prep = NULL,
last_value = NULL,
stage = NULL,
...,
solution_eval_fn = NULL
) {
# Call this function in such a way that it can use other gradethis internals when called by learnr
# (i.e., make tutorial_options(exercise.checker = gradethis::gradethis_exercise_checker) always work)
utils::getFromNamespace("check_exercise", "gradethis")(
label = label,
solution_code = solution_code,
user_code = user_code,
check_code = check_code,
envir_result = envir_result,
evaluate_result = evaluate_result,
envir_prep = envir_prep,
last_value = last_value,
stage = stage,
...
)
}
check_exercise <- function(
label = NULL,
solution_code = NULL,
user_code = NULL,
check_code = NULL,
envir_result = NULL,
evaluate_result = NULL,
envir_prep = NULL,
last_value = NULL,
stage = NULL,
...,
solution_eval_fn = NULL
) {
learnr_args <- list(
label = label,
solution_code = solution_code,
user_code = user_code,
check_code = check_code,
envir_result = envir_result,
evaluate_result = evaluate_result,
envir_prep = envir_prep,
last_value = last_value,
stage = stage,
...
)
if (length(user_code) == 0 || !any(nzchar(trimws(user_code)))) {
return(feedback(
fail("I didn't receive your code. Did you write any?"),
type = "info"
))
}
check_label <-
if (is.null(envir_result)) {
paste0(label, "-code-check")
} else {
paste0(label, "-check")
}
## setup environments for checking
# Errors in setup of exercise checking return from here
check_exercise_env <- rlang::current_env()
# Create the check environment used by grade_this() where the parent of
# check_env is a clone of `envir_prep`. We use capture_errors/graded to throw
# an internal grading problem if anything goes wrong.
check_env <- capture_errors(
capture_graded(
prepare_check_env(learnr_args, solution_eval_fn = solution_eval_fn)
),
on_error = function(err, ...) {
grade_grading_problem("Could not prepare checking environment for gradethis checking code.", error = err)
}
)
if (is_graded(check_env)) {
# An error occurred while trying to prepare the check environment
return(feedback(check_env, "error"))
}
# evaluate all checking code
to_check_fn <- capture_errors(
{
parsed_check_code <- parse(text = check_code %||% "")
capture_graded(
{
eval(parsed_check_code, envir = rlang::env_parent(check_env))
},
# if a `pass()`/`fail()` is used in the regular check chunk with no user
# submission context, it should be an error
on_graded = function(grade, ignore) {
fn_used <- if (isTRUE(grade$correct)) "`pass()`" else "`fail()`"
# notify author of their mistake
err_premature_grading <- list(
message = sprintf(
paste(
"A %s statement was executed without access to student feedback (prematurely graded).",
"Remember to only call %s inside your checking function, e.g. `grade_this({})`."
),
fn_used, fn_used
),
call = check_code,
label = check_label
)
message(err_premature_grading$message)
# return from main function (even though in a inner function! voodoo!)
rlang::return_from(
check_exercise_env,
feedback_grading_problem(error = err_premature_grading)
)
}
)
},
# if an unhandled error occurs while checking...
on_error = function(e, ignore) {
# notify author of their mistake
message("Error while checking `", check_label, "` chunk: ", e)
e$label <- check_label
e$call <- check_code
# return from main function (even though in a inner function! voodoo!)
rlang::return_from(check_exercise_env, feedback_grading_problem(error = e))
}
)
# Skip parse checking if it was already done in {learnr}
if (!learnr_includes_parse_check(stage) && identical(learnr_args$engine %||% "r", "r")) {
tryCatch(
parse(text = user_code %||% ""),
error = function(e) {
# Add the error object to the checking object
check_env$.error <- e
# Overwrite `to_check_fn` to validate the parse error function accepts
# `check_obj_envir`
to_check_fn <<- getOption("exercise.parse.error", grade_parse_error)
}
)
}
if (
!(
# make sure the returned value from check chunk evaluation is a function
checkmate::test_function(to_check_fn) &&
# ...that accepts at least 1 argument
checkmate::test_number(length(formals(to_check_fn)), lower = 1)
)
) {
# notify author of their mistake
err_not_a_function <- list(
message = paste0(
"`", check_label, "` chunk did not return a function (such as `grade_this`) ",
"that accepts 1 argument containing the checking object"
),
call = check_code,
label = check_label
)
message(err_not_a_function$message, "\nObject returned:\n", err_not_a_function$call)
return(feedback_grading_problem(error = err_not_a_function))
}
# evaluate the function with the check envir passed in. (Passing an environment allows for `.solution` to be calculated on demand)
# evaluation should handle errors themselves, but wrap in eval_gradethis to be sure
graded_result <- eval_gradethis(
to_check_fn(check_env)
)
# make sure the result is a pass or fail
if (!is_graded(graded_result)) {
if (!is.null(stage) && !identical(tolower(stage), "check")) {
# check chunks require a final answer, others might defer to later stages
return()
}
err_result_not_graded <- list(
message = paste0(
"`", check_label, "` chunk did not mark an answer as correct or incorrect.",
"Consider adding a `pass()` or `fail()` at the end of your `", check_label, "` code"
),
call = user_code,
label = check_label
)
message(err_result_not_graded$message)
return(feedback_grading_problem(error = err_result_not_graded))
}
# return result like normal
feedback(
graded_result,
type = "auto"
)
}
prepare_check_env <- function(
learnr_args,
envir_caller = rlang::caller_env(),
solution_eval_fn = NULL
) {
# The check_env starts from a copy of envir_prep which is the result of
# evaluating all of exercise setup code, duplicated to avoid the possibility
# of the checking code changing the prep environment
envir_base <- learnr::duplicate_env(learnr_args[["envir_prep"]])
check_env <- new.env(parent = envir_base)
force(envir_caller)
# Copy over all learnr args into the checking environment
for (name in names(learnr_args)) {
learnr_arg <- learnr_args[[name]]
name <- paste0(".", name)
# Ensure that code objects are always a length-1 character string
if (length(learnr_arg) > 1 && grepl("code", name) && is.character(learnr_arg)) {
learnr_arg <- paste(learnr_arg, collapse = "\n")
}
check_env[[name]] <- learnr_arg
}
# Add gradethis specific check objects
check_env[[".result"]] <- learnr_args[["last_value"]]
check_env[[".user"]] <- learnr_args[["last_value"]]
# Add full solution code options
solutions <- solutions_prepare(learnr_args[["solution_code"]])
check_env[[".solution_code_all"]] <- solutions
if (inherits(solutions, "gradethis_solutions")) {
# use last solution for .solution_code if we have multiple solutions
check_env[[".solution_code"]] <- solutions[[length(solutions)]]
}
check_env[[".envir_solution"]] <- envir_base
# Delayed evaluation of `.solution` and `.solution_all`
if (is.null(solution_eval_fn)) {
solution_eval_fn <- solution_eval_fn_get(
engine = learnr_args[["engine"]],
learnr_args[["label"]]
)
}
solution_eval_delayed(
code = check_env[[".solution_code"]] %||% "",
name = ".solution",
envir_assign = check_env,
envir_eval = envir_base,
envir_caller = envir_caller,
exercise_label = learnr_args[["label"]],
eval_fn = solution_eval_fn
)
check_env[[".solution_all"]] <-
solution_eval_all_delayed(
solutions,
envir_base,
eval_fn = solution_eval_fn
)
check_env
}
solution_eval_all_delayed <- function(
solution_code_all = NULL,
envir_base = parent.frame(),
eval_fn = NULL
) {
if (is.null(solution_code_all) || length(solution_code_all) == 0) {
return(NULL)
}
if (!inherits(solution_code_all, "gradethis_solutions")) {
solution_code_all <- solutions_prepare(solution_code_all)
}
solutions_env <- new.env()
class(solutions_env) <- "gradethis_solutions_env"
names_original <- names(solution_code_all) %||% "solution"
names(names_original) <- make.unique(names_original, sep = "_")
names(solution_code_all) <- names(names_original)
assign(".solution_labels", names_original, solutions_env)
purrr::iwalk(
solution_code_all,
solution_eval_delayed,
envir_eval = envir_base,
envir_assign = solutions_env,
eval_fn = eval_fn
)
solutions_env
}
solution_not_provided_grade <- function(label = NULL) {
grade_grading_problem(
message = "No solution is provided for this exercise.",
type = "warning",
error = list(
message = "No solution provided for this exercise",
label = label
)
)
}
solution_eval_delayed <- function(
code,
name = ".solution",
envir_assign,
envir_eval,
eval_fn = NULL,
exercise_label = NULL,
envir_caller = rlang::caller_env()
) {
delayedAssign(
assign.env = envir_assign,
x = name,
{
tryCatch(
eval_fn(code, envir_eval),
error_missing_solution = function(err) {
grade_no_solution <- solution_not_provided_grade(exercise_label)
if (!is.null(envir_caller)) {
# inside gradethis_exercise_checker or another process,
# return feedback from there
rlang::return_from(envir_caller, feedback(grade_no_solution))
}
# otherwise (e.g. mocking) just return the solution problem grade
grade_no_solution
}
)
}
)
}
solution_eval_fn_get <- function(engine, label = NULL) {
default_fns <- list(
r = solution_eval_r,
sql = solution_eval_sql
)
user_defined <- getOption("gradethis.exercise_checker.solution_eval_fn", list())
names(user_defined) <- tolower(names(user_defined))
fns_list <- utils::modifyList(default_fns, user_defined)
if (!tolower(engine) %in% names(fns_list)) {
return(solution_eval_fn_not_defined(label, engine))
}
fns_list[[tolower(engine)]]
}
solution_eval_r <- function(code, envir) {
expr <- parse(text = code)
if (length(expr) == 0) {
rlang::abort(class = "error_missing_solution")
}
eval(expr, envir = envir)
}
solution_eval_sql <- function(code, envir) {
rlang::check_installed("DBI")
# Find the DB connection in the `envir` objects
objs <- lapply(ls(envir), get, envir = envir)
is_db_con <- vapply(objs, inherits, logical(1), "DBIConnection")
con <- objs[is_db_con][[1]]
# Execute the query
DBI::dbGetQuery(con, code)
}
solution_eval_fn_not_defined <- function(label, engine) {
engine <- knitr_engine_caption(engine)
msg <- glue::glue("{gradethis_settings$grading_problem.message()} Solution results are not available for {engine} code.")
function(...) {
grade_grading_problem(
message = msg,
type = "warning",
error = list(message = msg, label = label)
)
}
}
grade_parse_error <- function(check_obj) {
# check_obj contains everything in learnr_args plus...
# - .error (parse error condition)
# - .solution (evaluated .solution_code)
# - .result (.last_value from .user_code)
# - .user (.last_value from .user_code)
#
# Code scaffolding in exercise code will cause parse errors, so first check
# for blanks. We consider a blank to be 3+ "_" characters.
n_blanks <- sum(vapply(
gregexpr("_{3,}", check_obj$.user_code),
function(x) sum(x > 0),
integer(1)
))
msg <-
if (n_blanks > 0) {
paste0(
"The exercise contains ",
if (n_blanks == 1L) {
"1 blank"
} else {
paste(n_blanks, "blanks")
},
". Please replace the `____` with valid R code."
)
} else {
paste0(
"It looks like this might not be valid R code:\n\n```r\n",
conditionMessage(check_obj$.error),
"\n```\n\nR cannot determine how to turn your text into ",
"a complete command. You may have forgotten to fill in a blank, ",
"to remove an underscore, to include a comma between arguments, ",
"or to close an opening `\"`, `'`, `(`, or `{{` ",
"with a matching `\"`, `'`, `)`, or `}}`. "
)
}
fail(message = msg, error = list(message = check_obj$.error$message, call = check_obj$.user_code))
}
learnr_includes_parse_check <- function(stage) {
if (is.null(stage)) {
return(FALSE)
}
utils::packageVersion("learnr") >= package_version("0.10.1.9017")
}
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.