From 1684c0cdc071b3f3ac2cc76f8a61ed4e0f71346f Mon Sep 17 00:00:00 2001 From: Garrett Grolemund Date: Tue, 31 Mar 2020 14:57:41 -0400 Subject: [PATCH] Plus handler (#92) * First pass at revised detect_mistakes - solves initial + inquiry. * Debugs detect_mistake to pass all tests, adds test for + case, edits detect_mistakes to flagged unmatched named arguments passed to ... as surplus * Adds tests for #84, #91, #94, #95. * Cleans up tests in test_detect_mistakes.R. Tests no longer use name of first argument. * Checks user code for bad syntax before standardising. Fixes #91, #94, #95. * Adds message generators for new cases: wrong_call(), bad_argument_name(), too_many_arguments(). * Adds new message generators to detect_mistakes. * Adds enclosing calls to student messages * Adds sanity-check.Rmd for checking that messages are sensible (which is not easy to automate). * Streamlines message generators. * Fixes bug in detect_mistakes that failed to catch unused unnamed arguments before passing student code to call_standardise_formals. * Improves the messages returned by the message generators. * Completes suite of sanity_checks for reading whether or not gradethis provides intelligible messages to students. * Corrects argument names in too_many_matches * Adds checks in sanity_checks.Rmd to tests as test_sanity_checks.R * Moves sanity-checks.Rmd to the tutorials as grade_code-messages * Changes content of old sanity-checks.R to be a tutorial. * Fixes awkward message returned by missing_argument when the missing argument does not have a name. * Fixes hard-coded tests that incorrectly fail in the presence of improvements. * Adds your_char variable to missing_argument() based on reviewer feedback * Improves handling of comparisons in build_intro() based on reviewer feedback. * Checks for case where user uses the same argument name twice. Adds duplicate_name() message generator. * Small improvements based on reviewer feedback * Fixes bug in how detect_mistakes handles partially matched formal names. * Further refactoring with real_names() inside of detect_mistakes() * Fixes bug that caused detect_mistakes to prematurely return NULL (correct) is one set of non-identical arguments were none-the-less correct. --- R/detect_mistakes.R | 582 +++++------ R/message_generators.R | 273 +++++- .../grade_code-messages.Rmd | 903 ++++++++++++++++++ tests/testthat/test_check_code.R | 5 +- tests/testthat/test_detect_mistakes.R | 262 ++--- tests/testthat/test_grade_learnr.R | 2 +- tests/testthat/test_sanity_checks.R | 566 +++++++++++ 7 files changed, 2150 insertions(+), 443 deletions(-) create mode 100644 inst/tutorials/grade_code-messages/grade_code-messages.Rmd create mode 100644 tests/testthat/test_sanity_checks.R diff --git a/R/detect_mistakes.R b/R/detect_mistakes.R index b38db519..cbe7c13b 100644 --- a/R/detect_mistakes.R +++ b/R/detect_mistakes.R @@ -1,322 +1,332 @@ -# given a user and solution expression, -# recursively detect differences -# detect_mistakes_old <- function(user, -# solution, env = parent.frame()) { -# force(env) -# -# # code should be checked in the opposite order -# # of evaluation (e.g. from the outside in for -# # nested notation), whether or not the student -# # (and/or teacher) used a pipe -# user <- rev(order_calls(unpipe_all(user), env = env)) -# solution <- rev(order_calls(unpipe_all(solution), env = env)) -# -# -# # do comparing named and unnamed arguments here -# # probably something using rlang::call_arg_names -# -# # user_len > solution_len ## surplus -# # user_len < solution_len ## missing -# -# # then for loop. -# -# max_length <- max(length(user), length(solution)) -# -# for (i in seq_len(max_length)) { -# - ## missing/surplus argument should not just compare raw position -# ## should determine what is missing/surplus by names -# # Did the user miss something? -# if (i > length(user)) { -# return(missing_argument(this_call = user[[i - 1]], -# that = solution[[i]], -# that_name = names(solution[i]))) -# } -# -# # Did the user write too much? -# if (i > length(solution)) { -# return(surplus_argument(this_call = user[[i - 1]][1], -# this_name = names(user[i]), -# this = ifelse(is.call(user[[i]]), -# renest(user[i:length(user)]), -# user[[i]]))) -# } -# -# # Does the user code not match the solution code? -# if (length(user[[i]]) != length(solution[[i]]) || -# !identical(user[[i]], solution[[i]]) -# ) { -# return(isolate_mismatch(user, solution, i)) -# } -# } -# NULL -# } - -detect_mistakes <- function(user, solution, env = rlang::env_parent()) { +detect_mistakes <- function(user, + solution, + env = rlang::env_parent(), + enclosing_call = NULL, + enclosing_arg = NULL) { force(env) - # rlang::env_print(env) - # print(sort(rlang::env_names(env))) + + submitted <- user if (is.call(user)) { - user <- call_standardise_formals(unpipe_all(user), env = env) + user <- unpipe_all(user) # cannot standardise yet without risking error + submitted_names <- rlang::names2(user) } if (is.call(solution)) { solution <- call_standardise_formals(unpipe_all(solution), env = env) } - # anything that is not a language, better the same - # else it's wrong + # 1. If the code contains a bare value, then the user and solution value + # should be identical. + # BUT WHAT IF ONE IS A CALL THAT EVALUATES TO THE VALUE OF THE OTHER? if (!is.call(user) || !is.call(solution)) { if (!identical(user, solution)) { - return(wrong_value(this = deparse_to_string(user), - that = solution) + return( + wrong_value( + this = submitted, + that = solution, + this_name = enclosing_arg, + enclosing_call = enclosing_call + ) ) } } - - user_len <- length(user) - solution_len <- length(solution) - - user_names <- rlang::names2(user) - solution_names <- rlang::names2(solution) - - if (user_len > solution_len) { - for (i in seq_len(user_len)) { - if (i > solution_len || user_names[i] != solution_names[i]) { + # We can assume anything below here is a call + + # Dividing cases into groups based on the relative lengths of the user's code + # and the solution code produces unitelligible messages as in issue #84. To + # produce more transparent messages that accord with how a user thinks of calls, + # check these things in this order: + + # 2. Check that the user and the solution use the same call + # SHOULD WE HAVE A TARGETED WRONG CALL FUNCTION? + if (!identical(user[[1]], solution[[1]])) { + return( + wrong_call( + this = user, + that = solution, + this_name = enclosing_arg, + enclosing_call = enclosing_call + ) + ) + } + + # 3. Check that the user code is not malformed and can be safely passed to + # call_standardise_formals(), which uses match.call(). Malformed code may + # contain an unused argument, multiple arguments whose names partially match + # the same formal, duplicate argument names, or an argument whose name + # partially matches more than one formal. + user_args <- as.list(user) + user_names <- real_names(user) + + solution_args <- as.list(solution) + solution_names <- real_names(solution) + + ## If the user duplicates an argument name, ensure that the solution does as + ## well. This should rarely happen, but might with map() for example. + user_arg_ns <- table(user_names) + solution_arg_ns <- table(solution_names) + if (any(user_arg_ns > 1)) { + duplicates <- names(user_arg_ns[user_arg_ns > 1]) + for (name in duplicates) { + if (!identical(user_arg_ns[name], solution_arg_ns[name])) { return( - surplus_argument( - this_call = user, - this = user[[i]], - this_name = user_names[[i]] + duplicate_name( + this_call = user, + this_name = name, + enclosing_call = enclosing_call, + enclosing_arg = enclosing_arg ) ) } } + } + + + ## Remove exact matches from further scrutiny + for (name in user_names) { + if (name %in% solution_names) { + user_args[[name]] <- NULL + solution_args[[name]] <- NULL + + # remove first instance of name from real solution + # names to handle duplicated argument names + name_index <- which(identical(solution_names, name))[1] + solution_names[name_index] <- "" + } + } + + ## Check remaining arguments for partial matches + remaining_user_names <- real_names(user_args) + remaining_solution_names <- real_names(solution_args) + + if (length(remaining_user_names) > 0) { + + ## Do any non-matched solution names partially match multiple user names? + pmatches_per_formal <- function(solution_name) { + sum(startsWith(solution_name, remaining_user_names)) + } + + matches <- vapply(remaining_solution_names, pmatches_per_formal, 1) + offenders <- matches[matches > 1] + + if (length(offenders) > 0) { + overmatched_name <- rlang::names2(offenders[1]) + return( + too_many_matches( + this_call = user, + that_name = overmatched_name, + enclosing_call = enclosing_call, + enclosing_arg = enclosing_arg + ) + ) + } - } else if (user_len < solution_len) { - for (i in seq_len(solution_len)) { - if (i > user_len || user_names[i] != solution_names[i]) { - return( - missing_argument( - this_call = solution, - that = solution[[i]], - that_name = solution_names[[i]] - ) + ## How many formals does each remaining user arg partially match? + pmatches_per_arg <- function(user_name) { + sum(startsWith(remaining_solution_names, user_name)) + } + + matches <- vapply(remaining_user_names, pmatches_per_arg, 1) + offenders <- matches[matches > 1] + unused <- matches[matches == 0] + well_matched <- matches[matches == 1] + + # names that match multiple arguments are a syntax error + if (length(offenders) > 0) { + bad_name <- rlang::names2(offenders[1]) + return( + bad_argument_name( + this_call = user, + this = user[[bad_name]], + this_name = bad_name, + enclosing_call = enclosing_call, + enclosing_arg = enclosing_arg + ) + ) + } + + # Unmatched named arguments are surplus + if (length(unused) > 0) { + surplus_name <- rlang::names2(unused[1]) + return( + surplus_argument( + this_call = user, + this = user[[surplus_name]], + this_name = surplus_name, + enclosing_call = enclosing_call, + enclosing_arg = enclosing_arg ) + ) + } + + # Remove partially matched arguments from further consideration + if (length(well_matched > 0)) { + matched_user_names <- rlang::names2(well_matched) + + for (name in matched_user_names) { + # which solution name does it match? + match <- which(startsWith(remaining_solution_names, name)) + matched_solution_name <- remaining_solution_names[match] + + user_args[[name]] <- NULL + solution_args[[matched_solution_name]] <- NULL } } - } else { - # see if call is same - if (!identical(user[[1]], solution[[1]])) { - return(wrong_value(this = deparse_to_string(user), - that = prep(solution), - this_name = user_names[1], - that_name = solution_names[1])) + + } + + # Check for unnamed, unused arguments + # Any further matching will now be by position not name + n_remaining_user <- length(user_args) + n_remaining_solution <- length(solution_args) + if (n_remaining_user > n_remaining_solution) { + i <- n_remaining_solution + 1 + return( + surplus_argument( + this_call = user, + this = user[[i]], + this_name = rlang::names2(user[i]), + enclosing_call = enclosing_call, + enclosing_arg = enclosing_arg + ) + ) + } + + + # It is now safe to call call_standardise_formals on student code + user <- call_standardise_formals(user, env = env) + user_names <- real_names(user) + + # 5. Check that every named argument in the solution appears in the user code. + # The outcome of this order is that when a user writes na = TRUE, gradethis + # will tell them that it expected an na.rm argument, not that na is a surplus + # argument. + solution_names <- real_names(solution) # original solution_names was modified above + missing_args <- solution_names[!(solution_names %in% user_names)] + if (length(missing_args) > 0) { + missing_name <- missing_args[1] + return( + missing_argument( + this_call = solution, + that_name = missing_name, + enclosing_call = enclosing_call, + enclosing_arg = enclosing_arg + ) + ) + } + + # 6. Check that the user code does not contain any named arguments that do not + # appear in the solution code. Since both calls have been standardised, these + # named arguments can only be being passed to ... and we should not match by + # position a named argument that is passed to ... with an unamed argument + # passed to ... + unmatched_user_names <- user_names[!(user_names %in% solution_names)] + if (length(unmatched_user_names) > 0) { + surplus_name <- unmatched_user_names[1] + return( + surplus_argument( + this_call = user, + this = user[[surplus_name]], + this_name = surplus_name, + enclosing_call = enclosing_call, + enclosing_arg = enclosing_arg + ) + ) + } + + # 7. Check that every named argument in the solution matches every + # correspondingly named argument in the user code. We know each + # has a match because of Step 5. + user_args <- as.list(user)[-1] # remove the call + solution_args <- as.list(solution)[-1] # remove the call + + for (name in solution_names) { + if (!identical(user[[name]], solution[[name]])) { + arg_name <- ifelse(name %in% submitted_names, name, "") + res <- detect_mistakes( + user = user[[name]], + solution = solution[[name]], + env = env, + # If too verbose, use user[1] + enclosing_call = submitted, + # avoid naming first arguments in messages + enclosing_arg = arg_name + ) + if(!is.null(res)) return(res) } - for (i in seq_len(user_len)) { - if (user_names[i] != solution_names[i]) { - return( - surplus_argument( - this_call = user, - this = user[[i]], - this_name = user_names[[i]] - ) - ) + # Make these arguments invisible to further checks + user_args[[name]] <- NULL + solution_args[[name]] <- NULL + } + + + # 8. Extract the remaining arguments from the user code and the solution code. + # Pair them in the order that they occur, checking that each pair matches. + # Check pairs in sequence and address unmatched arguments when you get to + # them. + user_len <- length(user_args) + solution_len <- length(solution_args) + + n <- max(user_len, solution_len) + + for (i in seq_len(n)) { + + # if solution argument is unmatched due to no remaining user arguments + if (i > user_len) { + name <- rlang::names2(solution_args[i]) + + # if the missing argument is unnamed, pass the value + if (is.null(name) || name == "") { + name <- solution_args[[i]] } - # if user[i] solution[i] not same: isolate_mismatch_2 - if (!identical(user[[i]], solution[[i]])) { - return( - detect_mistakes(user[[i]], solution[[i]], env = env) + + return( + missing_argument( + this_call = solution, + that_name = name, + enclosing_call = enclosing_call, + enclosing_arg = enclosing_arg ) - } + ) + # if user argument is unmatched due to no remaining solution arguments + } else if (i > solution_len) { + arg_name <- rlang::names2(user_args[i]) + if (!(arg_name %in% submitted_names)) arg_name <- "" + return( + surplus_argument( + this_call = user, + this = user_args[[i]], + this_name = arg_name, + enclosing_call = enclosing_call, + enclosing_arg = enclosing_arg + ) + ) + + # The user argument has a matching solution argument, are they identical? + } else if (!identical(user_args[[i]], solution_args[[i]])) { + name <- rlang::names2(user_args[i]) + if (!(name %in% submitted_names)) name <- "" + res <- detect_mistakes( + user = user_args[[i]], + solution = solution_args[[i]], + env = env, + # If too verbose, use user[1] + enclosing_call = submitted, + enclosing_arg = name + ) + if(!is.null(res)) return(res) } - } + # No missmatch found return(NULL) } -# isolate_mismatch_2 <- function(user, solution, i) { -# # For a given order call, we found code that is different -# # if the the first argument is different, -# # i.e., the wrong function was used, mean(1:3) vs std(1:3) -# # return wrong message -# if (length(user[[i]]) == 1 && -# length(solution[[i]]) == 1) { -# -# wrong <- prep_snippet(user, i) -# right <- prep_snippet(solution, i, .solution = TRUE) -# -# return(wrong_value(this = wrong, -# that = right, -# this_name = names(user[i]), -# that_name = names(solution[i]))) -# -# # If we cannot do this, we are working with two -# # multipart calls and we need to identify which -# # elements of the calls do not align (here we -# # rely heavily on the fact that both calls have -# # been previously standardized) -# } -# -# # some other part of the code is different -# detect_mistakes(user[[i]], solution[[i]]) -# } - -# isolate_mismatch <- function(user, solution, i) { - -# # We've honed in on the error when we can narrow -# # it down to a single incorrect user element -# # matched to a single correct solution element -# if (length(user[[i]]) == 1 && -# length(solution[[i]]) == 1) { - -# wrong <- prep_snippet(user, i) -# right <- prep_snippet(solution, i, .solution = TRUE) - -# return(wrong_value(this = wrong, -# that = right, -# this_name = names(user[i]), -# that_name = names(solution[i]))) - -# # If we cannot do this, we are working with two -# # multipart calls and we need to identify which -# # elements of the calls do not align (here we -# # rely heavily on the fact that both calls have -# # been previously standardized) -# } else { - -# user_call <- user[[i]] -# solution_call <- solution[[i]] - -# # First check that the calls match. -# if (user_call[[1]] != solution_call[[1]]) { -# wrong <- renest(user[i:length(user)]) -# right <- ifelse(is_infix(solution_call[1]), -# renest(solution[i:length(solution)]), -# solution_call[1]) - -# return(wrong_value(this = wrong, -# that = right, -# this_name = names(user[i]), -# that_name = names(solution[i]))) -# } - -# ## - -# # Then inspect the first argument (which appears on the next line) -# if (length(user) == i && length(solution) > i) { -# return(missing_argument(this_call = user[[i]], -# that = solution[[i + 1]], -# that_name = names(solution[i + 1]))) - -# } else if (length(user) > i && length(solution) == i) { -# return(surplus_argument(this_call = user[[i]][1], -# this_name = names(user[i + 1]), -# this = ifelse(is.call(user[[i + 1]]), -# renest(user[(i + 1):length(user)]), -# user[[i + 1]]))) - -# } else if (length(user) > i && length(solution) > i) { -# if (!names_match(user, solution, i + 1)) { -# return(wrong_value(this = user[[i + 1]], -# this_name = names(user[i + 1]), -# that = solution[[i + 1]], -# that_name = names(solution[i + 1]))) -# } else if (user[[i + 1]] != solution[[i + 1]]) { -# if (is_infix(user_call[1])) { -# return(detect_mistakes(user_call, solution_call)) -# } else { -# return(detect_mistakes(renest(user[(i + 1):length(user)]), -# renest(solution[(i + 1):length(solution)]))) -# } -# } -# } - -# # Then iterate through the remaining arguments one at a time -# # here we are iterating across a call instead of down a call -# # stack as in detect_mistakes - -# max_length <- max(length(user_call), length(solution_call)) - -# for (j in seq_len(max_length)) { -# if (j == 1) next - -# # Did the user leave out an argument? -# if (j > length(user_call)) { -# return(missing_argument(this_call = user_call[1], -# that = solution_call[[j]], -# that_name = names(solution_call[j]))) -# } - -# # Did the user include an extra argument? -# if (j > length(solution_call)) { -# return(surplus_argument(this_call = user_call[1], -# this = user_call[[j]], -# this_name = names(user_call[j]))) -# } - -# # Do the argument names match? -# if (!names_match(user_call, solution_call, j)) { -# return(wrong_value(this = user_call[[j]], -# this_name = names(user_call[j]), -# that = solution_call[[j]], -# that_name = names(solution_call[j]))) -# } - -# # Do two arguments conflict? They may themselves -# # contain an expression that we should drill into. -# if (user_call[[j]] != solution_call[[j]]) { -# return(detect_mistakes(user_call, solution_call)) -# } -# } -# } -# NULL -# } - -real_name <- function(name) { - !is.null(name) && name != "" +real_names <- function(x) { + x_names <- rlang::names2(x) + x_names[x_names != ""] } -names_match <- function(user, solution, i) { - - if (is.null(names(user))) return(TRUE) - user_names <- names(user) - - if (is.null(names(solution))) return(TRUE) - solution_names <- names(solution) - - if (real_name(user_names[i])) { - if (real_name(solution_names[i])) { - if (user_names[i] != solution_names[i]) { - return(FALSE) - } - } else if (user_names[i] %in% solution_names) { - return(FALSE) - } - } else if (real_name(solution_names[i]) && - solution_names[i] %in% user_names) { - return(FALSE) - } - TRUE -} - -prep_snippet <- function(code, i, .solution = FALSE) { - - # errors that involve an infix operator make more - # sense if the explanation refers to the operator - if (i == 2 && is_infix(code[[1]]) && length(code[[1]]) == 1) { - paste(deparse_to_string(code[[1]][[1]]), deparse_to_string(code[[2]])) - - # Return the internal arguments of user code, but - # not solution code (that could give away too much) - } else if (is.call(code[[i]])) { - ifelse(.solution, code[[i]][1], renest(code[i:length(code)])) - } else { - code[[i]] - } - -} diff --git a/R/message_generators.R b/R/message_generators.R index 62861f1f..9d3dbd51 100644 --- a/R/message_generators.R +++ b/R/message_generators.R @@ -3,36 +3,156 @@ # because it is not at hand in the submission. "this" always refers to # incorrect/user code, which is always at hand). Cases: -# missing argument -missing_argument <- function(this_call, that, that_name = NULL) { - this_call <- prep(this_call) - that <- prep(that) +# bad argument name +bad_argument_name <- function(this_call, + this, + this_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}{this_call} accepts more than one argument that begins with {this_name}. + # As a result, R cannot figure out which argument you want to pass {this} to. + # Check how you spelled {this_name}, or write out the full argument name. - if (!is.null(that_name) && that_name != "") - that <- paste(that_name, "=", that) + intro <- build_intro(.call = enclosing_call, .arg = enclosing_arg) - if (grepl("\\(\\)", that)) - that <- paste("a call to", that) + this <- prep(this) + this_call <- prep(this_call) + + if (grepl("\\(\\)", this)) + this <- paste("a call to", this) + + glue::glue_data( + list( + intro = intro, + this_call = this_call, + this_name = this_name, + this = this + ), + "{intro}{this_call} accepts more than one argument name that begins ", + "with {this_name}. As a result, R cannot figure out which ", + "argument you want to pass {this} to. Check how you spelled ", + "{this_name}, or write out the full argument name." + ) +} + +# duplicate_name +duplicate_name <- function(this_call, + this_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 {this_name} to {this_call}, which will cause " + # "an error. Check your spelling, or remove one of the arguments." + + this_call <- prep(this_call) + this_name <- prep(this_name) + + intro <- build_intro(.call = enclosing_call, .arg = enclosing_arg) + + glue::glue_data( + list( + intro = intro, + this_call = this_call, + this_name = this_name + ), + "You passed multiple arguments named {this_name} ", + "to {this_call}, which will cause an error. ", + "Check your spelling, or remove one of the arguments." + ) +} - glue::glue("Your call to {this_call} should include {that} ", - "as one of its arguments. You may have ", - "referred to it in a different way, or left out an important ", - "argument name.") +# WHAT TO DO IF THE MISSING ARGUMENT DOESN"T HAVE A NAME IN THE SOLUTION? +# missing argument +missing_argument <- function(this_call, + that_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 {this_call} should include {that_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") + + this_call <- prep(this_call) + that_name <- prep(that_name) + + if (grepl("\\(\\)", that_name)) { + that_name <- paste0("an argument, possibly unnamed, that calls ", that_name, ".") + } else { + that_name <- paste(that_name, "as one of its arguments.") + } + + glue::glue_data( + list( + intro = intro, + this_call = this_call, + that_name = that_name + ), + "{intro}{your_char}our call to {this_call} should include {that_name} ", + "You may have misspelled an argument name, ", + "or left out an important argument." + ) } # surplus argument -surplus_argument <- function(this_call, this, this_name = NULL) { +surplus_argument <- function(this_call, + this, + this_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 {this_call} to ", + # "include {this}. 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_call <- prep(this_call) this <- prep(this) + if (!is.null(this_name) && this_name != "") this <- paste(this_name, "=", this) - + glue::glue_data( list( this = this, this_call = this_call ), - "I did not expect your call to {this_call} to ", + "{intro}I did not expect your call to {this_call} to ", "include {this}. You ", "may have included an unnecessary argument, or you ", "may have left out or misspelled an important ", @@ -40,22 +160,111 @@ surplus_argument <- function(this_call, this, this_name = NULL) { ) } -# wrong value -wrong_value <- function(this, that, that_name = NULL, this_name = NULL) { +# too_many_matches +too_many_matches <- function(this_call, + that_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}{this_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." + + this_call <- prep(this_call) + that_name <- prep(that_name) + + intro <- build_intro(.call = enclosing_call, .arg = enclosing_arg) + + glue::glue_data( + list( + intro = intro, + this_call = this_call, + that_name = that_name + ), + "{intro}{this_call} accepts an argument named {that_name}. ", + "More than one of your argument names in {this_call} will ", + "be matched to {that_name}, which will cause an error. Try ", + "writing out the full argument names." + ) +} + +# wrong call +wrong_call <- function(this, + that, + this_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 call {that} where you called {this}." + + intro <- build_intro(.call = enclosing_call) + this <- prep(this) that <- prep(that) - - if (!is.null(that_name) && that_name != "") - that <- paste(that_name, "=", that) - if (!is.null(this_name) && this_name != "") + + if (!is.null(this_name) && this_name != "") { + that <- paste(this_name, "=", that) this <- paste(this_name, "=", this) + } + + glue::glue_data( + list( + intro = intro, + this = this, + that = that + ), + "{intro}I expected you to call {that} where you called {this}." + ) +} +# 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 +# this_name +wrong_value <- function(this, + that, + this_name = NULL, + enclosing_call = 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 {that} where you wrote {this}." + + intro <- build_intro(.call = enclosing_call) + + this <- prep(this) + that <- prep(that) + + if (!is.null(this_name) && this_name != "") { + that <- paste(this_name, "=", that) + this <- paste(this_name, "=", this) + } + if (grepl("\\(\\)", that)) - that <- paste("a call to", that) - + that <- paste("you to call", that) + glue::glue_data( - list(this = this, that = that), - "I expected {that}; what you wrote was interpreted as {this}." + list( + this = this, + that = that + ), + "{intro}I expected {that} where you wrote {this}." ) } @@ -64,3 +273,17 @@ prep <- function(text) { if (!is.character(text)) text <- deparse_to_string(text) text } + +build_intro <- function(.call = NULL, .arg = NULL) { + + if(!is.null(.call)) { + .call <- deparse_to_string(.call) + if (!is.null(.arg) && !identical(.arg, "")) { + .call <- paste(.arg, "=", .call) + } + intro <- glue::glue("In {.call}, ") + } else { + intro <- "" + } + intro +} \ No newline at end of file diff --git a/inst/tutorials/grade_code-messages/grade_code-messages.Rmd b/inst/tutorials/grade_code-messages/grade_code-messages.Rmd new file mode 100644 index 00000000..032c406e --- /dev/null +++ b/inst/tutorials/grade_code-messages/grade_code-messages.Rmd @@ -0,0 +1,903 @@ +--- +title: "grade_code messages" +output: + html_document: + toc: true +description: "This tutorial demonstrates how gradethis' grade_code() function provides formative feedback for a variety of common code errors." +--- + +```{r setup, echo = FALSE} +library(gradethis) +library(glue) +knitr::opts_chunk$set(echo = FALSE) +``` + +The `grade_code()` function tackles one of the hardest problems in automated learning, which is how to tell students: + +1. Which part of their code is wrong, and +2. How they should fix it + +`grade_code()` does this in an automated fashion. It compares the code that a student submits for a learnr exercise to the code that a teacher provides in the exercise's solution chunk. If the two match, `grade_code()` deems the code correct (which is signified by a `NULL` in the feedback messages below). If `grade_code()` spots a difference between the student code and the solution code, `grade_code()` tells the student where their code first diverges and how they should get back on the right track. + +The examples below show the feedback messages that `grade_code()` will provide for common coding mistakes. + +## Wrong Calls + +```{r echo = TRUE} +a <- function(x) x +b <- function(x) x +f <- function(x, y) x + y +g <- function(x, y = a(1)) x + y +``` + + +```{r} +solution <- quote(a(1)) +user <- quote(b(1)) +``` + +Correct: ``r gradethis:::deparse_to_string(solution)`` +Student: ``r gradethis:::deparse_to_string(user)`` +Feedback: +```{r echo = FALSE} +gradethis:::detect_mistakes(user, solution) +``` + +*** + +```{r} +solution <- quote(a()) +user <- quote(a) +``` + +Correct: ``r gradethis:::deparse_to_string(solution)`` +Student: ``r gradethis:::deparse_to_string(user)`` +Feedback: +```{r echo = FALSE} +gradethis:::detect_mistakes(user, solution) +``` + +*** + +```{r} +solution <- quote(a(1)) +user <- quote(b(a(1))) +``` + +Correct: ``r gradethis:::deparse_to_string(solution)`` +Student: ``r gradethis:::deparse_to_string(user)`` +Feedback: +```{r echo = FALSE} +gradethis:::detect_mistakes(user, solution) +``` + +*** + +```{r} +solution <- quote(a(1)) +user <- quote(a(b(1))) +``` + +Correct: ``r gradethis:::deparse_to_string(solution)`` +Student: ``r gradethis:::deparse_to_string(user)`` +Feedback: + +```{r echo = FALSE} +gradethis:::detect_mistakes(user, solution) +``` + +*** + +```{r} +solution <- quote(a(1)) +user <- quote(a(a(1))) +``` + +Correct: ``r gradethis:::deparse_to_string(solution)`` +Student: ``r gradethis:::deparse_to_string(user)`` +Feedback: +```{r echo = FALSE} +gradethis:::detect_mistakes(user, solution) +``` + +*** + +```{r} +solution <- quote(a(1)) +user <- quote(0 + a(1)) +``` + +Correct: ``r gradethis:::deparse_to_string(solution)`` +Student: ``r gradethis:::deparse_to_string(user)`` +Feedback: +```{r echo = FALSE} +gradethis:::detect_mistakes(user, solution) +``` + +*** + +```{r} +solution <- quote(a(1)) +user <- quote(a(1) + 0) +``` + +Correct: ``r gradethis:::deparse_to_string(solution)`` +Student: ``r gradethis:::deparse_to_string(user)`` +Feedback: +```{r echo = FALSE} +gradethis:::detect_mistakes(user, solution) +``` + +*** + +```{r} +solution <- quote(a() + a()) +user <- quote(a() + b()) +``` + +Correct: ``r gradethis:::deparse_to_string(solution)`` +Student: ``r gradethis:::deparse_to_string(user)`` +Feedback: +```{r echo = FALSE} +gradethis:::detect_mistakes(user, solution) +``` + +*** + +```{r} +solution <- quote(a() + a()) +user <- quote(b() + a()) +``` + +Correct: ``r gradethis:::deparse_to_string(solution)`` +Student: ``r gradethis:::deparse_to_string(user)`` +Feedback: +```{r echo = FALSE} +gradethis:::detect_mistakes(user, solution) +``` + +*** + +```{r} +solution <- quote(a(b(1))) +user <- quote(b(1) %>% a()) +``` + +Correct: ``r gradethis:::deparse_to_string(solution)`` +Student: ``r gradethis:::deparse_to_string(user)`` +Feedback: +```{r echo = FALSE} +# NULL implies the code was deemed correct +gradethis:::detect_mistakes(user, solution) +``` + +*** + +```{r} +solution <- quote(a(b(1))) +user <- quote(a(1) %>% b()) +``` + +Correct: ``r gradethis:::deparse_to_string(solution)`` +Student: ``r gradethis:::deparse_to_string(user)`` +Feedback: +```{r echo = FALSE} +gradethis:::detect_mistakes(user, solution) +``` + +*** + +```{r} +solution <- quote(a(a(1))) +user <- quote(b(1) %>% a()) +``` + +Correct: ``r gradethis:::deparse_to_string(solution)`` +Student: ``r gradethis:::deparse_to_string(user)`` +Feedback: +```{r echo = FALSE} +gradethis:::detect_mistakes(user, solution) +``` + +*** + +```{r} +solution <- quote(b(b(1))) +user <- quote(b(1) %>% a()) +``` + +Correct: ``r gradethis:::deparse_to_string(solution)`` +Student: ``r gradethis:::deparse_to_string(user)`` +Feedback: +```{r echo = FALSE} +gradethis:::detect_mistakes(user, solution) +``` + +*** + +```{r} +solution <- quote(f(1, y = a(1))) +user <- quote(f(1, y = b(1))) +``` + +Correct: ``r gradethis:::deparse_to_string(solution)`` +Student: ``r gradethis:::deparse_to_string(user)`` +Feedback: +```{r echo = FALSE} +gradethis:::detect_mistakes(user, solution) +``` + +*** + +```{r} +solution <- quote(f(1, y = a(1))) +user <- quote(f(1, y = b(a(1)))) +``` + +Correct: ``r gradethis:::deparse_to_string(solution)`` +Student: ``r gradethis:::deparse_to_string(user)`` +Feedback: +```{r echo = FALSE} +gradethis:::detect_mistakes(user, solution) +``` + +*** + +```{r} +solution <- quote(f(1, y = a(1))) +user <- quote(f(1, y = a(b(1)))) +``` + +Correct: ``r gradethis:::deparse_to_string(solution)`` +Student: ``r gradethis:::deparse_to_string(user)`` +Feedback: +```{r echo = FALSE} +gradethis:::detect_mistakes(user, solution) +``` + + +*** + +```{r} +solution <- quote(f(1, y = a(1))) +user <- quote(f(1, y = b(b(1)))) +``` + +Correct: ``r gradethis:::deparse_to_string(solution)`` +Student: ``r gradethis:::deparse_to_string(user)`` +Feedback: +```{r echo = FALSE} +gradethis:::detect_mistakes(user, solution) +``` + +*** + +```{r} +solution <- quote(f(1, y = a(1))) +user <- quote(f(1, y = a(a(1)))) +``` + +Correct: ``r gradethis:::deparse_to_string(solution)`` +Student: ``r gradethis:::deparse_to_string(user)`` +Feedback: +```{r echo = FALSE} +gradethis:::detect_mistakes(user, solution) +``` + +```{r} +solution <- quote(g(1)) # default y = a(1) +user <- quote(g(1, y = a(1))) +``` + +Correct: ``r gradethis:::deparse_to_string(solution)`` +Student: ``r gradethis:::deparse_to_string(user)`` +Feedback: +```{r echo = FALSE} +gradethis:::detect_mistakes(user, solution) +``` + +*** + +```{r} +solution <- quote(g(1)) # default y = a(1) +user <- quote(g(1, y = b(1))) +``` + +Correct: ``r gradethis:::deparse_to_string(solution)`` +Student: ``r gradethis:::deparse_to_string(user)`` +Feedback: +```{r echo = FALSE} +gradethis:::detect_mistakes(user, solution) +``` + +*** + +```{r} +solution <- quote(f(1, y = a(1))) +user <- quote(f(1, y = f(1))) +``` + +Correct: ``r gradethis:::deparse_to_string(solution)`` +Student: ``r gradethis:::deparse_to_string(user)`` +Feedback: +```{r echo = FALSE} +gradethis:::detect_mistakes(user, solution) +``` + +*** + + +# Wrong values + +```{r echo = TRUE} +a <- function(x) x +b <- function(x) x +x <- 1 +y <- 1 +X <- 1 +``` + +*** + +```{r} +solution <- quote(1) +user <- quote(2) +``` + +Correct: ``r gradethis:::deparse_to_string(solution)`` +Student: ``r gradethis:::deparse_to_string(user)`` +Feedback: +```{r echo = FALSE} +gradethis:::detect_mistakes(user, solution) +``` + +*** + +```{r} +solution <- quote(1) +user <- quote(-1) +``` + +Correct: ``r gradethis:::deparse_to_string(solution)`` +Student: ``r gradethis:::deparse_to_string(user)`` +Feedback: +```{r echo = FALSE} +gradethis:::detect_mistakes(user, solution) +``` + +*** + +```{r} +solution <- quote(1) +user <- quote(1L) +``` + +Correct: ``r gradethis:::deparse_to_string(solution)`` +Student: ``r gradethis:::deparse_to_string(user)`` +Feedback: +```{r echo = FALSE} +gradethis:::detect_mistakes(user, solution) +``` + +*** + +```{r} +solution <- quote(1) +user <- quote(1()) +``` + +Correct: ``r gradethis:::deparse_to_string(solution)`` +Student: ``r gradethis:::deparse_to_string(user)`` +Feedback: +```{r echo = FALSE} +gradethis:::detect_mistakes(user, solution) +``` + + +*** + +```{r} +solution <- quote(x) +user <- quote(y) +``` + +Correct: ``r gradethis:::deparse_to_string(solution)`` +Student: ``r gradethis:::deparse_to_string(user)`` +Feedback: +```{r echo = FALSE} +gradethis:::detect_mistakes(user, solution) +``` + +*** + +```{r} +solution <- quote(x) +user <- quote(X) +``` + +Correct: ``r gradethis:::deparse_to_string(solution)`` +Student: ``r gradethis:::deparse_to_string(user)`` +Feedback: +```{r echo = FALSE} +gradethis:::detect_mistakes(user, solution) +``` + +*** + +```{r} +solution <- quote(a(1)) +user <- quote(a(2)) +``` + +Correct: ``r gradethis:::deparse_to_string(solution)`` +Student: ``r gradethis:::deparse_to_string(user)`` +Feedback: +```{r echo = FALSE} +gradethis:::detect_mistakes(user, solution) +``` + +*** + +```{r} +solution <- quote(a(1)) +user <- quote(a(-1)) +``` + +Correct: ``r gradethis:::deparse_to_string(solution)`` +Student: ``r gradethis:::deparse_to_string(user)`` +Feedback: +```{r echo = FALSE} +gradethis:::detect_mistakes(user, solution) +``` + +*** + +```{r} +solution <- quote(a(1)) +user <- quote(a(1L)) +``` + +Correct: ``r gradethis:::deparse_to_string(solution)`` +Student: ``r gradethis:::deparse_to_string(user)`` +Feedback: +```{r echo = FALSE} +gradethis:::detect_mistakes(user, solution) +``` + +*** + +```{r} +solution <- quote(a(x)) +user <- quote(a(y)) +``` + +Correct: ``r gradethis:::deparse_to_string(solution)`` +Student: ``r gradethis:::deparse_to_string(user)`` +Feedback: +```{r echo = FALSE} +gradethis:::detect_mistakes(user, solution) +``` + +*** + +```{r} +solution <- quote(a(x)) +user <- quote(a(X)) +``` + +Correct: ``r gradethis:::deparse_to_string(solution)`` +Student: ``r gradethis:::deparse_to_string(user)`` +Feedback: +```{r echo = FALSE} +gradethis:::detect_mistakes(user, solution) +``` + +```{r} +solution <- quote(1 + 2) +user <- quote(1 + 1) +``` + +Correct: ``r gradethis:::deparse_to_string(solution)`` +Student: ``r gradethis:::deparse_to_string(user)`` +Feedback: +```{r echo = FALSE} +gradethis:::detect_mistakes(user, solution) +``` + +*** + +```{r} +solution <- quote(1 + 2) +user <- quote(2 + 1) +``` + +Correct: ``r gradethis:::deparse_to_string(solution)`` +Student: ``r gradethis:::deparse_to_string(user)`` +Feedback: +```{r echo = FALSE} +gradethis:::detect_mistakes(user, solution) +``` + +*** + +```{r} +solution <- quote(1 %>% f(2)) +user <- quote(3 %>% f(2)) +``` + +Correct: ``r gradethis:::deparse_to_string(solution)`` +Student: ``r gradethis:::deparse_to_string(user)`` +Feedback: +```{r echo = FALSE} +gradethis:::detect_mistakes(user, solution) +``` + +*** + +```{r} +solution <- quote(1 %>% f(2)) +user <- quote(1 %>% f(3)) +``` + +Correct: ``r gradethis:::deparse_to_string(solution)`` +Student: ``r gradethis:::deparse_to_string(user)`` +Feedback: +```{r echo = FALSE} +gradethis:::detect_mistakes(user, solution) +``` + +*** + +# Bad Argument Names + +```{r echo = TRUE} +# the name a will fail to uniquely match +tricky <- function(aa = 1, ab = 2, ac = 3) aa +``` + +*** + +```{r} +solution <- quote(tricky(ab = 1)) +user <- quote(tricky(a = 1)) +``` + +Correct: ``r gradethis:::deparse_to_string(solution)`` +Student: ``r gradethis:::deparse_to_string(user)`` +Feedback: +```{r echo = FALSE} +gradethis:::detect_mistakes(user, solution) +``` + +*** + +```{r} +solution <- quote(tricky(ab = 1)) +user <- quote(tricky(1, 2, a = 1)) +``` + +Correct: ``r gradethis:::deparse_to_string(solution)`` +Student: ``r gradethis:::deparse_to_string(user)`` +Feedback: +```{r echo = FALSE} +gradethis:::detect_mistakes(user, solution) +``` + +*** + +```{r} +solution <- quote(tricky(ab = 1)) +user <- quote(1 %>% tricky(a = 2)) +``` + +Correct: ``r gradethis:::deparse_to_string(solution)`` +Student: ``r gradethis:::deparse_to_string(user)`` +Feedback: +```{r echo = FALSE} +gradethis:::detect_mistakes(user, solution) +``` + +*** + +```{r} +solution <- quote(tricky(ab = 1)) +user <- quote(1 %>% tricky(a = .)) +``` + +Correct: ``r gradethis:::deparse_to_string(solution)`` +Student: ``r gradethis:::deparse_to_string(user)`` +Feedback: +```{r echo = FALSE} +gradethis:::detect_mistakes(user, solution) +``` + +*** + +# Formal argument name matches too many provided names + +```{r echo = TRUE} +# What if multiple arguments partially match ambiguous? +tricky2 <- function(ambiguous = 1, ...) ambiguous +not_tricky <- function(a = 1, ambiguous = 2, ...) a +``` + +*** + +```{r} +solution <- quote(tricky2(amb = 2)) +user <- quote(tricky2(a = 2, am = 2)) +``` + +Correct: ``r gradethis:::deparse_to_string(solution)`` +Student: ``r gradethis:::deparse_to_string(user)`` +Feedback: +```{r echo = FALSE} +gradethis:::detect_mistakes(user, solution) +``` + +*** + +```{r} +solution <- quote(not_tricky(amb = 2)) +user <- quote(not_tricky(a = 1, am = 2)) +``` + +Correct: ``r gradethis:::deparse_to_string(solution)`` +Student: ``r gradethis:::deparse_to_string(user)`` +Feedback: +```{r echo = FALSE} +gradethis:::detect_mistakes(user, solution) +``` + +*** + +```{r} +solution <- quote(tricky2(amb = 2)) +user <- quote(2 %>% tricky2(a = ., am = 2)) +``` + +Correct: ``r gradethis:::deparse_to_string(solution)`` +Student: ``r gradethis:::deparse_to_string(user)`` +Feedback: +```{r echo = FALSE} +gradethis:::detect_mistakes(user, solution) +``` + +*** + +# Surplus Arguments + +```{r echo = TRUE} +h <- function(x) x +i <- function(x, ...) x +``` + +*** + +```{r} +solution <- quote(h(x = 1)) +user <- quote(h(x = 1, y = 2)) +``` + +Correct: ``r gradethis:::deparse_to_string(solution)`` +Student: ``r gradethis:::deparse_to_string(user)`` +Feedback: +```{r echo = FALSE} +gradethis:::detect_mistakes(user, solution) +``` + +*** + +```{r} +solution <- quote(h(x = 1)) +user <- quote(h(1, 2)) +``` + +Correct: ``r gradethis:::deparse_to_string(solution)`` +Student: ``r gradethis:::deparse_to_string(user)`` +Feedback: +```{r echo = FALSE} +gradethis:::detect_mistakes(user, solution) +``` + +*** + +```{r} +solution <- quote(i(x = 1)) +user <- quote(i(1, 2)) +``` + +Correct: ``r gradethis:::deparse_to_string(solution)`` +Student: ``r gradethis:::deparse_to_string(user)`` +Feedback: +```{r echo = FALSE} +gradethis:::detect_mistakes(user, solution) +``` + +*** + +```{r} +solution <- quote(i(x = 1)) +user <- quote(i(1, x = 2)) +``` + +Correct: ``r gradethis:::deparse_to_string(solution)`` +Student: ``r gradethis:::deparse_to_string(user)`` +Feedback: +```{r echo = FALSE} +gradethis:::detect_mistakes(user, solution) +``` + +*** + +```{r} +solution <- quote(h(x = 1)) +user <- quote(1 %>% h(2)) +``` + +Correct: ``r gradethis:::deparse_to_string(solution)`` +Student: ``r gradethis:::deparse_to_string(user)`` +Feedback: +```{r echo = FALSE} +gradethis:::detect_mistakes(user, solution) +``` + +*** + +# Missing Arguments + +```{r echo = TRUE} +f <- function(x, y) x + y +g <- function(x, y = a(1)) x + y +z <- function(...) 1 +``` + +*** + +```{r} +solution <- quote(f(x = 1, y = 1)) +user <- quote(f(x = 1)) +``` + +Correct: ``r gradethis:::deparse_to_string(solution)`` +Student: ``r gradethis:::deparse_to_string(user)`` +Feedback: +```{r echo = FALSE} +gradethis:::detect_mistakes(user, solution) +``` + +*** + +```{r} +solution <- quote(a(f(x = 1, y = 2))) +user <- quote(a(f(x = 1))) +``` + +Correct: ``r gradethis:::deparse_to_string(solution)`` +Student: ``r gradethis:::deparse_to_string(user)`` +Feedback: +```{r echo = FALSE} +gradethis:::detect_mistakes(user, solution) +``` + +*** + +```{r} +solution <- quote(f(x = 1, y = 2)) +user <- quote(f(y = 2)) +``` + +Correct: ``r gradethis:::deparse_to_string(solution)`` +Student: ``r gradethis:::deparse_to_string(user)`` +Feedback: +```{r echo = FALSE} +gradethis:::detect_mistakes(user, solution) +``` + +*** + +```{r} +solution <- quote(f(x = 1, y = 2)) +user <- quote(f(1)) +``` + +Correct: ``r gradethis:::deparse_to_string(solution)`` +Student: ``r gradethis:::deparse_to_string(user)`` +Feedback: +```{r echo = FALSE} +gradethis:::detect_mistakes(user, solution) +``` + +*** + +```{r} +solution <- quote(f(x = 1, y = 2)) +user <- quote(1 %>% f()) +``` + +Correct: ``r gradethis:::deparse_to_string(solution)`` +Student: ``r gradethis:::deparse_to_string(user)`` +Feedback: +```{r echo = FALSE} +gradethis:::detect_mistakes(user, solution) +``` + +*** + +```{r} +solution <- quote(a(f(x = 1, y = 2))) +user <- quote(a(1 %>% f())) +``` + +Correct: ``r gradethis:::deparse_to_string(solution)`` +Student: ``r gradethis:::deparse_to_string(user)`` +Feedback: +```{r echo = FALSE} +gradethis:::detect_mistakes(user, solution) +``` + +*** + +```{r} +solution <- quote(a(1)) +user <- quote(a()) +``` + +Correct: ``r gradethis:::deparse_to_string(solution)`` +Student: ``r gradethis:::deparse_to_string(user)`` +Feedback: +```{r echo = FALSE} +gradethis:::detect_mistakes(user, solution) +``` + +*** + +```{r} +solution <- quote(z(1)) +user <- quote(z()) +``` + +Correct: ``r gradethis:::deparse_to_string(solution)`` +Student: ``r gradethis:::deparse_to_string(user)`` +Feedback: +```{r echo = FALSE} +gradethis:::detect_mistakes(user, solution) +``` + +*** + +```{r} +solution <- quote(z(a(1))) +user <- quote(z()) +``` + +Correct: ``r gradethis:::deparse_to_string(solution)`` +Student: ``r gradethis:::deparse_to_string(user)`` +Feedback: +```{r echo = FALSE} +gradethis:::detect_mistakes(user, solution) +``` + +*** + +# Duplicate names + +```{r echo = TRUE} +i <- function(x, ...) x +``` + +*** + +```{r} +solution <- quote(i(x = 1)) +user <- quote(i(x = 1, x = 2)) +``` + +Correct: ``r gradethis:::deparse_to_string(solution)`` +Student: ``r gradethis:::deparse_to_string(user)`` +Feedback: +```{r echo = FALSE} +gradethis:::detect_mistakes(user, solution) +``` + +*** diff --git a/tests/testthat/test_check_code.R b/tests/testthat/test_check_code.R index 35fefdb7..063aab84 100644 --- a/tests/testthat/test_check_code.R +++ b/tests/testthat/test_check_code.R @@ -71,8 +71,7 @@ test_that("Spots differences in calls", { grade_code(grader_args = list(user_quo = c, solution_quo = a)) , missing_argument(this_call = "vapply()", - that_name = "na.rm", - that = quote(TRUE)) + that_name = "na.rm") ) }) @@ -93,7 +92,7 @@ test_that("Mentions only first non-matching element", { expect_message( grade_code(grader_args = list(user_quo = x, solution_quo = z)), - wrong_value(this = "log(1)", that = quote(sqrt())) + wrong_call(this = quote(log()), that = quote(sqrt())) ) expect_message( diff --git a/tests/testthat/test_detect_mistakes.R b/tests/testthat/test_detect_mistakes.R index 1a545a9a..df9b5b12 100644 --- a/tests/testthat/test_detect_mistakes.R +++ b/tests/testthat/test_detect_mistakes.R @@ -7,54 +7,48 @@ test_that("detect_mistakes detects surplus code", { user <- quote(a(b(1))) solution <- quote(b(1)) expect_equal( - detect_mistakes(user, solution) - , - wrong_value(this = "a(x = b(1))", that = quote(b())) + detect_mistakes(user, solution), + wrong_call(this = user, that = solution) ) user <- quote(b(b(1))) solution <- quote(b(1)) expect_equal( - detect_mistakes(user, solution) - , - wrong_value(this = "b(x = 1)", that = quote(1)) + detect_mistakes(user, solution), + wrong_value(this = user[[2]], that = solution[[2]], enclosing_call = user) ) user <- quote(a(b(1))) solution <- quote(a(1)) expect_equal( - detect_mistakes(user, solution) - , - wrong_value(this = "b(x = 1)", that = quote(1)) - ) + detect_mistakes(user, solution), + wrong_value(this = user[[2]], that = solution[[2]], enclosing_call = user) + ) # non-function user <- quote(1(a(1))) # nolint solution <- quote(a(1)) expect_equal( - detect_mistakes(user, solution) - , - wrong_value(this = "1(a(1))", that = "a()") - ) + detect_mistakes(user, solution), + wrong_call(this = user, that = solution) + ) # internal atomic # arguments user <- quote(b(1)) solution <- quote(b()) expect_equal( - detect_mistakes(user, solution) - , - surplus_argument(quote(b()), "x = 1") - ) + detect_mistakes(user, solution), + surplus_argument(this_call = user, this = user[[2]]) + ) # internal non-function user <- quote(a(1(1))) # nolint solution <- quote(a(1)) expect_equal( - detect_mistakes(user, solution) - , - wrong_value(this = "1(1)", that = quote(1)) - ) + detect_mistakes(user, solution), + wrong_value(this = user[[2]], that = solution[[2]], enclosing_call = user) + ) }) test_that("detect_mistakes detects missing code", { @@ -63,9 +57,8 @@ test_that("detect_mistakes detects missing code", { user <- quote(b(1)) solution <- quote(a(b(1))) expect_equal( - detect_mistakes(user, solution) - , - wrong_value(this = "b(x = 1)", that = quote(a())) + detect_mistakes(user, solution), + wrong_call(this = user, that = solution) ) @@ -73,27 +66,24 @@ test_that("detect_mistakes detects missing code", { user <- quote(1(1)) # nolint solution <- quote(a(b(1))) expect_equal( - detect_mistakes(user, solution) - , - wrong_value(this = "1(1)", that = quote(a())) + detect_mistakes(user, solution), + wrong_call(this = user, that = solution) ) - # internal atomic + # internal atomic - NEEDS TO CATCH UNNAMED ARGUMENT HANDLING user <- quote(a()) solution <- quote(a(1)) expect_equal( - detect_mistakes(user, solution) - , - missing_argument(this_call = quote(a()), that_name = "x", that = quote(1)) + detect_mistakes(user, solution), + missing_argument(this_call = user, that_name = "x") ) # internal function user <- quote(a(1)) solution <- quote(a(b(1))) expect_equal( - detect_mistakes(user, solution) - , - wrong_value(this = quote(1), that = quote(b())) + detect_mistakes(user, solution), + wrong_value(this = quote(1), that = quote(b()), enclosing_call = user) ) # internal non-function would not appear in a solution @@ -106,45 +96,40 @@ test_that("detect_mistakes detects mis-matched code", { user <- quote(b(1)) solution <- quote(a(1)) expect_equal( - detect_mistakes(user, solution) - , - wrong_value(this = "b(x = 1)", that = quote(a())) + detect_mistakes(user, solution), + wrong_call(this = user, that = solution) ) # non-function user <- quote(1(1)) # nolint solution <- quote(a(1)) expect_equal( - detect_mistakes(user, solution) - , - wrong_value(this = "1(1)", that = quote(a())) + detect_mistakes(user, solution), + wrong_call(this = user, that = solution) ) # internal atomic user <- quote(a(1)) solution <- quote(a(2)) expect_equal( - detect_mistakes(user, solution) - , - wrong_value(this = quote(1), that = quote(2)) + detect_mistakes(user, solution), + wrong_value(this = quote(1), that = quote(2), enclosing_call = user) ) # internal function user <- quote(a(b(1))) solution <- quote(a(c(1))) expect_equal( - detect_mistakes(user, solution) - , - wrong_value(this = "b(x = 1)", that = quote(c())) + detect_mistakes(user, solution), + wrong_call(this = user[[2]], that = solution[[2]], enclosing_call = user) ) # internal non-function user <- quote(a(1(1))) # nolint solution <- quote(a(b(1))) expect_equal( - detect_mistakes(user, solution) - , - wrong_value(this = "1(1)", that = quote(b())) + detect_mistakes(user, solution), + wrong_call(this = user[[2]], that = solution[[2]], enclosing_call = user) ) }) @@ -165,7 +150,7 @@ test_that("detect_mistakes works with atomic solutions", { expect_equal( detect_mistakes(user, solution) , - wrong_value(this = "a(x = 1)", that = quote(1)) + wrong_value(this = user, that = solution) ) user <- quote(a()) @@ -179,18 +164,16 @@ test_that("detect_mistakes works with atomic solutions", { user <- quote(a(1)) solution <- quote(pi) expect_equal( - detect_mistakes(user, solution) - , - wrong_value(this = "a(x = 1)", that = quote(pi)) + detect_mistakes(user, solution), + wrong_value(this = user, that = solution) ) # non-function user <- quote(pi(1)) solution <- quote(pi) expect_equal( - detect_mistakes(user, solution) - , - wrong_value(this = "pi(1)", that = quote(pi)) + detect_mistakes(user, solution), + wrong_value(this = user, that = solution) ) # internal atomics, functions, non-functions, infixes, @@ -439,33 +422,29 @@ test_that("detect_mistakes works with pipes", { user <- quote(b(1 %>% abs())) solution <- quote(b(1)) expect_equal( - detect_mistakes(user, solution) - , - wrong_value("abs(1)", quote(1)) + detect_mistakes(user, solution), + wrong_value(this = user[[2]][[3]], that = solution[[2]], enclosing_call = user) ) user <- quote(sqrt(1)) solution <- quote(sqrt(1 %>% log())) expect_equal( - detect_mistakes(user, solution) - , - wrong_value(this = quote(1), that = quote(log())) + detect_mistakes(user, solution), + wrong_value(this = user[[2]], that = solution[[2]][[3]], enclosing_call = user) ) user <- quote(sqrt(1)) solution <- quote(sqrt(1 %>% log() %>% abs())) # nolint expect_equal( - detect_mistakes(user, solution) - , - wrong_value(this = quote(1), that = quote(abs())) + detect_mistakes(user, solution), + wrong_value(this = user[[2]], that = solution[[2]][[3]], enclosing_call = user) ) user <- quote(sqrt(1 %>% log())) solution <- quote(sqrt(1 %>% log() %>% abs())) # nolint expect_equal( - detect_mistakes(user, solution) - , - wrong_value(this = "log(1)", that = quote(abs())) + detect_mistakes(user, solution), + wrong_call(this = user[[2]][[3]], that = solution[[2]][[3]], enclosing_call = user) ) ## TODO infix operator @@ -481,20 +460,19 @@ test_that("detect_mistakes works with pipes", { user <- quote(a(2 %>% abs())) solution <- quote(a(2 %>% log())) expect_equal( - detect_mistakes(user, solution) - , - wrong_value(this = "abs(2)", that = "log()") + detect_mistakes(user, solution), + wrong_call(this = user[[2]][[3]], that = solution[[2]][[3]], enclosing_call = user) ) - user <- quote(a(2 %>% abs() %>% sqrt())) # nolint - solution <- quote(a(2 %>% log() %>% sqrt())) # nolint - expect_equal( - detect_mistakes(user, solution) - , - wrong_value(this = "abs(2)", that = "log()") - ) + # DOES MESSAGE AUTOMATICALLY UNPIPE INNER ARGUMENTS? + # user <- quote(a(2 %>% abs() %>% sqrt())) # nolint + # solution <- quote(a(2 %>% log() %>% sqrt())) # nolint + # expect_equal( + # detect_mistakes(user, solution), + # wrong_call(this = user[[2]][[2]][[3]], that = solution[[2]][[2]][[3]], enclosing_call = user[[2]]) + # ) - ## TODO infix operator + # TODO infix operator # user <- quote(a(2 %>% abs())) # solution <- quote(a(2 + log(1))) # expect_equal( @@ -507,9 +485,8 @@ test_that("detect_mistakes works with pipes", { user <- quote(1 %>% abs()) solution <- quote(1) expect_equal( - detect_mistakes(user, solution) - , - wrong_value("abs(1)", quote(1)) + detect_mistakes(user, solution), + wrong_value(this = user, that = solution) ) user <- quote(1) @@ -531,9 +508,8 @@ test_that("detect_mistakes works with pipes", { user <- quote(1 %>% log()) solution <- quote(1 %>% log() %>% abs()) # nolint expect_equal( - detect_mistakes(user, solution) - , - wrong_value(this = "log(1)", that = quote(abs())) + detect_mistakes(user, solution), + wrong_call(this = user[[3]], that = quote(abs())) ) ## TODO infix operator @@ -549,17 +525,17 @@ test_that("detect_mistakes works with pipes", { user <- quote(2 %>% abs()) solution <- quote(2 %>% log()) expect_equal( - detect_mistakes(user, solution) - , - wrong_value(this = "abs(2)", that = "log()") + detect_mistakes(user, solution), + wrong_call(this = unpipe(user), that = "log()") ) user <- quote(2 %>% abs() %>% sqrt()) # nolint solution <- quote(2 %>% log() %>% sqrt()) # nolint expect_equal( - detect_mistakes(user, solution) - , - wrong_value(this = "abs(2)", that = "log()") + detect_mistakes(user, solution), + wrong_call(this = unpipe(unpipe(user)[[2]]), + that = unpipe(unpipe(solution)[[2]]), + enclosing_call = user) ) ## TODO need to look into infix operators @@ -575,9 +551,8 @@ test_that("detect_mistakes works with pipes", { user <- quote(b(1)) solution <- quote(b(1) %>% a()) expect_equal( - detect_mistakes(user, solution) - , - wrong_value(this = "b(x = 1)", that = "a()") + detect_mistakes(user, solution), + wrong_call(this = user, that = "a()") ) }) @@ -586,32 +561,43 @@ test_that("detect_mistakes handles argument names correctly", { user <- quote(c(x = a(b(1)))) solution <- quote(c(x = b(1))) expect_equal( - detect_mistakes(user, solution) - , - wrong_value(this = "a(x = b(1))", - that = quote(b()), - this_name = "", - that_name = "") + detect_mistakes(user, solution), + wrong_call(this = user[[2]], + this_name = names(as.list(user))[2], + that = solution[[2]], + enclosing_call = user) ) user <- quote(b(x = 1)) - solution <- quote(b()) + solution <- quote(b(1)) + expect_null( + detect_mistakes(user, solution) + ) + + user <- quote(b(1)) + solution <- quote(b(x = 1)) + expect_null( + detect_mistakes(user, solution) + ) + + user <- quote(b(y = 1)) + solution <- quote(b(x = 1)) expect_equal( detect_mistakes(user, solution) , surplus_argument(this_call = quote(b()), this = quote(1), - this_name = "x") + this_name = "y") ) - user <- quote(b(x = a(1))) - solution <- quote(b()) + user <- quote(b(y = a(1))) + solution <- quote(b(1)) expect_equal( detect_mistakes(user, solution) , surplus_argument(this_call = quote(b()), this = "a()", - this_name = "x") + this_name = "y") ) test_fn <<- function(x, y = 1, z = FALSE, ...) {return(1)} @@ -635,6 +621,8 @@ test_that("detect_mistakes handles argument names correctly", { surplus_argument(this_call = quote(test_fn()), this = quote(1), this_name = "a") ) + # This user code looks correct (and runs!) but na.rm is an argument passed to + # ... that does not appear in the solution, and so should be flagged wrong. user <- quote(mean(1:10, cut = 1, na.rm = TRUE)) solution <- quote(mean(1:10, TRUE, cut = 1)) expect_equal( @@ -643,7 +631,7 @@ test_that("detect_mistakes handles argument names correctly", { # wrong_value(this = quote(1), # this_name = "cut", # that = quote(TRUE)) - surplus_argument(this_call = quote(mean()), this = quote(1), this_name = "cut") + surplus_argument(this_call = quote(mean()), this = quote(TRUE), this_name = "na.rm") ) }) @@ -653,11 +641,8 @@ test_that("detect_mistakes handles weird cases", { user <- quote(sum(sum(1, 2), 3)) solution <- quote(sum(1, 2, 3)) expect_equal( - detect_mistakes(user, solution) - , - # wrong_value(this = "sum(1, 2)", that = quote(1)) - missing_argument(this_call = quote(sum()), - that = quote(3)) + detect_mistakes(user, solution), + wrong_value(this = user[[2]], that = solution[[2]], enclosing_call = user) ) user <- quote(sum(1, 2)) @@ -677,10 +662,8 @@ test_that("detect_mistakes checks the call first", { user <- quote(0 + sqrt(log(2))) solution <- quote(sqrt(log(2))) expect_equal( - detect_mistakes(user, solution) - , - wrong_value(this = "0 + sqrt(log(2))", that = quote(sqrt(log(2)))) - # missing_argument(this_call = quote(sum()), that = quote(3)) + detect_mistakes(user, solution), + wrong_call(this = user, that = solution) ) }) @@ -700,27 +683,50 @@ test_that("detect_mistakes does not throw error for unused argument", { test_that("detect_mistakes does not throw error for multiple matches of argument", { - a <- function(x, ya = 1, yb = 2) x - user <- quote(a(1, y = 2)) - solution <- quote(a(1, ya = 2)) + z <<- function(x, ya = 1, yb = 2) x + user <- quote(z(1, y = 2)) + solution <- quote(z(1, ya = 2)) expect_equal( - detect_mistakes(user, solution) - , - missing_argument(this_call = quote(a()), that = quote(2), that_name = "ya") + detect_mistakes(user, solution), + bad_argument_name(this_call = user, + this = user[[3]], + this_name = names(as.list(user)[3])) ) }) test_that("detect_mistakes does not throw error for multiple matches of formal", { + + zz <<- function(x, yab = 1, ...) x + user <- quote(zz(1, y = 2, ya = 3)) + solution <- quote(zz(1)) + expect_equal( + detect_mistakes(user, solution), + too_many_matches(this_call = user, that_name = "yab") + ) - a <- function(x, yab = 1, ...) x - user <- quote(a(1, y = 2, ya = 3)) - solution <- quote(a(1)) +}) + +test_that("detect_mistakes handles duplicated argument names", { + + dd <<- function(a) a + user <- quote(dd(a = 1, a = 2)) + solution <- quote(dd(a = 1)) expect_equal( - detect_mistakes(user, solution) - , - surplus_argument(this_call = quote(a()), this = quote(2), this_name = "y") + detect_mistakes(user, solution), + duplicate_name(this_call = user, this_name = "a") ) }) +test_that("detect_mistakes does not return correct prematurely", { + + j <<- function(...) 1 + user <- quote(j(x = a(1), y = a(2))) + solution <- quote(j(x = a(x = 1), y = a(3))) + expect_equal( + detect_mistakes(user, solution), + wrong_value(this = user[[3]][[2]], that = solution[[3]][[2]], enclosing_call = user[[3]]) + ) + +}) diff --git a/tests/testthat/test_grade_learnr.R b/tests/testthat/test_grade_learnr.R index e2dff8c9..94f5c6e0 100644 --- a/tests/testthat/test_grade_learnr.R +++ b/tests/testthat/test_grade_learnr.R @@ -74,6 +74,6 @@ test_that("Grade learnr check_code", { check_code = "grade_code(glue_incorrect = '{.message}')", solution_code = "exp(log(1))" ), - "I expected 1; what you wrote was interpreted as 2." + "In log(2), I expected 1 where you wrote 2." ) }) diff --git a/tests/testthat/test_sanity_checks.R b/tests/testthat/test_sanity_checks.R new file mode 100644 index 00000000..26f6d6b9 --- /dev/null +++ b/tests/testthat/test_sanity_checks.R @@ -0,0 +1,566 @@ +context("Check sanity messages") + +a <<- function(x) x +b <<- function(x) x +f <<- function(x, y) x + y +g <<- function(x, y = a(1)) x + y + +test_that("detect_mistakes detects wrong calls", { + + solution <- quote(b(1)) + user <- quote(a(1)) + expect_equal( + detect_mistakes(user, solution), + wrong_call(this = quote(a()), that = quote(b())) + ) + + solution <- quote(a()) + user <- quote(a) + expect_equal( + detect_mistakes(user, solution), + wrong_value(this = quote(a), that = quote(a())) + ) + + solution <- quote(a(1)) + user <- quote(b(a(1))) + expect_equal( + detect_mistakes(user, solution), + wrong_call(this = user, that = solution) + ) + + solution <- quote(a(1)) + user <- quote(a(b(1))) + expect_equal( + detect_mistakes(user, solution), + wrong_value(this = user[[2]], that = solution[[2]], enclosing_call = user) + ) + + solution <- quote(a(1)) + user <- quote(a(a(1))) + expect_equal( + detect_mistakes(user, solution), + wrong_value(this = user[[2]], that = solution[[2]], enclosing_call = user) + ) + + solution <- quote(a(1)) + user <- quote(0 + a(1)) + expect_equal( + detect_mistakes(user, solution), + wrong_call(this = user, that = solution) + ) + + solution <- quote(a(1)) + user <- quote(a(1) + 0) + expect_equal( + detect_mistakes(user, solution), + wrong_call(this = user, that = solution) + ) + + solution <- quote(a() + b()) + user <- quote(a() + a()) + expect_equal( + detect_mistakes(user, solution), + wrong_call(this = user[[3]], that = solution[[3]], enclosing_call = user) + ) + + solution <- quote(a() + b()) + user <- quote(b() + a()) + expect_equal( + detect_mistakes(user, solution), + wrong_call(this = user[[2]], that = solution[[2]], enclosing_call = user) + ) + + solution <- quote(a(b(1))) + user <- quote(b(1) %>% a()) + expect_null( + detect_mistakes(user, solution) + ) + + solution <- quote(a(b(1))) + user <- quote(a(1) %>% b()) + expect_equal( + detect_mistakes(user, solution), + wrong_call(this = user[[3]], that = solution) + ) + + solution <- quote(a(b(1))) + user <- quote(a(1) %>% a()) + expect_equal( + detect_mistakes(user, solution), + wrong_call(this = user[[3]], that = solution[[2]], enclosing_call = user) + ) + + solution <- quote(a(b(1))) + user <- quote(b(1) %>% b()) + expect_equal( + detect_mistakes(user, solution), + wrong_call(this = user[[3]], that = solution) + ) + + solution <- quote(f(1, y = a(1))) + user <- quote(f(1, y = b(1))) + expect_equal( + detect_mistakes(user, solution), + wrong_call( + this = user[[3]], + that = solution[[3]], + this_name = "y", + enclosing_call = user + ) + ) + + solution <- quote(f(1, y = a(1))) + user <- quote(f(1, y = b(a(1)))) + expect_equal( + detect_mistakes(user, solution), + wrong_call( + this = user[[3]], + that = solution[[3]], + this_name = "y", + enclosing_call = user + ) + ) + + solution <- quote(f(1, y = a(1))) + user <- quote(f(1, y = a(b(1)))) + expect_equal( + detect_mistakes(user, solution), + wrong_value( + this = user[[3]][[2]], + that = solution[[3]][[2]], + enclosing_call = user[[3]] + ) + ) + + solution <- quote(f(1, y = a(1))) + user <- quote(f(1, y = b(b(1)))) + expect_equal( + detect_mistakes(user, solution), + wrong_call( + this = user[[3]], + that = solution[[3]], + this_name = "y", + enclosing_call = user + ) + ) + + solution <- quote(f(1, y = a(1))) + user <- quote(f(1, y = a(a(1)))) + expect_equal( + detect_mistakes(user, solution), + wrong_value( + this = user[[3]][[2]], + that = solution[[3]][[2]], + enclosing_call = user[[3]] + ) + ) + + solution <- quote(g(1)) + user <- quote(g(1, y = a(1))) + expect_null( + detect_mistakes(user, solution) + ) + + solution <- quote(g(1)) + user <- quote(g(1, y = b(1))) + expect_equal( + detect_mistakes(user, solution), + wrong_call( + this = user[[3]], + that = formals(g)[[2]], + this_name = "y", + enclosing_call = user + ) + ) + + solution <- quote(f(1, y = a(1))) + user <- quote(f(1, y = f(1))) + expect_equal( + detect_mistakes(user, solution), + wrong_call( + this = user[[3]], + that = formals(g)[[2]], + this_name = "y", + enclosing_call = user + ) + ) + +}) + +test_that("detect_mistakes detects wrong values", { + + x <<- 1 + y <<- 1 + X <<- 1 + + solution <- quote(1) + user <- quote(2) + expect_equal( + detect_mistakes(user, solution), + wrong_value( + this = user, + that = solution + ) + ) + + solution <- quote(1) + user <- quote(-1) + expect_equal( + detect_mistakes(user, solution), + wrong_value( + this = user, + that = solution + ) + ) + + solution <- quote(1) + user <- quote(1L) + expect_equal( + detect_mistakes(user, solution), + wrong_value( + this = user, + that = solution + ) + ) + + solution <- quote(1) + user <- quote(1()) + expect_equal( + detect_mistakes(user, solution), + wrong_value( + this = user, + that = solution + ) + ) + + solution <- quote(x) + user <- quote(y) + expect_equal( + detect_mistakes(user, solution), + wrong_value( + this = user, + that = solution + ) + ) + + solution <- quote(x) + user <- quote(X) + expect_equal( + detect_mistakes(user, solution), + wrong_value( + this = user, + that = solution + ) + ) + + solution <- quote(a(1)) + user <- quote(a(2)) + expect_equal( + detect_mistakes(user, solution), + wrong_value( + this = deparse_to_string(user[[2]]), + that = solution[[2]], + enclosing_call = user + ) + ) + + solution <- quote(a(1)) + user <- quote(a(-1)) + expect_equal( + detect_mistakes(user, solution), + wrong_value( + this = user[[2]], + that = solution[[2]], + enclosing_call = user + ) + ) + + solution <- quote(a(1)) + user <- quote(a(1L)) + expect_equal( + detect_mistakes(user, solution), + wrong_value( + this = deparse_to_string(user[[2]]), + that = solution[[2]], + enclosing_call = user + ) + ) + + solution <- quote(a(x)) + user <- quote(a(y)) + expect_equal( + detect_mistakes(user, solution), + wrong_value( + this = deparse_to_string(user[[2]]), + that = solution[[2]], + enclosing_call = user + ) + ) + + solution <- quote(a(x)) + user <- quote(a(X)) + expect_equal( + detect_mistakes(user, solution), + wrong_value( + this = deparse_to_string(user[[2]]), + that = solution[[2]], + enclosing_call = user + ) + ) + + solution <- quote(1 + 2) + user <- quote(1 + 1) + expect_equal( + detect_mistakes(user, solution), + wrong_value( + this = deparse_to_string(user[[3]]), + that = solution[[3]], + enclosing_call = user + ) + ) + + solution <- quote(1 + 2) + user <- quote(2 + 1) + expect_equal( + detect_mistakes(user, solution), + wrong_value( + this = deparse_to_string(user[[2]]), + that = solution[[2]], + enclosing_call = user + ) + ) + + solution <- quote(1 %>% f(2)) + user <- quote(3 %>% f(2)) + expect_equal( + detect_mistakes(user, solution), + wrong_value( + this = deparse_to_string(user[[2]]), + that = solution[[2]], + enclosing_call = user + ) + ) + + solution <- quote(1 %>% f(2)) + user <- quote(1 %>% f(3)) + expect_equal( + detect_mistakes(user, solution), + wrong_value( + this = deparse_to_string(user[[3]][[2]]), + that = solution[[3]][[2]], + enclosing_call = user + ) + ) + +}) + +test_that("detect_mistakes detects bad argument names", { + + tricky <<- function(aa = 1, ab = 2, ac = 3) aa + + solution <- quote(tricky(ab = 1)) + user <- quote(tricky(a = 1)) + expect_equal( + detect_mistakes(user, solution), + bad_argument_name( + this_call = user, + this = user[[2]], + this_name = names(as.list(user)[2]) + ) + ) + + solution <- quote(tricky(ab = 1)) + user <- quote(tricky(1, 2, a = 1)) + expect_equal( + detect_mistakes(user, solution), + bad_argument_name( + this_call = user, + this = user[[4]], + this_name = names(as.list(user)[4]) + ) + ) + + solution <- quote(tricky(ab = 1)) + user <- quote(1 %>% tricky(a = 2)) + expect_equal( + detect_mistakes(user, solution), + bad_argument_name( + this_call = user[[3]], + this = user[[3]][[2]], + this_name = names(as.list(user[[3]])[2]) + ) + ) + + solution <- quote(tricky(ab = 1)) + user <- quote(1 %>% tricky(a = .)) + expect_equal( + detect_mistakes(user, solution), + bad_argument_name( + this_call = user[[3]], + this = user[[2]], + this_name = names(as.list(user[[3]])[2]) + ) + ) + +}) + +test_that("detect_mistakes detects too many matches", { + + tricky2 <<- function(ambiguous = 1, ...) ambiguous + not_tricky <<- function(a = 1, ambiguous = 2, ...) a + + solution <- quote(tricky2(ambiguous = 2)) + user <- quote(tricky2(a = 2, am = 2)) + expect_equal( + detect_mistakes(user, solution), + too_many_matches( + this_call = user, + that_name = names(as.list(solution)[2]) + ) + ) + + solution <- quote(not_tricky(ambiguous = 2)) + user <- quote(not_tricky(a = 1, am = 2)) + expect_null( + detect_mistakes(user, solution) + ) + + solution <- quote(tricky2(ambiguous = 2)) + user <- quote(2 %>% tricky2(a = ., am = 2)) + expect_equal( + detect_mistakes(user, solution), + too_many_matches( + this_call = user[[3]], + that_name = names(as.list(solution)[2]) + ) + ) + +}) + +test_that("detect_mistakes detects surplus arguments", { + + h <<- function(x) x + i <<- function(x, ...) x + + solution <- quote(h(x = 1)) + user <- quote(h(x = 1, y = 2)) + expect_equal( + detect_mistakes(user, solution), + surplus_argument( + this_call = user, + this = user[[3]], + this_name = names(as.list(user)[3]) + ) + ) + + solution <- quote(h(x = 1)) + user <- quote(h(1, 2)) + expect_equal( + detect_mistakes(user, solution), + surplus_argument( + this_call = user, + this = user[[3]], + this_name = names(as.list(user)[3]) + ) + ) + + solution <- quote(i(x = 1)) + user <- quote(i(1, 2)) + expect_equal( + detect_mistakes(user, solution), + surplus_argument( + this_call = user, + this = user[[3]], + this_name = names(as.list(user)[3]) + ) + ) + + solution <- quote(i(x = 1)) + user <- quote(i(1, x = 2)) + expect_equal( + detect_mistakes(user, solution), + surplus_argument( + this_call = user, + this = user[[2]], + this_name = names(as.list(user)[2]) + ) + ) + + solution <- quote(h(x = 1)) + user <- quote(1 %>% h(2)) + expect_equal( + detect_mistakes(user, solution), + surplus_argument( + this_call = user[[3]], + this = user[[3]][[2]], + this_name = names(as.list(as.list(user)[[3]])[2]) + ) + ) + +}) + +test_that("detect_mistakes detects missing argument", { + + solution <- quote(f(x = 1, y = 1)) + user <- quote(f(x = 1)) + expect_equal( + detect_mistakes(user, solution), + missing_argument( + this_call = user, + that_name = names(as.list(solution)[3]) + ) + ) + + solution <- quote(a(f(x = 1, y = 1))) + user <- quote(a(f(x = 1))) + expect_equal( + detect_mistakes(user, solution), + missing_argument( + this_call = user[[2]], + that_name = names(as.list(solution[[2]])[3]), + enclosing_call = user + ) + ) + + solution <- quote(f(x = 1, y = 1)) + user <- quote(f(y = 1)) + expect_equal( + detect_mistakes(user, solution), + missing_argument( + this_call = user, + that_name = names(as.list(solution)[2]) + ) + ) + + solution <- quote(f(x = 1, y = 1)) + user <- quote(f(1)) + expect_equal( + detect_mistakes(user, solution), + missing_argument( + this_call = user, + that_name = names(as.list(solution)[3]) + ) + ) + + solution <- quote(f(x = 1, y = 1)) + user <- quote(1 %>% f()) + expect_equal( + detect_mistakes(user, solution), + missing_argument( + this_call = user[[3]], + that_name = names(as.list(solution)[3]) + ) + ) + + solution <- quote(a(f(x = 1, y = 1))) + user <- quote(a(1 %>% f())) + expect_equal( + detect_mistakes(user, solution), + missing_argument( + this_call = user[[2]][[3]], + that_name = names(as.list(solution[[2]])[3]), + enclosing_call = user + ) + ) + +})