More informative messages when fail_if(cond = ) is invalid (#341)

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")),

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).

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))
   }

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 <simpleWarning>
+      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 <simpleWarning>
+      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 <simpleWarning>
+      The `cond` argument to `pass_if()` must be coercible to logical, not an object of class <character>.
+
+---
+
+    Code
+      grade <- expect_grade_this(fail_if(!all.equal(.result, .solution)), user_code = "1",
+      solution_code = "2", is_correct = logical(0))
+    Warning <simpleWarning>
+      The `cond` argument to `fail_if()` produced an error:
+        Error in !all.equal(.result, .solution) : invalid argument type
+

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,