Improved composition

`expect_named()` and `expect_output()` need to always return the input value, even if they use some subexpectation.

To make this work, expectation components now only ever fail (never pass) and return TRUE or FALSE.

Fixes `expect_named()` and `expect_output()` now return different outputs

Fixes #2246

Author: hadley

R/expect-equality.R

@@ -68,7 +68,11 @@ expect_equal <- function(
   check_number_decimal(tolerance, min = 0, allow_null = TRUE)
 
   if (edition_get() >= 3) {
-    expect_waldo_equal_("equal", act, exp, info, ..., tolerance = tolerance)
+    if (
+      !expect_waldo_equal_("equal", act, exp, info, ..., tolerance = tolerance)
+    ) {
+      return()
+    }
   } else {
     if (!is.null(tolerance)) {
       comp <- compare(act$val, exp$val, ..., tolerance = tolerance)
@@ -84,8 +88,8 @@ expect_equal <- function(
       )
       return(fail(msg, info = info))
     }
-    pass(act$val)
   }
+  pass(act$val)
 }
 
 
@@ -103,30 +107,29 @@ expect_identical <- function(
   exp <- quasi_label(enquo(expected), expected.label)
 
   if (edition_get() >= 3) {
-    expect_waldo_equal_("identical", act, exp, info, ...)
+    if (!expect_waldo_equal_("identical", act, exp, info, ...)) {
+      return()
+    }
   } else {
     ident <- identical(act$val, exp$val, ...)
-    if (ident) {
-      msg_act <- NULL
-    } else {
+    if (!ident) {
       compare <- compare(act$val, exp$val)
       if (compare$equal) {
         msg_act <- "Objects equal but not identical"
       } else {
         msg_act <- compare$message
       }
-    }
 
-    if (!ident) {
       msg <- c(
         sprintf("Expected %s to be identical to %s.", act$lab, exp$lab),
         "Differences:",
         msg_act
       )
       return(fail(msg, info = info))
     }
-    pass(act$val)
   }
+
+  pass(act$val)
 }
 
 expect_waldo_equal_ <- function(
@@ -144,15 +147,16 @@ expect_waldo_equal_ <- function(
     x_arg = "actual",
     y_arg = "expected"
   )
-  if (length(comp) != 0) {
-    msg <- c(
-      sprintf("Expected %s to be %s to %s.", act$lab, type, exp$lab),
-      "Differences:",
-      paste0(comp, collpase = "\n")
-    )
-    return(fail(msg, info = info, trace_env = trace_env))
+  if (length(comp) == 0) {
+    return(TRUE)
   }
-  pass(act$val)
+
+  msg <- c(
+    sprintf("Expected %s to be %s to %s.", act$lab, type, exp$lab),
+    "Differences:",
+    paste0(comp, collpase = "\n")
+  )
+  fail(msg, info = info, trace_env = trace_env)
 }
 
 #' Is an object equal to the expected value, ignoring attributes?

R/expect-match.R

@@ -50,17 +50,23 @@ expect_match <- function(
     return(fail(msg, info = info))
   }
 
-  expect_match_(
-    act = act,
-    regexp = regexp,
-    perl = perl,
-    fixed = fixed,
-    ...,
-    all = all,
-    info = info,
-    label = label,
-    negate = FALSE
-  )
+  if (
+    !expect_match_(
+      act = act,
+      regexp = regexp,
+      perl = perl,
+      fixed = fixed,
+      ...,
+      all = all,
+      info = info,
+      label = label,
+      negate = FALSE
+    )
+  ) {
+    return()
+  }
+
+  pass(act$val)
 }
 
 #' @describeIn expect_match Check that a string doesn't match a regular
@@ -84,17 +90,22 @@ expect_no_match <- function(
   check_bool(fixed)
   check_bool(all)
 
-  expect_match_(
-    act = act,
-    regexp = regexp,
-    perl = perl,
-    fixed = fixed,
-    ...,
-    all = all,
-    info = info,
-    label = label,
-    negate = TRUE
-  )
+  if (
+    !expect_match_(
+      act = act,
+      regexp = regexp,
+      perl = perl,
+      fixed = fixed,
+      ...,
+      all = all,
+      info = info,
+      label = label,
+      negate = TRUE
+    )
+  ) {
+    return()
+  }
+  pass(act$val)
 }
 
 expect_match_ <- function(
@@ -115,7 +126,7 @@ expect_match_ <- function(
   ok <- if (all) all(condition) else any(condition)
 
   if (ok) {
-    return(pass(act$val))
+    return(TRUE)
   }
 
   values <- show_text(act$val, condition)
@@ -135,7 +146,7 @@ expect_match_ <- function(
     encodeString(regexp, quote = '"')
   )
   msg_act <- c(paste0("Actual ", title, ':'), values)
-  return(fail(c(msg_exp, msg_act), info = info, trace_env = trace_env))
+  fail(c(msg_exp, msg_act), info = info, trace_env = trace_env)
 }
 
 

R/expect-named.R

@@ -47,11 +47,15 @@ expect_named <- function(
   act_names <- normalise_names(names(act$val), ignore.order, ignore.case)
 
   if (ignore.order) {
-    act <- labelled_value(act_names, paste0("names(", act$lab, ")"))
-    return(expect_setequal_(act, exp))
+    act_names <- labelled_value(act_names, paste0("names(", act$lab, ")"))
+    if (!expect_setequal_(act_names, exp)) {
+      return()
+    }
   } else {
-    act <- labelled_value(act_names, paste0("names(", act$lab, ")"))
-    return(expect_waldo_equal_("equal", act, exp))
+    act_name <- labelled_value(act_names, paste0("names(", act$lab, ")"))
+    if (!expect_waldo_equal_("equal", act_name, exp)) {
+      return()
+    }
   }
 
   pass(act$val)

R/expect-output.R

@@ -42,15 +42,16 @@ expect_output <- function(
       )
       return(fail(msg, info = info))
     }
-    pass(act$val)
   } else if (is.null(regexp) || identical(act$cap, "")) {
     if (identical(act$cap, "")) {
       msg <- sprintf("Expected %s to produce output.", act$lab)
       return(fail(msg, info = info))
     }
-    pass(act$val)
   } else {
-    act <- labelled_value(act$cap, act$lab)
-    expect_match_(act, enc2native(regexp), ..., title = "output")
+    act_out <- labelled_value(act$cap, paste0("output from ", act$lab))
+    if (!expect_match_(act_out, enc2native(regexp), ..., title = "output")) {
+      return()
+    }
   }
+  pass(act$val)
 }

