# Each case should have a function that takes both strings and quotes, and hence
# is easy to drop into testthat. ("that" always refers to correct/solution code,
# because it is not at hand in the submission. "this" always refers to
# incorrect/user code, which is always at hand). Cases:
message_extra_answer <- function(this_line) {
glue::glue_data(
list(
this_line = prep(this_line)
),
"I didn't expect the call {this_line} in your answer. Please remove it and resubmit your work."
)
}
message_missing_answer <- function(this_prior_line) {
glue::glue_data(
list(
this_prior_line = prep(this_prior_line)
),
"I expected another call after {this_prior_line}. Did you forget to write one?"
)
}
# bad argument name
message_bad_argument_name <- function(
submitted_call,
submitted,
submitted_name,
enclosing_call = NULL,
enclosing_arg = NULL
) { # only if the user supplied one (to match user code)
# f(1, g(1, h(b = i(1))))
# f(1, a = g(1, a = h(ba = i(1)), bb = i(2)))
# In f(1, g(1, h(b = i(1)))), h() accepts more than one argument that begins with b.
# As a result, R cannot figure out which argument you want to pass i(1) to.
# Check how you spelled b, or write out the full argument name.
# {intro}{submitted_call} accepts more than one argument that begins with {submitted_name}.
# As a result, R cannot figure out which argument you want to pass {submitted} to.
# Check how you spelled {submitted_name}, or write out the full argument name.
intro <- build_intro(.call = enclosing_call, .arg = enclosing_arg)
submitted <- prep(submitted)
submitted_call <- prep(submitted_call)
if (grepl("\\(\\)", submitted))
submitted <- paste("a call to", submitted)
glue::glue_data(
list(
intro = intro,
submitted_call = submitted_call,
submitted_name = submitted_name,
submitted = submitted
),
"{intro}{submitted_call} accepts more than one argument name that begins ",
"with `{submitted_name}`. As a result, R cannot figure out which ",
"argument you want to pass {submitted} to. Check how you spelled ",
"`{submitted_name}`, or write out the full argument name."
)
}
# duplicate_name
message_duplicate_name <- function(
submitted_call,
submitted_name,
enclosing_call = NULL,
enclosing_arg = NULL
) {
# f(a = 1, a = 2)
# f(a = 1)
# "You passed multiple arguments named a to f(), which will cause "
# "an error. Check your spelling, or remove one of the arguments."
# "You passed multiple arguments named {submitted_name} to {submitted_call},
# "which will cause an error. Check your spelling, or remove one of the arguments."
submitted_call <- prep(submitted_call)
submitted_name <- prep(submitted_name)
intro <- build_intro(.call = enclosing_call, .arg = enclosing_arg)
glue::glue_data(
list(
intro = intro,
submitted_call = submitted_call,
submitted_name = submitted_name
),
"You passed multiple arguments named {submitted_name} ",
"to {submitted_call}, which will cause an error. ",
"Check your spelling, or remove one of the arguments."
)
}
# WHAT TO DO IF THE MISSING ARGUMENT DOESN'T HAVE A NAME IN THE SOLUTION?
# missing argument
message_missing_argument <- function(
submitted_call,
solution_name = NULL,
enclosing_call = NULL,
enclosing_arg = NULL
) {
# f(1, g(1, h(i(1))))
# f(1, a = g(1, a = h(a = i(1)), b = i(2)))
# "In g(1, h(i(1))), Your call to h() should include b",
# "as one of its arguments. You may have referred to it ",
# "in a different way, or left out an important argument name."
# "{intro}Your call to {submitted_call} should include {solution_name} ",
# "as one of its arguments. You may have referred to it ",
# "in a different way, or left out an important argument name."
intro <- build_intro(.call = enclosing_call, .arg = enclosing_arg)
your_char <- ifelse(intro == "", "Y", "y")
submitted_call <- prep(submitted_call)
solution_name <- prep(solution_name)
if (grepl("\\(\\)", solution_name)) {
solution_name <- paste0("an argument, possibly unnamed, that calls ", solution_name, ".")
} else {
solution_name <- paste(solution_name, "as one of its arguments.")
}
glue::glue_data(
list(
intro = intro,
submitted_call = submitted_call,
solution_name = solution_name
),
"{intro}{your_char}our call to {submitted_call} should include {solution_name} ",
"You may have misspelled an argument name, ",
"or left out an important argument."
)
}
# surplus argument
message_surplus_argument <- function(
submitted_call,
submitted,
submitted_name = NULL,
enclosing_call = NULL,
enclosing_arg = NULL
) {
# f(1, g(1, h(1, b = i(1))))
# f(1, a = g(1, a = h(a = 1)))
# "In g(1, h(1, i(1))), I did not expect your call to h() to ",
# "include b = i(1). You ",
# "may have included an unnecessary argument, or you ",
# "may have left out or misspelled an important ",
# "argument name."
# "{intro}I did not expect your call to {submitted_call} to ",
# "include {submitted}. You ",
# "may have included an unnecessary argument, or you ",
# "may have left out or misspelled an important ",
# "argument name."
intro <- build_intro(.call = enclosing_call, .arg = enclosing_arg)
submitted_call <- prep(submitted_call)
submitted <- prep(submitted)
if (!is.null(submitted_name) && submitted_name != "")
submitted <- md_code_prepend(paste(submitted_name, "= "), submitted)
glue::glue_data(
list(
submitted = submitted,
submitted_call = submitted_call
),
"{intro}I did not expect your call to {submitted_call} to ",
"include {submitted}. You ",
"may have included an unnecessary argument, or you ",
"may have left out or misspelled an important ",
"argument name."
)
}
# partial matching
message_pmatches_argument_name <- function(
submitted_call,
submitted,
submitted_name = NULL,
solution_name = NULL,
enclosing_call = NULL,
enclosing_arg = NULL
) {
# "{intro}I did not expect your call to {submitted_call} to ",
# "include {submitted}. You ",
# "may have included an unnecessary argument, or you ",
# "may have left out or misspelled an important ",
# "argument name."
# intro <- build_intro(.call = enclosing_call, .arg = enclosing_arg)
# "This code seems correct, but please write with full parameter(s) names."
# "You wrote {submitted} please rewrite with {solution_name} ."
# "You wrote {submitted} please rewrite with {solution_name} ."
submitted_call <- prep(submitted_call)
submitted <- lapply(submitted, prep) #yes devrait etre quoted
submitted_user <- submitted
if (!is.null(submitted_name)) {
submitted_name <- paste(submitted_name, "= ")
submitted_user <- purrr::map2(submitted_name, submitted, md_code_prepend)
}
if (!is.null(solution_name)) {
solution_name <- paste(solution_name, "= ")
solution_name <- purrr::map2(solution_name, submitted, md_code_prepend)
}
intro <- "This code seems correct, but please write using full argument(s) names:\n\n"
msg <- glue::glue_data(
list(
submitted = submitted_user,
solution_name = solution_name,
submitted_call = submitted_call
),
"- Where you wrote {submitted}, please use the full formal name {solution_name}."
)
glue::glue_data(
list(
intro = intro,
msg = msg
),
"{intro}{paste0(msg, collapse = '\n')}"
)
}
# too_many_matches
message_too_many_matches <- function(
submitted_call,
solution_name,
enclosing_call = NULL,
enclosing_arg = NULL
) {
# f(1, g(1, h(b = i(1), ba = 2)))
# f(1, a = g(1, a = h(bab = 1)))
# "Double check the argument names you are using. ",
# "In g(1, h(b = i(1), ba = 2)), h() accepts an argument named bab. More than one of your argument names will ",
# "be matched to bab, which will cause an error. Try ",
# "writing out the full argument names."
# "Double check the argument names you are using. ",
# "{intro}{submitted_call} accepts an argument named {that} and it ",
# "looks like more than one of your argument names will ",
# "be matched to {that}, which will cause an error. Try ",
# "writing out the full argument names."
submitted_call <- prep(submitted_call)
solution_name <- prep(solution_name)
intro <- build_intro(.call = enclosing_call, .arg = enclosing_arg)
glue::glue_data(
list(
intro = intro,
submitted_call = submitted_call,
solution_name = solution_name
),
"{intro}{submitted_call} accepts an argument named {solution_name}. ",
"More than one of your argument names in {submitted_call} will ",
"be matched to {solution_name}, which will cause an error. Try ",
"writing out the full argument names."
)
}
# wrong call
message_wrong_call <- function(submitted,
solution,
submitted_name = NULL,
enclosing_call = NULL) {
# f(1, g(1, h(a = i(1))))
# f(1, a = g(1, a = h(a = j(1))))
# "g(1, h(i(1))), I expected you to call a = j() where you called a = i()."
# "{intro}I expected you to {action} {solution} where you called {submitted}."
intro <- build_intro(.call = enclosing_call)
solution_original <- solution
submitted <- prep(submitted)
solution <- prep(solution)
if (!is.null(submitted_name) && submitted_name != "") {
solution <- md_code_prepend(paste(submitted_name, "= "), solution)
submitted <- md_code_prepend(paste(submitted_name, "= "), submitted)
}
action <-
if (is_infix_assign(solution_original)) {
"assign something to something else with"
} else {
"call"
}
glue::glue_data(
list(
submitted = submitted,
solution = solution,
action = action
),
"{intro}I expected you to {action} {solution} where you called {submitted}."
)
}
# wrong value for wrong value and wrong call, the enclosing argument is the
# argument that appears before the call or value. It should be passed to
# submitted_name
message_wrong_value <- function(
submitted,
solution,
submitted_name = NULL,
enclosing_call = NULL
) {
if (is_missing(submitted)) {
submitted <- NULL
}
# f(1, g(1, h(1)))
# f(1, a = g(1, a = h(2)))
# "h(1), I expected 2 where you wrote 1."
# "{intro}I expected {solution} where you wrote {submitted}."
intro <- build_intro(.call = enclosing_call)
expected <- "expected"
if (length(submitted) > length(solution)) {
expected <- "didn't expect"
solution <- submitted
submitted <- NULL
}
where <- " where you wrote "
solution_original <- solution
solution <- prep(solution)
if (is.null(submitted)) {
intro <- ""
submitted <- build_intro(enclosing_call %||% solution_original, .open = "", .close = "")
} else {
submitted <- prep(submitted)
}
if (!is.null(submitted_name) && submitted_name != "") {
solution <- md_code_prepend(paste(submitted_name, "= "), solution)
submitted <- md_code_prepend(paste(submitted_name, "= "), submitted)
}
# NOTE: infix operators that are calls like `<-` also
# need to be accounted for but perhaps there's a cleaner
# solution than tacking on more greps.
action <-
if (is_infix_assign(solution_original)) {
"you to assign something to something else with "
} else if (grepl("\\(\\)", solution)) {
"you to call "
}
glue::glue_data(
list(
intro = intro,
expected = expected,
solution = solution,
where = if (!identical(submitted, "")) where else "",
submitted = submitted,
action = action %||% ""
),
"{intro}I {expected} {action}{solution}{where}{submitted}."
)
}
prep <- function(text) {
# NOTE: `[` does not work well for assign `<-` and would
# grab whole expression ending up with: NULL <- NULL.
# this extra condition to use `[[` works, but requires further
# investigation for a cleaner solution.
if (is_infix(text)) {
text <- text[[1]]
} else if (is.call(text) && !is_pipe(text)) {
text <- text[1]
} else if (is.pairlist(text)) {
return(prep_function_arguments(text))
}
paste0("`", deparse_to_string(text), "`")
}
build_intro <- function(.call = NULL, .arg = NULL, .open = "In ", .close = ", ") {
is_call_fn_def <- is_function_definition(.call)
if (!is.null(.call)) {
.call_str <- deparse_to_string(.call)
if (!is.null(.arg) && !identical(.arg, "")) {
.call_str <- paste(.arg, "=", .call_str)
}
if (is_call_fn_def) {
# strip function body
.call_str <- sub("^(function\\(.+?\\))(.+)$", "\\1", .call_str)
}
if (nchar(.call_str) > 80) {
# too much context, the intro is too long to be helpful
return("")
}
intro <- glue::glue("{.open}`{.call_str}`{.close}")
} else {
intro <- ""
}
intro
}
prep_function_arguments <- function(arg_list) {
args <- names(arg_list)
values <- purrr::map_chr(
as.list(arg_list),
function(arg_value) {
if (arg_value == quote("")) return("")
paste(" =", deparse(arg_value))
}
)
s <- if (length(args) == 1) " " else "s "
paste0("argument", s, paste0("`", args, values, "`", collapse = ", "))
}
md_code_prepend <- function(prefix, x) {
if (length(x) > 1) {
return(purrr::map(x, ~ md_code_prepend(prefix, .x)))
}
stopifnot(length(prefix) == 1, length(x) == 1)
if (grepl("^`", x)) {
# remove leading code backtick if present in the string
x <- gsub("^`", "", x)
# add leading code backtick if _not_ present in the prefix
if (!grepl("^`", prefix)) {
prefix <- paste0("`", prefix)
}
}
paste0(prefix, x)
}
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.