Standardise expectation helpers

R/expect-comparison.R

@@ -19,7 +19,12 @@
 #' @name comparison-expectations
 NULL
 
-expect_compare <- function(operator = c("<", "<=", ">", ">="), act, exp) {
+expect_compare_ <- function(
+  operator = c("<", "<=", ">", ">="),
+  act,
+  exp,
+  trace_env = caller_env()
+) {
   operator <- match.arg(operator)
   op <- match.fun(operator)
 
@@ -42,7 +47,7 @@ expect_compare <- function(operator = c("<", "<=", ">", ">="), act, exp) {
       exp$lab,
       act$val - exp$val
     )
-    return(fail(msg, trace_env = caller_env()))
+    return(fail(msg, trace_env = trace_env))
   }
   pass(act$val)
 }
@@ -52,7 +57,7 @@ expect_lt <- function(object, expected, label = NULL, expected.label = NULL) {
   act <- quasi_label(enquo(object), label, arg = "object")
   exp <- quasi_label(enquo(expected), expected.label, arg = "expected")
 
-  expect_compare("<", act, exp)
+  expect_compare_("<", act, exp)
 }
 
 #' @export
@@ -61,7 +66,7 @@ expect_lte <- function(object, expected, label = NULL, expected.label = NULL) {
   act <- quasi_label(enquo(object), label, arg = "object")
   exp <- quasi_label(enquo(expected), expected.label, arg = "expected")
 
-  expect_compare("<=", act, exp)
+  expect_compare_("<=", act, exp)
 }
 
 #' @export
@@ -70,7 +75,7 @@ expect_gt <- function(object, expected, label = NULL, expected.label = NULL) {
   act <- quasi_label(enquo(object), label, arg = "object")
   exp <- quasi_label(enquo(expected), expected.label, arg = "expected")
 
-  expect_compare(">", act, exp)
+  expect_compare_(">", act, exp)
 }
 
 #' @export
@@ -79,7 +84,7 @@ expect_gte <- function(object, expected, label = NULL, expected.label = NULL) {
   act <- quasi_label(enquo(object), label, arg = "object")
   exp <- quasi_label(enquo(expected), expected.label, arg = "expected")
 
-  expect_compare(">=", act, exp)
+  expect_compare_(">=", act, exp)
 }
 
 

R/expect-condition.R