R/expect-self-test.R

@@ -88,7 +88,9 @@ expect_failure <- function(expr, message = NULL, ...) {
 
   if (!is.null(message)) {
     act <- labelled_value(status$last_failure$message, "failure message")
-    return(expect_match_(act, message, ..., title = "message"))
+    if (!expect_match_(act, message, ..., title = "message")) {
+      return()
+    }
   }
   pass(NULL)
 }

R/expect-setequal.R

@@ -34,7 +34,11 @@ expect_setequal <- function(object, expected) {
     testthat_warn("expect_setequal() ignores names")
   }
 
-  expect_setequal_(act, exp)
+  if (!expect_setequal_(act, exp)) {
+    return()
+  }
+
+  pass(act$val)
 }
 
 expect_setequal_ <- function(
@@ -45,22 +49,23 @@ expect_setequal_ <- function(
   act_miss <- unique(act$val[!act$val %in% exp$val])
   exp_miss <- unique(exp$val[!exp$val %in% act$val])
 
-  if (length(exp_miss) || length(act_miss)) {
-    msg_exp <- sprintf(
-      "Expected %s to have the same values as %s.",
-      act$lab,
-      exp$lab
-    )
-    msg_act <- c(
-      sprintf("Actual: %s", values(act$val)),
-      sprintf("Expected: %s", values(exp$val)),
-      if (length(act_miss)) sprintf("Needs: %s", values(act_miss)),
-      if (length(exp_miss)) sprintf("Absent: %s", values(exp_miss))
-    )
-
-    return(fail(c(msg_exp, msg_act), trace_env = trace_env))
+  if (length(exp_miss) == 0 && length(act_miss) == 0) {
+    return(TRUE)
   }
-  pass(act$val)
+
+  msg_exp <- sprintf(
+    "Expected %s to have the same values as %s.",
+    act$lab,
+    exp$lab
+  )
+  msg_act <- c(
+    sprintf("Actual: %s", values(act$val)),
+    sprintf("Expected: %s", values(exp$val)),
+    if (length(act_miss)) sprintf("Needs: %s", values(act_miss)),
+    if (length(exp_miss)) sprintf("Absent: %s", values(exp_miss))
+  )
+
+  fail(c(msg_exp, msg_act), trace_env = trace_env)
 }
 
 values <- function(x) {
@@ -87,7 +92,11 @@ expect_mapequal <- function(object, expected) {
   act <- quasi_label(enquo(object))
   exp <- quasi_label(enquo(expected))
 
-  expect_waldo_equal_("equal", act, exp, list_as_map = TRUE)
+  if (!expect_waldo_equal_("equal", act, exp, list_as_map = TRUE)) {
+    return()
+  }
+
+  pass(act$val)
 }
 
 #' @export

R/expect-that.R

@@ -21,7 +21,8 @@
 #' @param trace An optional backtrace created by [rlang::trace_back()].
 #'   When supplied, the expectation is displayed with the backtrace.
 #'   Expert use only.
-#' @export
+#' @return `pass()` returns `value` invisibly; `fail()` returns `FALSE`
+#'   invisibly.
 #' @examples
 #' expect_length <- function(object, n) {
 #'   act <- quasi_label(rlang::enquo(object), arg = "object")
@@ -44,6 +45,7 @@ fail <- function(
   trace <- trace %||% capture_trace(trace_env)
   message <- paste(c(message, info), collapse = "\n")
   expectation("failure", message, srcref = srcref, trace = trace)
+  invisible(FALSE)
 }
 
 snapshot_fail <- function(message, trace_env = caller_env()) {

tests/testthat/_snaps/expect-output.md

@@ -22,7 +22,7 @@
       expect_output(g(), "x")
     Condition
       Error:
-      ! Expected `g()` to match regexp "x".
+      ! Expected output from `g()` to match regexp "x".
       Actual output:
       x | !
 

tests/testthat/test-expect-named.R

@@ -12,6 +12,13 @@ test_that("expected_named verifies actual of names", {
   expect_snapshot_failure(expect_named(x, "b"))
 })
 
+test_that("always returns inputs", {
+  x <- c(a = 1)
+  expect_equal(expect_named(x), x)
+  expect_equal(expect_named(x, "a"), x)
+  expect_equal(expect_named(x, "a", ignore.order = TRUE), x)
+})
+
 test_that("expected_named optionally ignores order and case", {
   x <- c(a = 1, b = 2)
   expect_success(expect_named(x, c("A", "B"), ignore.case = TRUE))

tests/testthat/test-expect-output.R

@@ -33,8 +33,18 @@ test_that("... passed on to grepl", {
   expect_success(expect_output(print("X"), "x", ignore.case = TRUE))
 })
 
-test_that("returns first argument", {
-  expect_equal(expect_output(1, NA), 1)
+test_that("always returns first argument", {
+  f1 <- function() {
+    1
+  }
+  f2 <- function() {
+    cat("x")
+    1
+  }
+
+  expect_equal(expect_output(f1(), NA), 1)
+  expect_equal(expect_output(f2()), 1)
+  expect_equal(expect_output(f2(), "x"), 1)
 })
 
 test_that("uses unicode characters in output where available", {