#' Provide automated code feedback
#'
#' Generate a message describing the first instance of a code mismatch. Three
#' functions are provided for working with code feedback: `code_feedback()` does
#' the comparison and returns a character description of the mismatch, or a
#' `NULL` if no differences are found. `maybe_code_feedback()` is designed to be
#' used inside [fail()] and related [graded()] messages, as in
#' `"{maybe_code_feedback()}"`. And `give_code_feedback()` gives you a way to
#' add code feedback to any [fail()] message in a [grade_this()] or
#' [grade_result()] checking function.
#'
#' @section Code differences:
#'
#' There are many different ways that code can be different, yet still the same.
#' Here is how we detect code differences:
#'
#' 1. If the single values are different. Ex: `log(2)` vs `log(3)`
#' 2. If the function call is different. Ex: `log(2)` vs `sqrt(2)`
#' 3. Validate the user code can be standardized via
#' [rlang::call_standardise()]. The `env` parameter is important for this
#' step as \pkg{gradethis} does not readily know about user defined
#' functions. Ex: `read.csv("file.csv")` turns into
#' `read.csv(file = "file.csv")`
#' 4. If multiple formals are matched. Ex: `read.csv(f = "file.csv")` has `f`
#' match to `file` and `fill`.
#' 5. Verify that every named argument in the solution appears in the user
#' code. Ex: If the solution is `read.csv("file.csv", header = TRUE)`,
#' `header` must exist.
#' 6. Verify that the user did not supply extra named arguments to `...`.
#' Ex: `mean(x = 1:10, na.rm = TRUE)` vs `mean(x = 1:10)`
#' 7. Verify that every named argument in the solution matches the value of the
#' corresponding user argument. Ex: `read.csv("file.csv", header = TRUE)`
#' vs `read.csv("file.csv", header = FALSE)`
#' 8. Verify that the remaining arguments of the user and solution code match
#' in order and value. Ex: `mean(1:10, 0.1)` vs `mean(1:10, 0.2)`
#'
#' @examples
#' # code_feedback() ------------------------------------------------------
#'
#' # Values are same, so no differences found
#' code_feedback("log(2)", "log(2)")
#'
#' # Functions are different
#' code_feedback("log(2)", "sqrt(2)")
#'
#' # Standardize argument names (no differences)
#' code_feedback("read.csv('file.csv')", "read.csv(file = 'file.csv')")
#'
#' # Partial matching is not allowed
#' code_feedback("read.csv(f = 'file.csv')", "read.csv(file = 'file.csv')")
#'
#' # Feedback will spot differences in argument values...
#' code_feedback(
#' "read.csv('file.csv', header = FALSE)",
#' "read.csv('file.csv', header = TRUE)"
#' )
#'
#' # ...or when arguments are expected to appear in a call...
#' code_feedback("mean(1:10)", "mean(1:10, na.rm = TRUE)")
#'
#' # ...even when the expected argument matches the function's default value
#' code_feedback("read.csv('file.csv')", "read.csv('file.csv', header = TRUE)")
#'
#' # Unstandardized arguments will match by order and value
#' code_feedback("mean(1:10, 0.1)", "mean(1:10, 0.2)")
#'
#'
#' # give_code_feedback() -------------------------------------------------
#'
#' # We'll use this example of an incorrect exercise submission throughout
#' submission_wrong <- mock_this_exercise(
#' .user_code = "log(4)",
#' .solution_code = "sqrt(4)"
#' )
#'
#' # To add feedback to *any* incorrect grade,
#' # wrap the entire `grade_this()` call in `give_code_feedback()`:
#' grader <-
#' # ```{r example-check}
#' give_code_feedback(grade_this({
#' pass_if_equal(.solution, "Good job!")
#' if (.result < 2) {
#' fail("Too low!")
#' }
#' fail()
#' }))
#' # ```
#' grader(submission_wrong)
#'
#' # Or you can wrap the message of any fail() directly:
#' grader <-
#' # ```{r example-check}
#' grade_this({
#' pass_if_equal(.solution, "Good job!")
#' if (.result < 2) {
#' fail(give_code_feedback("Too low!"))
#' }
#' fail()
#' })
#' # ```
#' grader(submission_wrong)
#'
#' # Typically, grade_result() doesn't include code feedback
#' grader <-
#' # ```{r example-check}
#' grade_result(
#' fail_if(~ round(.result, 0) != 2, "Not quite!")
#' )
#' # ```
#' grader(submission_wrong)
#'
#' # But you can use give_code_feedback() to append code feedback
#' grader <-
#' # ```{r example-check}
#' give_code_feedback(grade_result(
#' fail_if(~ round(.result, 0) != 2, "Not quite!")
#' ))
#' # ```
#' grader(submission_wrong)
#'
#' # The default `grade_this_code()` `incorrect` message always adds code feedback,
#' # so be sure to remove \"{maybe_code_feedback()}\" from the incorrect message
#' grader <-
#' # ```{r example-check}
#' give_code_feedback(grade_this_code(incorrect = "{random_encouragement()}"))
#' # ```
#' grader(submission_wrong)
#' @param user_code,solution_code String containing user or solution code. By
#' default, when used in [grade_this()], [.user_code] is retrieved for the
#' [.user_code]. `solution_code` may also be a list containing multiple
#' solution variations, so by default in [grade_this()] [.solution_code_all]
#' is found and used for `solution_code`. You may also use `.solution_code` if
#' there is only one solution.
#' @param user_env Environment used to standardize formals of the user code.
#' Defaults to retrieving [.envir_result] from the calling environment.
#' If not found, the [parent.frame()] will be used.
#' @param solution_env Environment used to standardize formals of the solution code.
#' Defaults to retrieving [.envir_solution] from the calling environment.
#' If not found, the [parent.frame()] will be used.
#' @param env Environment used to standardize formals of the user and solution code.
#' Defaults to retrieving [.envir_result] and [.envir_solution] from [parent.frame()].
#' @param ... Ignored in `code_feedback()` and `maybe_code_feedback()`. In
#' `give_code_feedback()`, `...` are passed to `maybe_code_feedback()`.
#' @param allow_partial_matching A logical. If `FALSE`, the partial matching of
#' argument names is not allowed and e.g. `runif(1, mi = 0)` will return a
#' message indicating that the full formal name `min` should be used. The
#' default is set via the `gradethis.allow_partial_matching` option, or by
#' [gradethis_setup()].
#'
#' @return
#'
#' - `code_feedback()` returns a character value describing the difference
#' between the student's submitted code and the solution. If no
#' discrepancies are found, `code_feedback()` returns `NULL`.
#'
#' - `maybe_code_feedback()` always returns a string for safe use in glue
#' strings. If no discrepancies are found, it returns an empty string.
#'
#' - `give_code_feedback()` catches [fail()] grades and adds code feedback to
#' the feedback message using `maybe_code_feedback()`.
#'
#' @describeIn code_feedback Determine code feedback by comparing the user's
#' code to the solution.
#' @export
code_feedback <- function(
user_code = .user_code,
solution_code = .solution_code_all,
user_env = .envir_result,
solution_env = .envir_solution,
...,
allow_partial_matching = getOption("gradethis.allow_partial_matching", TRUE)
) {
ellipsis::check_dots_empty()
resolve_placeholder_parent <-
purrr::partial(
resolve_placeholder,
env_find = !!parent.frame(),
throw_grade = FALSE
)
user_env <- resolve_placeholder_parent(user_env, default = parent.frame())
solution_env <- resolve_placeholder_parent(solution_env, default = parent.frame())
user_code <- resolve_placeholder_parent(user_code, default = NULL)
solution_code <- resolve_placeholder_parent(solution_code, default = NULL)
if (inherits(solution_code, "gradethis_solutions") || is.list(solution_code)) {
# pass env?
solution_code <- solution_code_closest(
user_code,
solution_code,
user_env,
solution_env
)
}
user_expr <- to_expr(user_code, "user_code")
solution_expr <- to_expr(solution_code, "solution_code")
checkmate::assert_environment(user_env, null.ok = FALSE, .var.name = "user_env")
checkmate::assert_environment(solution_env, null.ok = FALSE, .var.name = "solution_env")
if (identical(user_expr, solution_expr)) {
# identical! return early
return(NULL)
}
# returns `NULL` if no mistakes are found
detect_mistakes(
user = user_expr,
solution = solution_expr,
user_env = new.env(parent = user_env),
solution_env = new.env(parent = solution_env),
allow_partial_matching = isTRUE(allow_partial_matching)
)
}
to_expr <- function(x, name) {
if (rlang::is_quosure(x)) {
as.expression(rlang::get_expr(x))
} else {
checkmate::assert_character(x, null.ok = FALSE, min.chars = 1L, min.len = 1, .var.name = name)
str2expression(x)
}
}
should_display_code_feedback <- function() {
isTRUE(getOption("gradethis.maybe_code_feedback", FALSE))
}
with_maybe_code_feedback <- function(val, expr) {
with_options(
list("gradethis.maybe_code_feedback" = val),
expr
)
}
solution_code_closest <- function(
user_code,
solution_code_all,
user_env,
solution_env
) {
closest_solution <- solution_code_closest_which(
user_code,
solution_code_all,
user_env,
solution_env
)
unlist(solution_code_all[closest_solution])
}
solution_code_closest_which <- function(
user_code,
solution_code_all,
user_env,
solution_env
) {
# If there's no solution code or only one solution,
# we don't need to find the closest match
if (length(solution_code_all) < 2) {
return(length(solution_code_all))
}
# Convert from list to character vector
solution_code_all <- unlist(solution_code_all)
standardise_code_text <- function(code, env) {
code %>%
unpipe_all_str() %>%
rlang::parse_exprs() %>%
call_standardise_formals_recursive(env = env) %>%
purrr::map_chr(rlang::expr_text) %>%
paste(collapse = "\n")
}
user_code <- standardise_code_text(user_code, env = user_env)
solution_code_all <- solution_code_all %>%
purrr::map_chr(standardise_code_text, env = solution_env)
# Find the index of the solution code that the user code is closest to
# which.min.last() uses the last index if there is a tie
string_distance <- utils::adist(user_code, solution_code_all)
index_min <- which(string_distance == min(string_distance))
if (length(index_min) == 1) {
return(index_min)
}
# If index_min is invalid, fallback to the last element of solution_code_all
if (
length(index_min) == 0 ||
!all(index_min %in% seq_along(solution_code_all))
) {
return(length(solution_code_all))
}
# Return last solution if it's in the tie
if (length(solution_code_all) %in% index_min) {
return(length(solution_code_all))
}
# Otherwise, return the first solution within the tie
index_min[[1]]
}
which.min.last <- function(x) { # nolint: object_name
x <- rev(x)
index <- which.min(x)
rev(seq_along(x))[index]
}
#' @describeIn code_feedback Return `code_feedback()` result when possible.
#' Useful when setting default [fail()] glue messages. For example, if there
#' is no solution, no code feedback will be given.
#'
#' @param default Default value to return if no code feedback is found or code
#' feedback can be provided.
#' @param before,after Strings to be added before or after the code feedback
#' message to ensure the message is properly formatted in your feedback.
#' @param space_before,space_after Deprecated. Use `before` and `after`.
#'
#' @export
maybe_code_feedback <- function(
user_code = get0(".user_code", parent.frame()),
solution_code = get0(".solution_code_all", parent.frame()),
user_env = get0(".envir_result", parent.frame(), ifnotfound = parent.frame()),
solution_env = get0(".envir_solution", parent.frame(), ifnotfound = parent.frame()),
...,
allow_partial_matching = getOption("gradethis.allow_partial_matching", TRUE),
default = "",
before = getOption("gradethis.maybe_code_feedback.before", " "),
after = getOption("gradethis.maybe_code_feedback.after", NULL),
space_before = deprecated(),
space_after = deprecated()
) {
ellipsis::check_dots_empty()
# if feedback is not enabled, return
if (!should_display_code_feedback()) {
return(default)
}
if (is_present(space_before)) {
deprecate_warn("0.2.3", "maybe_code_feedback(space_before=)", "maybe_code_feedback(before=)")
if (missing(before)) {
before <- if (isTRUE(space_before)) " " else ""
}
}
if (is_present(space_after)) {
deprecate_warn("0.2.3", "maybe_code_feedback(space_after=)", "maybe_code_feedback(after=)")
if (missing(after)) {
after <- if (isTRUE(space_after)) " " else ""
}
}
# ensure before and after are single strings
checkmate::check_character(before, any.missing = FALSE, null.ok = TRUE)
checkmate::check_character(after, any.missing = FALSE, null.ok = TRUE)
before <- paste(before, collapse = "\n")
after <- paste(after, collapse = "\n")
# if an error occurs, return the default value
# if no differences are found, return the default value
# if any difference is found, maybe add space before and after
capture_errors(
{
code_feedback_val <- code_feedback(
user_code = user_code,
solution_code = solution_code,
user_env = user_env,
solution_env = solution_env,
allow_partial_matching = allow_partial_matching
)
if (is.null(code_feedback_val)) {
return(default)
}
# return upgraded value
paste0(before, code_feedback_val, after)
},
on_error = function(e, that_env) {
# something bad happened. Return default value
rlang::return_from(that_env, default)
}
)
}
#' @describeIn code_feedback Appends [maybe_code_feedback()] to the
#' message generated by incorrect grades.
#'
#' @param expr A grading function — like [grade_this()] or [grade_result()] —
#' or a character string. The code feedback will be appended to the message
#' of any incorrect grades using [maybe_code_feedback()], set to always
#' include the code feedback, if possible. If `expr` is a character string,
#' `"{maybe_code_feedback()}"` is pasted into the string, without
#' customization.
#' @param location Should the code feedback message be added before or after?
#'
#' @export
give_code_feedback <- function(
expr,
...,
env = parent.frame(),
location = c("after", "before")
) {
location <- match.arg(location)
# evaluate expression in gradethis context to catch any grades
# and also turn off maybe_code_feedback so that feedback isn't repeated twice
expr_q <- rlang::get_expr(rlang::enquo(expr))
res <- with_maybe_code_feedback(
FALSE,
eval_gradethis(rlang::eval_bare(expr_q, env))
)
# then dispatch on input type internally
give_code_feedback_(res, env = env, location = location, ...)
}
give_code_feedback_ <- function(
x,
...,
env = parent.frame(),
location = c("after", "before")
) {
UseMethod("give_code_feedback_", x)
}
#' @export
give_code_feedback_.character <- function(x, ..., location = "after") {
# This just inlines maybe_code_feedback() but doesn't guarantee it will show up
mcf <- "{maybe_code_feedback()}"
before <- identical(location, "before")
paste0(if (before) mcf, x, if (!before) mcf)
}
#' @export
give_code_feedback_.function <- function(x, ..., env = NULL, location = "after") {
function(check_env) {
# get original grade without any code feedback (it will always be appended)
grade <- capture_graded(with_maybe_code_feedback(FALSE, x(check_env)))
give_code_feedback_(grade, env = check_env, location = location, ...)
}
}
#' @export
give_code_feedback_.gradethis_graded <- function(
x,
...,
env = rlang::env_parent(n = 2),
location = "after"
) {
# Use code for multiple solutions if available, otherwise single solution
solution_code <-
get0(".solution_code_all", envir = env, ifnotfound = NULL) %||%
get0(".solution_code", envir = env, ifnotfound = NULL)
user_code <- get0(".user_code", envir = env, ifnotfound = NULL)
engine <- tolower(get0(".engine", envir = env, ifnotfound = "r"))
is_not_r_ex <- !identical(engine, "r")
is_missing_solution <- is.null(solution_code)
is_correct <- identical(x$correct, TRUE)
if (is_not_r_ex || is_missing_solution || is_correct) {
signal_grade(x)
}
# What about correct grades with differences??
feedback <- with_maybe_code_feedback(
TRUE,
maybe_code_feedback(user_code, solution_code, ...)
)
# If there isn't any feedback or if the feedback message has already been
# added to the grade message, then just re-throw the grade
if (identical(feedback, "") || grepl(feedback, x$message, fixed = TRUE)) {
signal_grade(x)
}
before <- identical(location, "before")
x$message <- paste0(
if (before) feedback,
x$message,
if (!before) feedback
)
signal_grade(x)
}
#' @export
give_code_feedback_.NULL <- function(x, ...) {
invisible(NULL)
}
#' @export
give_code_feedback_.default <- function(x, ...) {
stop(
"give_code_feedback() expected a character, function, or grade.",
call. = FALSE
)
}
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.