@@ -115,7 +115,7 @@ expect_error <- function(
   label = NULL
 ) {
   if (edition_get() >= 3) {
-    expect_condition_matching(
+    expect_condition_matching_(
       "error",
       {{ object }},
       regexp = regexp,
@@ -163,7 +163,7 @@ expect_warning <- function(
       warn("The `all` argument is deprecated")
     }
 
-    expect_condition_matching(
+    expect_condition_matching_(
       "warning",
       {{ object }},
       regexp = regexp,
@@ -208,7 +208,7 @@ expect_message <- function(
   label = NULL
 ) {
   if (edition_get() >= 3) {
-    expect_condition_matching(
+    expect_condition_matching_(
       "message",
       {{ object }},
       regexp = regexp,
@@ -240,7 +240,7 @@ expect_condition <- function(
   label = NULL
 ) {
   if (edition_get() >= 3) {
-    expect_condition_matching(
+    expect_condition_matching_(
       "condition",
       {{ object }},
       regexp = regexp,
@@ -273,7 +273,7 @@ expect_condition <- function(
   }
 }
 
-expect_condition_matching <- function(
+expect_condition_matching_ <- function(
   base_class,
   object,
   regexp = NULL,
@@ -309,7 +309,12 @@ expect_condition_matching <- function(
   # Access error fields with `[[` rather than `$` because the
   # `$.Throwable` from the rJava package throws with unknown fields
   if (!is.null(msg)) {
-    return(fail(msg, info = info, trace = act$cap[["trace"]], trace_env = trace_env))
+    return(fail(
+      msg,
+      info = info,
+      trace = act$cap[["trace"]],
+      trace_env = trace_env
+    ))
   }
   # If a condition was expected, return it. Otherwise return the value
   # of the expression.

R/expect-constant.R

@@ -30,14 +30,14 @@ NULL
 #' @rdname logical-expectations
 expect_true <- function(object, info = NULL, label = NULL) {
   act <- quasi_label(enquo(object), label, arg = "object")
-  expect_waldo_constant(act, TRUE, info = info, ignore_attr = TRUE)
+  expect_waldo_constant_(act, TRUE, info = info, ignore_attr = TRUE)
 }
 
 #' @export
 #' @rdname logical-expectations
 expect_false <- function(object, info = NULL, label = NULL) {
   act <- quasi_label(enquo(object), label, arg = "object")
-  expect_waldo_constant(act, FALSE, info = info, ignore_attr = TRUE)
+  expect_waldo_constant_(act, FALSE, info = info, ignore_attr = TRUE)
 }
 
 #' Does code return `NULL`?
@@ -56,12 +56,18 @@ expect_false <- function(object, info = NULL, label = NULL) {
 #' show_failure(expect_null(y))
 expect_null <- function(object, info = NULL, label = NULL) {
   act <- quasi_label(enquo(object), label, arg = "object")
-  expect_waldo_constant(act, NULL, info = info)
+  expect_waldo_constant_(act, NULL, info = info)
 }
 
 # helpers -----------------------------------------------------------------
 
-expect_waldo_constant <- function(act, constant, info, ...) {
+expect_waldo_constant_ <- function(
+  act,
+  constant,
+  info,
+  ...,
+  trace_env = caller_env()
+) {
   comp <- waldo_compare(
     act$val,
     constant,
@@ -77,7 +83,7 @@ expect_waldo_constant <- function(act, constant, info, ...) {
       deparse(constant),
       paste0(comp, collapse = "\n\n")
     )
-    return(fail(msg, info = info, trace_env = caller_env()))
+    return(fail(msg, info = info, trace_env = trace_env))
   }
 
   pass(act$val)

R/expect-equality.R

@@ -67,7 +67,7 @@ expect_equal <- function(
   exp <- quasi_label(enquo(expected), expected.label, arg = "expected")
 
   if (edition_get() >= 3) {
-    expect_waldo_equal("equal", act, exp, info, ..., tolerance = tolerance)
+    expect_waldo_equal_("equal", act, exp, info, ..., tolerance = tolerance)
   } else {
     if (!is.null(tolerance)) {
       comp <- compare(act$val, exp$val, ..., tolerance = tolerance)
@@ -97,7 +97,7 @@ expect_identical <- function(
   exp <- quasi_label(enquo(expected), expected.label, arg = "expected")
 
   if (edition_get() >= 3) {
-    expect_waldo_equal("identical", act, exp, info, ...)
+    expect_waldo_equal_("identical", act, exp, info, ...)
   } else {
     ident <- identical(act$val, exp$val, ...)
     if (ident) {
@@ -119,7 +119,14 @@ expect_identical <- function(
   }
 }
 
-expect_waldo_equal <- function(type, act, exp, info, ...) {
+expect_waldo_equal_ <- function(
+  type,
+  act,
+  exp,
+  info,
+  ...,
+  trace_env = caller_env()
+) {
   comp <- waldo_compare(
     act$val,
     exp$val,
@@ -137,7 +144,7 @@ expect_waldo_equal <- function(type, act, exp, info, ...) {
       "`expected`",
       paste0(comp, collapse = "\n\n")
     )
-    return(fail(msg, info = info, trace_env = caller_env()))
+    return(fail(msg, info = info, trace_env = trace_env))
   }
   pass(act$val)
 }

R/expect-length.R

@@ -21,7 +21,7 @@ expect_length <- function(object, n) {
 
   if (act$n != n) {
     msg <- sprintf("%s has length %i, not length %i.", act$lab, act$n, n)
-    return(fail(msg, trace_env = parent.frame()))
+    return(fail(msg))
   }
   pass(act$val)
 }

R/expect-output.R

@@ -45,6 +45,7 @@ expect_output <- function(
     }
     pass(act$val)
   } else {
-    expect_match(act$cap, enc2native(regexp), ..., info = info, label = act$lab)
+    act <- new_actual(act$cap, act$lab)
+    expect_match_(act, enc2native(regexp), ...)
   }
 }

R/expect-self-test.R

@@ -85,15 +85,16 @@ expect_failure <- function(expr, message = NULL, ...) {
   }
 
   if (!is.null(message)) {
-    return(expect_match(status$last_failure$message, message, ...))
+    act <- new_actual(status$last_failure$message, "Failure message")
+    return(expect_match_(act, message, ...))
   }
   pass(NULL)
 }
 
 #' @export
 #' @rdname expect_success
 expect_snapshot_failure <- function(expr) {
-  expect_snapshot_error(expr, "expectation_failure")
+  expect_snapshot_condition_("expectation_failure", expr)
 }
 
 #' Test for absence of success or failure
@@ -134,13 +135,13 @@ expect_no_failure <- function(expr) {
 }
 
 expect_snapshot_skip <- function(x, cran = FALSE) {
-  expect_snapshot_error(x, class = "skip", cran = cran)
+  expect_snapshot_condition_("skip", x)
 }
 expect_skip <- function(code) {
-  expect_condition(code, class = "skip")
+  expect_condition_matching_("skip", code)
 }
 expect_no_skip <- function(code) {
-  expect_no_condition(code, class = "skip")
+  expect_no_("skip", code)
 }
 
 

R/expectations-matches.R

@@ -103,10 +103,17 @@ expect_match_ <- function(
   all = TRUE,
   info = NULL,
   label = NULL,
-  negate = FALSE
+  negate = FALSE,
+  trace_env = caller_env()
 ) {
   matches <- grepl(regexp, act$val, perl = perl, fixed = fixed, ...)
   condition <- if (negate) !matches else matches
+  ok <- if (all) all(condition) else any(condition)
+
+  if (ok) {
+    return(pass(act$val))
+  }
+
   escape <- if (fixed) identity else escape_regex
 
   if (length(act$val) == 1) {
@@ -117,14 +124,12 @@ expect_match_ <- function(
       paste0("* ", escape(encodeString(act$val)), collapse = "\n")
     )
   }
-  if (if (all) !all(condition) else !any(condition)) {
-    msg <- sprintf(
-      if (negate) "%s does match %s.\n%s" else "%s does not match %s.\n%s",
-      escape(act$lab),
-      encodeString(regexp, quote = '"'),
-      values
-    )
-    return(fail(msg, info = info, trace_env = caller_env()))
-  }
-  pass(act$val)
+
+  msg <- sprintf(
+    if (negate) "%s does match %s.\n%s" else "%s does not match %s.\n%s",
+    escape(act$lab),
+    encodeString(regexp, quote = '"'),
+    values
+  )
+  return(fail(msg, info = info, trace_env = trace_env))
 }

R/quasi-label.R

@@ -42,9 +42,16 @@ quasi_label <- function(quo, label = NULL, arg = "quo") {
 
   expr <- quo_get_expr(quo)
 
+  new_actual(
+    eval_bare(expr, quo_get_env(quo)),
+    label %||% expr_label(expr)
+  )
+}
+
+new_actual <- function(value, label) {
   list(
-    val = eval_bare(expr, quo_get_env(quo)),
-    lab = label %||% expr_label(expr)
+    val = value,
+    lab = label
   )
 }
 

R/snapshot-file.R

@@ -191,7 +191,7 @@ snapshot_file_equal <- function(
   path,
   file_equal = compare_file_binary,
   fail_on_new = FALSE,
-  trace_env = NULL
+  trace_env = caller_env()
 ) {
   if (!file.exists(path)) {
     abort(paste0("`", path, "` not found"))

R/snapshot-reporter.R

@@ -48,7 +48,7 @@ SnapshotReporter <- R6::R6Class(
       ...,
       tolerance = testthat_tolerance(),
       variant = NULL,
-      trace_env = NULL
+      trace_env = caller_env()
     ) {
       check_string(self$test, allow_empty = FALSE)
       i <- self$new_snaps$append(self$test, variant, save(value))
@@ -102,7 +102,7 @@ SnapshotReporter <- R6::R6Class(
       path,
       file_equal,
       variant = NULL,
-      trace_env = NULL
+      trace_env = caller_env()
     ) {
       self$announce_file_snapshot(name)