diff --git a/DESCRIPTION b/DESCRIPTION index 1229a7f3..4d42848d 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,7 +1,7 @@ Type: Package Package: gradethis Title: Automated Feedback for Student Exercises in 'learnr' Tutorials -Version: 0.2.12.9000 +Version: 0.2.12.9001 Authors@R: c( person("Garrick", "Aden-Buie", , "garrick@posit.co", role = "aut", comment = c(ORCID = "0000-0002-7111-0077")), diff --git a/NEWS.md b/NEWS.md index c64663c3..f2184af1 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,3 +1,7 @@ +# gradethis 0.2.12.9001 + +* `pass_if()` and `fail_if()` now produce more informative error messages if their `cond` argument is invalid (#341). + # gradethis 0.2.12.9000 * New functions: `user_object_get()`, `user_object_exists()` and `user_object_list()` can be used to interact with objects created by the student's code. `solution_object_get()`, `solution_object_exists()` and `solution_object_list()` do the same for objects created by the solution code (#333). diff --git a/R/graded.R b/R/graded.R index ec8796f4..c4fcddc9 100644 --- a/R/graded.R +++ b/R/graded.R @@ -681,7 +681,7 @@ pass_if <- function( } if (detect_grade_this(env)) { - assert_gradethis_condition_type_is_value(cond, "pass_if") + assert_gradethis_condition_is_true_or_false(cond, "pass_if") if (cond) { message <- message %||% getOption("gradethis.pass", "Correct!") pass(message, env = env, ..., praise = praise) @@ -714,7 +714,7 @@ fail_if <- function( } if (detect_grade_this(env)) { - assert_gradethis_condition_type_is_value(cond, "fail_if") + assert_gradethis_condition_is_true_or_false(cond, "fail_if") if (cond) { message <- message %||% getOption("gradethis.fail", "Incorrect.") fail(message, env = env, ..., hint = hint, encourage = encourage) @@ -943,11 +943,76 @@ fail_if_error <- function( } } -assert_gradethis_condition_type_is_value <- function(x, from = NULL) { - type <- condition_type(x) +assert_gradethis_condition_is_true_or_false <- function(cond, from = NULL) { + from <- if (!is.null(from)) paste0("to `", from, "()` ") else "" + + assert_gradethis_condition_does_not_error(cond, from) + assert_gradethis_condition_type_is_value(cond, from) + assert_gradethis_condition_is_scalar(cond, from) + assert_gradethis_condition_is_logical(cond, from) + assert_gradethis_condition_is_not_na(cond, from) +} + +assert_gradethis_condition_does_not_error <- function(cond, from) { + error <- rlang::catch_cnd(cond, "error") + + if (rlang::is_error(error)) { + msg_internal <- paste0( + "The `cond` argument ", from, "produced an error:", "\n", + " Error in ", format(error$call), " : ", error$message + ) + + warning(msg_internal, immediate. = TRUE, call. = !is.null(from)) + grade_grading_problem(error = error) + } +} + +assert_gradethis_condition_type_is_value <- function(cond, from) { + type <- condition_type(cond) + if (!identical(type, "value")) { - from <- if (!is.null(from)) paste0(from, "() ") else "" - msg_internal <- paste0(from, "does not accept functions or formulas when used inside grade_this().") + msg_internal <- paste0( + "The `cond` argument ", + from, + "does not accept functions or formulas when used inside `grade_this()`." + ) + + warning(msg_internal, immediate. = TRUE, call. = !is.null(from)) + grade_grading_problem(error = list(message = msg_internal)) + } +} + +assert_gradethis_condition_is_scalar <- function(cond, from) { + cond_length <- length(cond) + + if (cond_length != 1) { + msg_internal <- paste0( + "The `cond` argument ", from, "must be length 1, ", + "not ", cond_length, "." + ) + + warning(msg_internal, immediate. = TRUE, call. = !is.null(from)) + grade_grading_problem(error = list(message = msg_internal)) + } +} + +assert_gradethis_condition_is_logical <- function(cond, from) { + cond_class <- paste0("<", paste(class(cond), collapse = "/"), ">") + + if (!inherits(cond, "logical") && identical(as.logical(cond), NA)) { + msg_internal <- paste0( + "The `cond` argument ", from, "must be coercible to logical, ", + "not an object of class ", cond_class, "." + ) + + warning(msg_internal, immediate. = TRUE, call. = !is.null(from)) + grade_grading_problem(error = list(message = msg_internal)) + } +} + +assert_gradethis_condition_is_not_na <- function(cond, from) { + if (identical(cond, NA)) { + msg_internal <- paste0("The `cond` argument ", from, "must not be `NA`.") warning(msg_internal, immediate. = TRUE, call. = !is.null(from)) grade_grading_problem(error = list(message = msg_internal)) } diff --git a/tests/testthat/_snaps/graded.md b/tests/testthat/_snaps/graded.md new file mode 100644 index 00000000..912c072c --- /dev/null +++ b/tests/testthat/_snaps/graded.md @@ -0,0 +1,33 @@ +# pass_if() and fail_if() give errors for invalid cond + + Code + grade <- expect_grade_this(pass_if(~TRUE), user_code = "1", solution_code = "2", + is_correct = logical(0)) + Warning + The `cond` argument to `pass_if()` does not accept functions or formulas when used inside `grade_this()`. + +--- + + Code + grade <- expect_grade_this(fail_if(~TRUE), user_code = "1", solution_code = "2", + is_correct = logical(0)) + Warning + The `cond` argument to `fail_if()` does not accept functions or formulas when used inside `grade_this()`. + +--- + + Code + grade <- expect_grade_this(pass_if(all.equal(.result, .solution)), user_code = "1", + solution_code = "2", is_correct = logical(0)) + Warning + The `cond` argument to `pass_if()` must be coercible to logical, not an object of class . + +--- + + Code + grade <- expect_grade_this(fail_if(!all.equal(.result, .solution)), user_code = "1", + solution_code = "2", is_correct = logical(0)) + Warning + The `cond` argument to `fail_if()` produced an error: + Error in !all.equal(.result, .solution) : invalid argument type + diff --git a/tests/testthat/test-graded.R b/tests/testthat/test-graded.R index 53741783..e831d800 100644 --- a/tests/testthat/test-graded.R +++ b/tests/testthat/test-graded.R @@ -482,6 +482,48 @@ test_that("pass_if() and fail_if() use default pass/fail message in grade_this() ) }) +test_that("pass_if() and fail_if() give errors for invalid cond", { + expect_snapshot( + grade <- expect_grade_this( + pass_if(~ TRUE), + user_code = "1", + solution_code = "2", + is_correct = logical(0) + ) + ) + expect_type(grade$error, "list") + + expect_snapshot( + grade <- expect_grade_this( + fail_if(~ TRUE), + user_code = "1", + solution_code = "2", + is_correct = logical(0) + ) + ) + expect_type(grade$error, "list") + + expect_snapshot( + grade <- expect_grade_this( + pass_if(all.equal(.result, .solution)), + user_code = "1", + solution_code = "2", + is_correct = logical(0) + ) + ) + expect_type(grade$error, "list") + + expect_snapshot( + grade <- expect_grade_this( + fail_if(!all.equal(.result, .solution)), + user_code = "1", + solution_code = "2", + is_correct = logical(0) + ) + ) + expect_type(grade$error, "list") +}) + test_that("grade_if_equal() edge cases with diffobj::ses()", { result <- c(39.6, 40.1, 35, 42, 34.5, 41.4, 39, 40.6, 36.5, 37.6, 35.7, 41.3, 37.6, 41.1, 36.4, 41.6, 35.5, 41.1, 35.9, 41.8, 33.5, 39.7,