From a3189a8e80d625ebde86670da15df00bbe9508e6 Mon Sep 17 00:00:00 2001 From: Hadley Wickham Date: Fri, 3 Oct 2025 14:30:56 -0500 Subject: [PATCH 01/22] 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 --- R/expect-equality.R | 38 +++++++++-------- R/expect-match.R | 59 +++++++++++++++----------- R/expect-named.R | 12 ++++-- R/expect-output.R | 9 ++-- R/expect-self-test.R | 4 +- R/expect-setequal.R | 43 +++++++++++-------- R/expect-that.R | 4 +- tests/testthat/_snaps/expect-output.md | 2 +- tests/testthat/test-expect-named.R | 7 +++ tests/testthat/test-expect-output.R | 14 +++++- 10 files changed, 121 insertions(+), 71 deletions(-) diff --git a/R/expect-equality.R b/R/expect-equality.R index c01665603..718c47c91 100644 --- a/R/expect-equality.R +++ b/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,21 +107,19 @@ 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:", @@ -125,8 +127,9 @@ expect_identical <- function( ) 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? diff --git a/R/expect-match.R b/R/expect-match.R index 1fc952b47..97eb38e0b 100644 --- a/R/expect-match.R +++ b/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) } diff --git a/R/expect-named.R b/R/expect-named.R index 4a71ca121..759b9f784 100644 --- a/R/expect-named.R +++ b/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) diff --git a/R/expect-output.R b/R/expect-output.R index fea13a7a4..d9f3692e4 100644 --- a/R/expect-output.R +++ b/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) } diff --git a/R/expect-self-test.R b/R/expect-self-test.R index a0a565b80..6e5a385d6 100644 --- a/R/expect-self-test.R +++ b/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) } diff --git a/R/expect-setequal.R b/R/expect-setequal.R index f9a53839f..01051cd72 100644 --- a/R/expect-setequal.R +++ b/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 diff --git a/R/expect-that.R b/R/expect-that.R index 730f3b2fb..5ad8b8c12 100644 --- a/R/expect-that.R +++ b/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()) { diff --git a/tests/testthat/_snaps/expect-output.md b/tests/testthat/_snaps/expect-output.md index 4a9d73b64..2d4c77b74 100644 --- a/tests/testthat/_snaps/expect-output.md +++ b/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 | ! diff --git a/tests/testthat/test-expect-named.R b/tests/testthat/test-expect-named.R index 21dfe4aed..31f6d9354 100644 --- a/tests/testthat/test-expect-named.R +++ b/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)) diff --git a/tests/testthat/test-expect-output.R b/tests/testthat/test-expect-output.R index c98144463..52e2adbd2 100644 --- a/tests/testthat/test-expect-output.R +++ b/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", { From c219d631e2cf3b7b07c73dc5444821ccde0da23f Mon Sep 17 00:00:00 2001 From: Hadley Wickham Date: Fri, 3 Oct 2025 16:56:38 -0500 Subject: [PATCH 02/22] Always return `act$val` --- R/expect-equality.R | 40 +++++++++---------- R/expect-match.R | 95 ++++++++++++++++++++------------------------ R/expect-named.R | 10 ++--- R/expect-output.R | 15 ++++--- R/expect-self-test.R | 22 +++++----- R/expect-setequal.R | 41 ++++++++----------- R/expect-that.R | 2 +- 7 files changed, 103 insertions(+), 122 deletions(-) diff --git a/R/expect-equality.R b/R/expect-equality.R index 718c47c91..f60859b64 100644 --- a/R/expect-equality.R +++ b/R/expect-equality.R @@ -68,11 +68,7 @@ expect_equal <- function( check_number_decimal(tolerance, min = 0, allow_null = TRUE) if (edition_get() >= 3) { - if ( - !expect_waldo_equal_("equal", act, exp, info, ..., tolerance = tolerance) - ) { - return() - } + expect_waldo_equal_("equal", act, exp, info, ..., tolerance = tolerance) } else { if (!is.null(tolerance)) { comp <- compare(act$val, exp$val, ..., tolerance = tolerance) @@ -80,16 +76,18 @@ expect_equal <- function( comp <- compare(act$val, exp$val, ...) } - if (!comp$equal) { + if (comp$equal) { + pass() + } else { msg <- c( sprintf("Expected %s to equal %s.", act$lab, exp$lab), "Differences:", comp$message ) - return(fail(msg, info = info)) + fail(msg, info = info) } } - pass(act$val) + invisible(act$val) } @@ -107,12 +105,12 @@ expect_identical <- function( exp <- quasi_label(enquo(expected), expected.label) if (edition_get() >= 3) { - if (!expect_waldo_equal_("identical", act, exp, info, ...)) { - return() - } + expect_waldo_equal_("identical", act, exp, info, ...) } else { ident <- identical(act$val, exp$val, ...) - if (!ident) { + if (ident) { + pass() + } else { compare <- compare(act$val, exp$val) if (compare$equal) { msg_act <- "Objects equal but not identical" @@ -129,7 +127,7 @@ expect_identical <- function( } } - pass(act$val) + invisible(act$val) } expect_waldo_equal_ <- function( @@ -148,15 +146,17 @@ expect_waldo_equal_ <- function( y_arg = "expected" ) if (length(comp) == 0) { - return(TRUE) + pass() + } else { + 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) } - 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) + invisible(act$val) } #' Is an object equal to the expected value, ignoring attributes? diff --git a/R/expect-match.R b/R/expect-match.R index 97eb38e0b..12d2af23f 100644 --- a/R/expect-match.R +++ b/R/expect-match.R @@ -50,23 +50,17 @@ expect_match <- function( return(fail(msg, info = info)) } - if ( - !expect_match_( - act = act, - regexp = regexp, - perl = perl, - fixed = fixed, - ..., - all = all, - info = info, - label = label, - negate = FALSE - ) - ) { - return() - } - - pass(act$val) + expect_match_( + act = act, + regexp = regexp, + perl = perl, + fixed = fixed, + ..., + all = all, + info = info, + label = label, + negate = FALSE + ) } #' @describeIn expect_match Check that a string doesn't match a regular @@ -90,22 +84,17 @@ expect_no_match <- function( check_bool(fixed) check_bool(all) - 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_( + act = act, + regexp = regexp, + perl = perl, + fixed = fixed, + ..., + all = all, + info = info, + label = label, + negate = TRUE + ) } expect_match_ <- function( @@ -126,27 +115,29 @@ expect_match_ <- function( ok <- if (all) all(condition) else any(condition) if (ok) { - return(TRUE) - } - - values <- show_text(act$val, condition) - if (length(act$val) == 1) { - which <- "" + pass() } else { - which <- if (all) "every element of " else "some element of " + values <- show_text(act$val, condition) + if (length(act$val) == 1) { + which <- "" + } else { + which <- if (all) "every element of " else "some element of " + } + match <- if (negate) "not to match" else "to match" + + msg_exp <- sprintf( + "Expected %s%s %s %s %s.", + which, + act$lab, + match, + if (fixed) "string" else "regexp", + encodeString(regexp, quote = '"') + ) + msg_act <- c(paste0("Actual ", title, ':'), values) + fail(c(msg_exp, msg_act), info = info, trace_env = trace_env) } - match <- if (negate) "not to match" else "to match" - - msg_exp <- sprintf( - "Expected %s%s %s %s %s.", - which, - act$lab, - match, - if (fixed) "string" else "regexp", - encodeString(regexp, quote = '"') - ) - msg_act <- c(paste0("Actual ", title, ':'), values) - fail(c(msg_exp, msg_act), info = info, trace_env = trace_env) + + invisible(act$val) } diff --git a/R/expect-named.R b/R/expect-named.R index 759b9f784..652713cb7 100644 --- a/R/expect-named.R +++ b/R/expect-named.R @@ -48,17 +48,13 @@ expect_named <- function( if (ignore.order) { act_names <- labelled_value(act_names, paste0("names(", act$lab, ")")) - if (!expect_setequal_(act_names, exp)) { - return() - } + expect_setequal_(act_names, exp) } else { act_name <- labelled_value(act_names, paste0("names(", act$lab, ")")) - if (!expect_waldo_equal_("equal", act_name, exp)) { - return() - } + expect_waldo_equal_("equal", act_name, exp) } - pass(act$val) + invisible(act$val) } normalise_names <- function(x, ignore.order = FALSE, ignore.case = FALSE) { diff --git a/R/expect-output.R b/R/expect-output.R index d9f3692e4..8f58acb64 100644 --- a/R/expect-output.R +++ b/R/expect-output.R @@ -40,18 +40,21 @@ expect_output <- function( sprintf("Expected %s to produce no output.", act$lab), sprintf("Actual output:\n%s", encodeString(act$cap)) ) - return(fail(msg, info = info)) + fail(msg, info = info) + } else { + pass() } } 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)) + fail(msg, info = info) + } else { + pass() } } else { act_out <- labelled_value(act$cap, paste0("output from ", act$lab)) - if (!expect_match_(act_out, enc2native(regexp), ..., title = "output")) { - return() - } + expect_match_(act_out, enc2native(regexp), ..., title = "output") } - pass(act$val) + + invisible(act$val) } diff --git a/R/expect-self-test.R b/R/expect-self-test.R index 6e5a385d6..1ae3e2595 100644 --- a/R/expect-self-test.R +++ b/R/expect-self-test.R @@ -75,24 +75,22 @@ expect_failure <- function(expr, message = NULL, ...) { "Expected one failure.", sprintf("Actually failed %i times", status$n_failure) ) - return(fail(msg)) - } - - if (status$n_success != 0) { + fail(msg) + } else if (status$n_success != 0) { msg <- c( "Expected zero successes.", sprintf("Actually succeeded %i times", status$n_success) ) - return(fail(msg)) - } - - if (!is.null(message)) { - act <- labelled_value(status$last_failure$message, "failure message") - if (!expect_match_(act, message, ..., title = "message")) { - return() + fail(msg) + } else { + if (is.null(message)) { + pass() + } else { + act <- labelled_value(status$last_failure$message, "failure message") + expect_match_(act, message, ..., title = "message") } } - pass(NULL) + invisible() } #' @export diff --git a/R/expect-setequal.R b/R/expect-setequal.R index 01051cd72..bfd8f7bb9 100644 --- a/R/expect-setequal.R +++ b/R/expect-setequal.R @@ -34,11 +34,7 @@ expect_setequal <- function(object, expected) { testthat_warn("expect_setequal() ignores names") } - if (!expect_setequal_(act, exp)) { - return() - } - - pass(act$val) + expect_setequal_(act, exp) } expect_setequal_ <- function( @@ -50,22 +46,23 @@ expect_setequal_ <- function( exp_miss <- unique(exp$val[!exp$val %in% act$val]) if (length(exp_miss) == 0 && length(act_miss) == 0) { - return(TRUE) + pass() + } else { + 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) } - 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) + invisible(act$value) } values <- function(x) { @@ -92,11 +89,7 @@ expect_mapequal <- function(object, expected) { act <- quasi_label(enquo(object)) exp <- quasi_label(enquo(expected)) - if (!expect_waldo_equal_("equal", act, exp, list_as_map = TRUE)) { - return() - } - - pass(act$val) + expect_waldo_equal_("equal", act, exp, list_as_map = TRUE) } #' @export diff --git a/R/expect-that.R b/R/expect-that.R index 5ad8b8c12..6dcda8eda 100644 --- a/R/expect-that.R +++ b/R/expect-that.R @@ -67,7 +67,7 @@ capture_trace <- function(trace_env) { #' @param value Value to return, typically the result of evaluating the #' `object` argument to the expectation. #' @export -pass <- function(value) { +pass <- function(value = NULL) { expectation("success", "success") invisible(value) } From 7bb8bffe3e7e060da1300665cf25b94be6db0f73 Mon Sep 17 00:00:00 2001 From: Hadley Wickham Date: Fri, 3 Oct 2025 17:13:20 -0500 Subject: [PATCH 03/22] Polishing/fixes --- R/expect-match.R | 37 ++++++++-------- R/expect-that.R | 4 +- man/fail.Rd | 2 +- vignettes/custom-expectation.Rmd | 75 +++++++++++++++++--------------- 4 files changed, 61 insertions(+), 57 deletions(-) diff --git a/R/expect-match.R b/R/expect-match.R index 12d2af23f..8b9f8af00 100644 --- a/R/expect-match.R +++ b/R/expect-match.R @@ -116,26 +116,27 @@ expect_match_ <- function( if (ok) { pass() + invisible(act$val) + } + + values <- show_text(act$val, condition) + if (length(act$val) == 1) { + which <- "" } else { - values <- show_text(act$val, condition) - if (length(act$val) == 1) { - which <- "" - } else { - which <- if (all) "every element of " else "some element of " - } - match <- if (negate) "not to match" else "to match" - - msg_exp <- sprintf( - "Expected %s%s %s %s %s.", - which, - act$lab, - match, - if (fixed) "string" else "regexp", - encodeString(regexp, quote = '"') - ) - msg_act <- c(paste0("Actual ", title, ':'), values) - fail(c(msg_exp, msg_act), info = info, trace_env = trace_env) + which <- if (all) "every element of " else "some element of " } + match <- if (negate) "not to match" else "to match" + + msg_exp <- sprintf( + "Expected %s%s %s %s %s.", + which, + act$lab, + match, + if (fixed) "string" else "regexp", + encodeString(regexp, quote = '"') + ) + msg_act <- c(paste0("Actual ", title, ':'), values) + fail(c(msg_exp, msg_act), info = info, trace_env = trace_env) invisible(act$val) } diff --git a/R/expect-that.R b/R/expect-that.R index 6dcda8eda..96aa0ad16 100644 --- a/R/expect-that.R +++ b/R/expect-that.R @@ -21,8 +21,7 @@ #' @param trace An optional backtrace created by [rlang::trace_back()]. #' When supplied, the expectation is displayed with the backtrace. #' Expert use only. -#' @return `pass()` returns `value` invisibly; `fail()` returns `FALSE` -#' invisibly. +#' @export #' @examples #' expect_length <- function(object, n) { #' act <- quasi_label(rlang::enquo(object), arg = "object") @@ -45,7 +44,6 @@ 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()) { diff --git a/man/fail.Rd b/man/fail.Rd index 09d9d4350..7626b138e 100644 --- a/man/fail.Rd +++ b/man/fail.Rd @@ -13,7 +13,7 @@ fail( trace = NULL ) -pass(value) +pass(value = NULL) } \arguments{ \item{message}{Failure message to send to the user. It's best practice to diff --git a/vignettes/custom-expectation.Rmd b/vignettes/custom-expectation.Rmd index c13711477..ee5fd3b04 100644 --- a/vignettes/custom-expectation.Rmd +++ b/vignettes/custom-expectation.Rmd @@ -48,9 +48,11 @@ If we use it in a test you can see there's an issue: test_that("success", { expect_nrow(mtcars, 32) }) + test_that("failure 1", { expect_nrow(mtcars, 30) }) + test_that("failure 2", { expect_nrow(matrix(1:5), 2) }) @@ -64,35 +66,38 @@ These are both minor issues, so if they don't bother you, you can save yourself ## Expectation basics -An expectation has three main parts, as illustrated by `expect_length()`: +An expectation has four main parts, as illustrated by `expect_length()`: ```{r} expect_length <- function(object, n) { # 1. Capture object and label act <- quasi_label(rlang::enquo(object)) - - # 2. Check if expectations are violated + act_n <- length(act$val) if (act_n != n) { msg <- c( sprintf("Expected %s to have length %i.", act$lab, n), sprintf("Actual length: %i.", act_n) ) - return(fail(msg)) + # 2. Fail if expectations are violated + fail(msg) + } else { + # 3. Pass if expectations are met + pass() } - # 3. Pass when expectations are met - pass(act$val) + # 4. Invisibly return the input value + invisible(act$val) } ``` The first step in any expectation is to use `quasi_label()` to capture a "labeled value", i.e., a list that contains both the value (`$val`) for testing and a label (`$lab`) used to make failure messages as informative as possible. This is a pattern that exists for fairly esoteric reasons; you don't need to understand it, just copy and paste it. -Next you need to check each way that `object` could violate the expectation. In this case, there's only one check, but in more complicated cases there can be multiple checks. In most cases, it's easier to check for violations one by one, using early returns to `fail()`. This makes it easier to write informative failure messages that first describe what was expected and then what was actually seen. +Next you need to check each way that `object` could violate the expectation. In this case, there's only one check, but in more complicated cases there can be multiple checks. In most cases, it's easier to check for violations one by one, using an nested if-else statement. That makes it easier to write informative failure messages that first describe what was expected and then what was actually seen. -Note that you need to use `return(fail())` here. If you don't, your expectation might end up failing multiple times or both failing and succeeding. You won't see these problems when interactively testing your expectation, but forgetting to `return()` can lead to incorrect fail and pass counts in typical usage. In the next section, you'll learn how to test your expectation to avoid this issue. +If the object is as expected, call `pass()`. This ensures that a success will be registered in the test reporter. -Finally, if the object is as expected, call `pass()` with `act$val`. This is good practice because expectation functions are called primarily for their side-effects (triggering a failure), and returning the value allows expectations to be piped together: +Finally, return the input value (`act$val`) invisibly. This is good practice because expectations are called primarily for their side-effects (triggering a failure), and returning the value allows expectations to be piped together: ```{r} #| label: piping @@ -153,7 +158,8 @@ expect_vector_length <- function(object, n) { sprintf("Expected %s to be a vector", act$lab), sprintf("Actual type: %s", typeof(act$val)) ) - return(fail(msg)) + fail(msg) + return(invisible(act$val)) } act_n <- length(act$val) @@ -162,10 +168,11 @@ expect_vector_length <- function(object, n) { sprintf("Expected %s to have length %i.", act$lab, n), sprintf("Actual length: %i.", act_n) ) - return(fail(msg)) + fail(msg) + } else { + pass() } - - pass(act$val) + invisible(act$val) } ``` @@ -189,26 +196,24 @@ expect_s3_class <- function(object, class) { if (!is.object(act$val)) { msg <- sprintf("Expected %s to be an object.", act$lab) - return(fail(msg)) - } - - if (isS4(act$val)) { + fail(msg) + } else if (isS4(act$val)) { msg <- c( sprintf("Expected %s to be an S3 object.", act$lab), "Actual OO type: S4" ) - return(fail(msg)) - } - - if (!inherits(act$val, class)) { + fail(msg) + } else if (!inherits(act$val, class)) { msg <- c( sprintf("Expected %s to inherit from %s.", act$lab, class), sprintf("Actual class: %s", class(act$val)) ) - return(fail(msg)) + fail(msg) + } else { + pass() } - pass(act$val) + invisible(act$val) } ``` @@ -254,26 +259,24 @@ expect_s3_object <- function(object, class = NULL) { if (!is.object(act$val)) { msg <- sprintf("Expected %s to be an object.", act$lab) - return(fail(msg)) - } - - if (isS4(act$val)) { + fail(msg) + } else if (isS4(act$val)) { msg <- c( sprintf("Expected %s to be an S3 object.", act$lab), "Actual OO type: S4" ) - return(fail(msg)) - } - - if (!is.null(class) && !inherits(act$val, class)) { + fail(msg) + } else if (!is.null(class) && !inherits(act$val, class)) { msg <- c( sprintf("Expected %s to inherit from %s.", act$lab, class), sprintf("Actual class: %s", class(act$val)) ) - return(fail(msg)) + fail(msg) + } else { + pass() } - pass(act$val) + invisible(act$val) } ``` @@ -288,10 +291,12 @@ expect_length_ <- function(act, n, trace_env = caller_env()) { act_n <- length(act$val) if (act_n != n) { msg <- sprintf("%s has length %i, not length %i.", act$lab, act_n, n) - return(fail(msg, trace_env = trace_env)) + fail(msg, trace_env = trace_env) + } else { + pass() } - pass(act$val) + invisible(act$val) } expect_length <- function(object, n) { From c4a6e27648f53102d9cb4ed606f1a10ed3b72da3 Mon Sep 17 00:00:00 2001 From: Hadley Wickham Date: Fri, 3 Oct 2025 17:20:33 -0500 Subject: [PATCH 04/22] Fix mistake --- R/expect-match.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/R/expect-match.R b/R/expect-match.R index 8b9f8af00..88354a83b 100644 --- a/R/expect-match.R +++ b/R/expect-match.R @@ -116,7 +116,7 @@ expect_match_ <- function( if (ok) { pass() - invisible(act$val) + return(invisible(act$val)) } values <- show_text(act$val, condition) From c7e1f2d6ec4be044b68ecacacb7ea4485dbba821 Mon Sep 17 00:00:00 2001 From: Hadley Wickham Date: Sun, 5 Oct 2025 17:43:22 -0500 Subject: [PATCH 05/22] Update a few more --- R/expect-comparison.R | 55 +++++++++++++------------- R/expect-condition.R | 32 +++++++++------ R/expect-constant.R | 6 ++- R/expect-equality.R | 16 ++++---- R/expect-inheritance.R | 88 ++++++++++++++++++++++-------------------- 5 files changed, 108 insertions(+), 89 deletions(-) diff --git a/R/expect-comparison.R b/R/expect-comparison.R index 27b0915a5..3556f9c6c 100644 --- a/R/expect-comparison.R +++ b/R/expect-comparison.R @@ -37,35 +37,38 @@ expect_compare_ <- function( call = trace_env ) } - if (!isTRUE(cmp)) { - diff <- act$val - exp$val - msg_exp <- sprintf("Expected %s %s %s.", act$lab, operator, exp$lab) - - digits <- max( - digits(act$val), - digits(exp$val), - min_digits(act$val, exp$val) - ) + if (isTRUE(cmp)) { + pass() + return(invisible(act$val)) + } - msg_act <- sprintf( - "Actual comparison: %s %s %s", - num_exact(act$val, digits), - actual_op, - num_exact(exp$val, digits) - ) + diff <- act$val - exp$val + msg_exp <- sprintf("Expected %s %s %s.", act$lab, operator, exp$lab) + + digits <- max( + digits(act$val), + digits(exp$val), + min_digits(act$val, exp$val) + ) - if (is.na(diff)) { - msg_diff <- NULL - } else { - msg_diff <- sprintf( - "Difference: %s %s 0", - num_exact(diff, digits), - actual_op - ) - } - return(fail(c(msg_exp, msg_act, msg_diff), trace_env = trace_env)) + msg_act <- sprintf( + "Actual comparison: %s %s %s", + num_exact(act$val, digits), + actual_op, + num_exact(exp$val, digits) + ) + + if (is.na(diff)) { + msg_diff <- NULL + } else { + msg_diff <- sprintf( + "Difference: %s %s 0", + num_exact(diff, digits), + actual_op + ) } - pass(act$val) + fail(c(msg_exp, msg_act, msg_diff), trace_env = trace_env) + invisible(act$val) } #' @export #' @rdname comparison-expectations diff --git a/R/expect-condition.R b/R/expect-condition.R index c7414fead..b92e09619 100644 --- a/R/expect-condition.R +++ b/R/expect-condition.R @@ -143,9 +143,11 @@ expect_error <- 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"]])) + fail(msg, info = info, trace = act$cap[["trace"]]) + } else { + pass() } - pass(act$val %||% act$cap) + invisible(act$val %||% act$cap) } } @@ -198,9 +200,11 @@ expect_warning <- function( cond_type = "warnings" ) if (!is.null(msg)) { - return(fail(msg, info = info)) + fail(msg, info = info) + } else { + pass() } - pass(act$val) + invisible(act$val) } } @@ -236,9 +240,11 @@ expect_message <- function( act <- quasi_capture(enquo(object), label, capture_messages) msg <- compare_messages(act$cap, act$lab, regexp = regexp, all = all, ...) if (!is.null(msg)) { - return(fail(msg, info = info)) + fail(msg, info = info) + } else { + pass() } - pass(act$val) + invisible(act$val) } } @@ -285,9 +291,11 @@ expect_condition <- function( cond_type = "condition" ) if (!is.null(msg)) { - return(fail(msg, info = info, trace = act$cap[["trace"]])) + fail(msg, info = info, trace = act$cap[["trace"]]) + } else { + pass() } - pass(act$val %||% act$cap) + invisible(act$val %||% act$cap) } } @@ -327,16 +335,18 @@ 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( + fail( msg, info = info, trace = act$cap[["trace"]], trace_env = trace_env - )) + ) + } else { + pass() } # If a condition was expected, return it. Otherwise return the value # of the expression. - pass(if (expected) act$cap else act$val) + invisible(if (expected) act$cap else act$val) } # ------------------------------------------------------------------------- diff --git a/R/expect-constant.R b/R/expect-constant.R index e6ca95d25..76f3ff078 100644 --- a/R/expect-constant.R +++ b/R/expect-constant.R @@ -82,7 +82,9 @@ expect_waldo_constant_ <- function( "Differences:", paste0(comp, collpase = "\n") ) - return(fail(msg, info = info, trace_env = trace_env)) + fail(msg, info = info, trace_env = trace_env) + } else { + pass() } - pass(act$val) + invisible(act$val) } diff --git a/R/expect-equality.R b/R/expect-equality.R index f60859b64..379339542 100644 --- a/R/expect-equality.R +++ b/R/expect-equality.R @@ -86,8 +86,8 @@ expect_equal <- function( ) fail(msg, info = info) } + invisible(act$val) } - invisible(act$val) } @@ -107,8 +107,7 @@ expect_identical <- function( if (edition_get() >= 3) { expect_waldo_equal_("identical", act, exp, info, ...) } else { - ident <- identical(act$val, exp$val, ...) - if (ident) { + if (identical(act$val, exp$val, ...)) { pass() } else { compare <- compare(act$val, exp$val) @@ -123,11 +122,10 @@ expect_identical <- function( "Differences:", msg_act ) - return(fail(msg, info = info)) + fail(msg, info = info) } + invisible(act$val) } - - invisible(act$val) } expect_waldo_equal_ <- function( @@ -207,7 +205,9 @@ expect_equivalent <- function( exp$lab, comp$message ) - return(fail(msg, info = info)) + fail(msg, info = info) + } else { + pass() } - pass(act$val) + invisible(act$val) } diff --git a/R/expect-inheritance.R b/R/expect-inheritance.R index 6b55f95c5..1594f5e86 100644 --- a/R/expect-inheritance.R +++ b/R/expect-inheritance.R @@ -94,7 +94,9 @@ expect_s3_class <- function(object, class, exact = FALSE) { if (identical(class, NA)) { if (isS3(object)) { msg <- sprintf("Expected %s not to be an S3 object.", act$lab) - return(fail(msg)) + fail(msg) + } else { + pass() } } else if (is.character(class)) { if (!isS3(act$val)) { @@ -102,29 +104,27 @@ expect_s3_class <- function(object, class, exact = FALSE) { sprintf("Expected %s to be an S3 object.", act$lab), sprintf("Actual OO type: %s.", oo_type(act$val)) ) - return(fail(msg)) - } else if (exact) { - if (!identical(class(act$val), class)) { - msg <- c( - sprintf("Expected %s to have class %s.", act$lab, exp_lab), - sprintf("Actual class: %s.", act$class) - ) - return(fail(msg)) - } + fail(msg) + } else if (exact && !identical(class(act$val), class)) { + msg <- c( + sprintf("Expected %s to have class %s.", act$lab, exp_lab), + sprintf("Actual class: %s.", act$class) + ) + fail(msg) + } else if (!inherits(act$val, class)) { + msg <- c( + sprintf("Expected %s to inherit from %s.", act$lab, exp_lab), + sprintf("Actual class: %s.", act$class) + ) + fail(msg) } else { - if (!inherits(act$val, class)) { - msg <- c( - sprintf("Expected %s to inherit from %s.", act$lab, exp_lab), - sprintf("Actual class: %s.", act$class) - ) - return(fail(msg)) - } + pass() } } else { stop_input_type(class, c("a character vector", "NA")) } - pass(act$val) + invisible(act$val) } #' @export @@ -137,7 +137,9 @@ expect_s4_class <- function(object, class) { if (identical(class, NA)) { if (isS4(object)) { msg <- sprintf("Expected %s not to be an S4 object.", act$lab) - return(fail(msg)) + fail(msg) + } else { + pass() } } else if (is.character(class)) { if (!isS4(act$val)) { @@ -145,21 +147,21 @@ expect_s4_class <- function(object, class) { sprintf("Expected %s to be an S4 object.", act$lab), sprintf("Actual OO type: %s.", oo_type(act$val)) ) - return(fail(msg)) + fail(msg) + } else if (!methods::is(act$val, class)) { + msg <- c( + sprintf("Expected %s to inherit from %s.", act$lab, exp_lab), + sprintf("Actual class: %s.", act$class) + ) + fail(msg) } else { - if (!methods::is(act$val, class)) { - msg <- c( - sprintf("Expected %s to inherit from %s.", act$lab, exp_lab), - sprintf("Actual class: %s.", act$class) - ) - return(fail(msg)) - } + pass() } } else { stop_input_type(class, c("a character vector", "NA")) } - pass(act$val) + invisible(act$val) } #' @export @@ -173,20 +175,20 @@ expect_r6_class <- function(object, class) { sprintf("Expected %s to be an R6 object.", act$lab), sprintf("Actual OO type: %s.", oo_type(act$val)) ) - return(fail(msg)) - } - - if (!inherits(act$val, class)) { + fail(msg) + } else if (!inherits(act$val, class)) { act_class <- format_class(class(act$val)) exp_class <- format_class(class) msg <- c( sprintf("Expected %s to inherit from %s.", act$lab, exp_class), sprintf("Actual class: %s.", act_class) ) - return(fail(msg)) + fail(msg) + } else { + pass() } - pass(act$val) + invisible(act$val) } #' @export @@ -204,10 +206,8 @@ expect_s7_class <- function(object, class) { sprintf("Expected %s to be an S7 object.", act$lab), sprintf("Actual OO type: %s.", oo_type(act$val)) ) - return(fail(msg)) - } - - if (!S7::S7_inherits(object, class)) { + fail(msg) + } else if (!S7::S7_inherits(object, class)) { exp_class <- attr(class, "name", TRUE) act_class <- setdiff(base::class(object), "S7_object") act_class_desc <- paste0("<", act_class, ">", collapse = "/") @@ -216,10 +216,12 @@ expect_s7_class <- function(object, class) { sprintf("Expected %s to inherit from <%s>.", act$lab, exp_class), sprintf("Actual class: %s.", act_class_desc) ) - return(fail(msg)) + fail(msg) + } else { + pass() } - pass(act$val) + invisible(act$val) } #' Do you expect to inherit from this class? @@ -260,9 +262,11 @@ expect_is <- function(object, class, info = NULL, label = NULL) { exp_lab, act$class ) - return(fail(msg, info = info)) + fail(msg, info = info) + } else { + pass() } - pass(act$val) + invisible(act$val) } # Helpers ---------------------------------------------------------------------- From 87377ac3bb8bf03c04c9c2030346b174096a5e90 Mon Sep 17 00:00:00 2001 From: Hadley Wickham Date: Mon, 6 Oct 2025 08:02:42 -0500 Subject: [PATCH 06/22] Push through more expectations --- R/expect-inheritance.R | 6 ++-- R/expect-invisible.R | 12 +++++--- R/expect-known.R | 34 ++++++++++++++------- R/expect-named.R | 8 +++-- R/expect-no-condition.R | 6 ++-- R/expect-reference.R | 6 ++-- R/expect-self-test.R | 24 ++++++++------- R/expect-setequal.R | 8 +++-- R/expect-shape.R | 28 +++++++++++------- R/expect-silent.R | 6 ++-- R/expect-that.R | 19 +++++++----- R/expect-vector.R | 8 ++++- R/old-school.R | 10 ++++--- R/snapshot-file.R | 5 ++-- R/snapshot.R | 6 ++-- R/test-compiled-code.R | 5 ++-- R/verify-output.R | 2 +- man/fail.Rd | 16 +++++----- tests/testthat/_snaps/expect-self-test.md | 2 +- tests/testthat/_snaps/expect-shape.md | 8 ++--- tests/testthat/reporters/tests.R | 2 +- tests/testthat/test-expect-self-test.R | 36 +++++++++++------------ tests/testthat/test-snapshot.R | 2 +- tests/testthat/test-test-that.R | 4 +-- 24 files changed, 161 insertions(+), 102 deletions(-) diff --git a/R/expect-inheritance.R b/R/expect-inheritance.R index 1594f5e86..c25197d1d 100644 --- a/R/expect-inheritance.R +++ b/R/expect-inheritance.R @@ -74,9 +74,11 @@ expect_type <- function(object, type) { sprintf("Expected %s to have type %s.", act$lab, format_class(type)), sprintf("Actual type: %s", format_class(act_type)) ) - return(fail(msg)) + fail(msg) + } else { + pass() } - pass(act$val) + invisible(act$val) } #' @export diff --git a/R/expect-invisible.R b/R/expect-invisible.R index 9ae1ec596..14709393f 100644 --- a/R/expect-invisible.R +++ b/R/expect-invisible.R @@ -29,9 +29,11 @@ expect_invisible <- function(call, label = NULL) { sprintf("Expected %s to return invisibly.", lab), "Actual visibility: visible." ) - return(fail(msg)) + fail(msg) + } else { + pass() } - pass(vis$value) + invisible(vis$value) } #' @export @@ -45,7 +47,9 @@ expect_visible <- function(call, label = NULL) { sprintf("Expected %s to return visibly.", lab), "Actual visibility: invisible." ) - return(fail(msg)) + fail(msg) + } else { + pass() } - pass(vis$value) + invisible(vis$value) } diff --git a/R/expect-known.R b/R/expect-known.R index 98f32c866..4239260b7 100644 --- a/R/expect-known.R +++ b/R/expect-known.R @@ -73,15 +73,22 @@ expect_known_output <- function( act$lab <- label %||% quo_label(act$quo) act <- append(act, eval_with_output(object, print = print, width = width)) - compare_file(file, act$out, update = update, info = info, ...) + expect_file_unchanged_(file, act$out, update = update, info = info, ...) invisible(act$val) } -compare_file <- function(path, lines, ..., update = TRUE, info = NULL) { +expect_file_unchanged_ <- function( + path, + lines, + ..., + update = TRUE, + info = NULL +) { if (!file.exists(path)) { cli::cli_warn("Creating reference output.") brio::write_lines(lines, path) - return(pass(NULL)) + pass() + return() } old_lines <- brio::read_lines(path) @@ -108,9 +115,10 @@ compare_file <- function(path, lines, ..., update = TRUE, info = NULL) { encodeString(path, quote = "'"), paste0(comp, collapse = "\n\n") ) - return(fail(msg, info = info, trace_env = caller_env())) + fail(msg, info = info, trace_env = caller_env()) + } else { + pass() } - pass(NULL) } #' Do you expect the output/result to equal a known good value? @@ -151,7 +159,7 @@ expect_output_file <- function( act$lab <- label %||% quo_label(act$quo) act <- append(act, eval_with_output(object, print = print, width = width)) - compare_file(file, act$out, update = update, info = info, ...) + expect_file_unchanged_(file, act$out, update = update, info = info, ...) invisible(act$val) } @@ -180,6 +188,7 @@ expect_known_value <- function( if (!file.exists(file)) { cli::cli_warn("Creating reference value.") saveRDS(object, file, version = version) + pass() } else { ref_val <- readRDS(file) comp <- compare(act$val, ref_val, ...) @@ -194,11 +203,13 @@ expect_known_value <- function( encodeString(file, quote = "'"), comp$message ) - return(fail(msg, info = info)) + fail(msg, info = info) + } else { + pass() } } - pass(act$value) + invisible(act$val) } #' @export @@ -233,6 +244,7 @@ expect_known_hash <- function(object, hash = NULL) { if (is.null(hash)) { cli::cli_warn("No recorded hash: use {substr(act_hash, 1, 10)}.") + pass() } else { if (hash != act_hash) { msg <- sprintf( @@ -240,11 +252,13 @@ expect_known_hash <- function(object, hash = NULL) { hash, act_hash ) - return(fail(msg)) + fail(msg) + } else { + pass() } } - pass(act$value) + invisible(act$val) } all_utf8 <- function(x) { diff --git a/R/expect-named.R b/R/expect-named.R index 652713cb7..10cc88761 100644 --- a/R/expect-named.R +++ b/R/expect-named.R @@ -74,9 +74,11 @@ normalise_names <- function(x, ignore.order = FALSE, ignore.case = FALSE) { expect_has_names_ <- function(act, trace_env = caller_env()) { act_names <- names(act$val) - if (identical(act_names, NULL)) { + if (is.null(act_names)) { msg <- sprintf("Expected %s to have names.", act$lab) - return(fail(msg, trace_env = trace_env)) + fail(msg, trace_env = trace_env) + } else { + pass() } - return(pass(act$val)) + invisible(act$val) } diff --git a/R/expect-no-condition.R b/R/expect-no-condition.R index 50b939fb2..46e0fab10 100644 --- a/R/expect-no-condition.R +++ b/R/expect-no-condition.R @@ -119,10 +119,12 @@ expect_no_ <- function( "." ) msg_act <- actual_condition(first_match) - return(fail(c(msg_exp, msg_act), trace_env = trace_env)) + fail(c(msg_exp, msg_act), trace_env = trace_env) + } else { + pass() } - pass(act$val) + invisible(act$val) } indent_lines <- function(x) { diff --git a/R/expect-reference.R b/R/expect-reference.R index 6f23b3c7d..64d90c8d1 100644 --- a/R/expect-reference.R +++ b/R/expect-reference.R @@ -28,9 +28,11 @@ expect_reference <- function( if (!is_reference(act$val, exp$val)) { msg <- sprintf("Expected %s to be a reference to %s.", act$lab, exp$lab) - return(fail(msg, info = info)) + fail(msg, info = info) + } else { + pass() } - pass(act$val) + invisible(act$val) } # expect_reference() needs dev version of rlang diff --git a/R/expect-self-test.R b/R/expect-self-test.R index 1ae3e2595..a0beda495 100644 --- a/R/expect-self-test.R +++ b/R/expect-self-test.R @@ -51,18 +51,18 @@ expect_success <- function(expr) { "Expected one success.", sprintf("Actually succeeded %i times", status$n_success) ) - return(fail(msg)) - } - - if (status$n_failure > 0) { + fail(msg) + } else if (status$n_failure > 0) { msg <- c( "Expected zero failures.", sprintf("Actually failed %i times", status$n_failure) ) - return(fail(msg)) + fail(msg) + } else { + pass() } - pass(NULL) + invisible() } #' @export @@ -116,9 +116,11 @@ expect_no_success <- function(expr) { status <- capture_success_failure(expr) if (status$n_success > 0) { - return(fail("Expectation succeeded")) + fail("Expectation succeeded") + } else { + pass() } - pass(NULL) + invisible() } #' @export @@ -128,9 +130,11 @@ expect_no_failure <- function(expr) { status <- capture_success_failure(expr) if (status$n_failure > 0) { - return(fail("Expectation failed")) + fail("Expectation failed") + } else { + pass() } - pass(NULL) + invisible() } expect_snapshot_skip <- function(x, cran = FALSE) { diff --git a/R/expect-setequal.R b/R/expect-setequal.R index bfd8f7bb9..80ad586f7 100644 --- a/R/expect-setequal.R +++ b/R/expect-setequal.R @@ -114,9 +114,11 @@ expect_contains <- function(object, expected) { sprintf("Missing: %s", values(exp$val[exp_miss])) ) fail(c(msg_exp, msg_act)) + } else { + pass() } - pass(act$val) + invisible(act$val) } #' @export @@ -141,9 +143,11 @@ expect_in <- function(object, expected) { sprintf("Invalid: %s", values(act$val[act_miss])) ) fail(c(msg_exp, msg_act)) + } else { + pass() } - pass(act$val) + invisible(act$val) } # Helpers ---------------------------------------------------------------------- diff --git a/R/expect-shape.R b/R/expect-shape.R index c7c1ae311..2463af841 100644 --- a/R/expect-shape.R +++ b/R/expect-shape.R @@ -32,9 +32,11 @@ expect_length <- function(object, n) { sprintf("Expected %s to have length %i.", act$lab, n), sprintf("Actual length: %i.", act$n) ) - return(fail(msg)) + fail(msg) + } else { + pass() } - pass(act$val) + invisible(act$val) } #' @param nrow,ncol Expected [nrow()]/[ncol()] of `object`. @@ -61,14 +63,17 @@ expect_shape = function(object, ..., nrow, ncol, dim) { sprintf("Expected %s to have %i rows.", act$lab, nrow), sprintf("Actual rows: %i.", act$nrow) ) - return(fail(msg)) + fail(msg) + } else { + pass() } } else if (!missing(ncol)) { check_number_whole(ncol, allow_na = TRUE) if (length(dim_object) == 1L) { msg <- sprintf("Expected %s to have two or more dimensions.", act$lab) - return(fail(msg)) + fail(msg) + return(invisible(act$val)) } act$ncol <- dim_object[2L] @@ -78,7 +83,9 @@ expect_shape = function(object, ..., nrow, ncol, dim) { sprintf("Expected %s to have %i columns.", act$lab, ncol), sprintf("Actual columns: %i.", act$ncol) ) - return(fail(msg)) + fail(msg) + } else { + pass() } } else { # !missing(dim) @@ -92,16 +99,17 @@ expect_shape = function(object, ..., nrow, ncol, dim) { sprintf("Expected %s to have %i dimensions.", act$lab, length(dim)), sprintf("Actual dimensions: %i.", length(act$dim)) ) - } - - if (!identical(as.integer(act$dim), as.integer(dim))) { + fail(msg) + } else if (!identical(as.integer(act$dim), as.integer(dim))) { msg <- c( sprintf("Expected %s to have dim (%s).", act$lab, toString(dim)), sprintf("Actual dim: (%s).", toString(act$dim)) ) - return(fail(msg)) + fail(msg) + } else { + pass() } } - pass(act$val) + invisible(act$val) } diff --git a/R/expect-silent.R b/R/expect-silent.R index 7d96c5fec..c5a3f9b48 100644 --- a/R/expect-silent.R +++ b/R/expect-silent.R @@ -31,7 +31,9 @@ expect_silent <- function(object) { sprintf("Expected %s to run silently.", act$lab), sprintf("Actual noise: %s.", paste(outputs, collapse = ", ")) ) - return(fail(msg)) + fail(msg) + } else { + pass() } - pass(act$cap$result) + invisible(act$cap$result) } diff --git a/R/expect-that.R b/R/expect-that.R index 96aa0ad16..0fb61564e 100644 --- a/R/expect-that.R +++ b/R/expect-that.R @@ -2,8 +2,9 @@ #' #' @description #' These are the primitives that you can use to implement your own expectations. -#' Regardless of how it's called an expectation should either return `pass()`, -#' `fail()`, or throw an error (if for example, the arguments are invalid). +#' Every path through an expectation should either call `pass()`, `fail()`, +#' or throw an error (e.g. if the arguments are invalid). Expectations should +#' always return `invisible(act$val)`. #' #' Learn more about creating your own expectations in #' `vignette("custom-expectation")`. @@ -29,10 +30,12 @@ #' act_n <- length(act$val) #' if (act_n != n) { #' msg <- sprintf("%s has length %i, not length %i.", act$lab, act_n, n) -#' return(fail(msg)) +#' fail(msg) +#' } else { +#' pass() #' } #' -#' pass(act$val) +#' invisible(act$val) #' } fail <- function( message = "Failure has been forced", @@ -44,12 +47,14 @@ fail <- function( trace <- trace %||% capture_trace(trace_env) message <- paste(c(message, info), collapse = "\n") expectation("failure", message, srcref = srcref, trace = trace) + invisible() } snapshot_fail <- function(message, trace_env = caller_env()) { trace <- capture_trace(trace_env) message <- paste(message, collapse = "\n") expectation("failure", message, trace = trace, snapshot = TRUE) + invisible() } capture_trace <- function(trace_env) { @@ -62,12 +67,10 @@ capture_trace <- function(trace_env) { } #' @rdname fail -#' @param value Value to return, typically the result of evaluating the -#' `object` argument to the expectation. #' @export -pass <- function(value = NULL) { +pass <- function() { expectation("success", "success") - invisible(value) + invisible() } #' Mark a test as successful diff --git a/R/expect-vector.R b/R/expect-vector.R index 048337da4..5fd1752fc 100644 --- a/R/expect-vector.R +++ b/R/expect-vector.R @@ -22,15 +22,21 @@ expect_vector <- function(object, ptype = NULL, size = NULL) { # added by as_label() act$lab <- gsub("^`|`$", "", act$lab) + failed <- FALSE withCallingHandlers( vctrs::vec_assert(act$val, ptype = ptype, size = size, arg = act$lab), vctrs_error_scalar_type = function(e) { + failed <<- TRUE fail(e$message) }, vctrs_error_assert = function(e) { + failed <<- TRUE fail(e$message) } ) - pass(act$val) + if (!failed) { + pass() + } + invisible(act$val) } diff --git a/R/old-school.R b/R/old-school.R index b3fcb397d..2cac26689 100644 --- a/R/old-school.R +++ b/R/old-school.R @@ -148,9 +148,10 @@ takes_less_than <- function(amount) { if (duration >= amount) { msg <- paste0("took ", duration, " seconds, which is more than ", amount) - return(fail(msg)) + fail(msg) + } else { + pass() } - pass(expr) } } @@ -170,9 +171,10 @@ not <- function(f) { negate <- function(expt) { if (expectation_success(expt)) { msg <- paste0("NOT(", expt$message, ")") - return(fail(msg, srcref = expt$srcref)) + fail(msg, srcref = expt$srcref) + } else { + pass() } - pass(NULL) } function(...) { diff --git a/R/snapshot-file.R b/R/snapshot-file.R index 8a64ef334..b78763a90 100644 --- a/R/snapshot-file.R +++ b/R/snapshot-file.R @@ -191,9 +191,10 @@ expect_snapshot_file <- function( comp, hint ) - return(snapshot_fail(msg)) + snapshot_fail(msg) + } else { + pass() } - pass(NULL) } is_text_file <- function(path) { diff --git a/R/snapshot.R b/R/snapshot.R index 2dc7686ac..aa31234cc 100644 --- a/R/snapshot.R +++ b/R/snapshot.R @@ -380,10 +380,12 @@ expect_snapshot_helper <- function( comp, hint ) - return(snapshot_fail(msg, trace_env = trace_env)) + snapshot_fail(msg, trace_env = trace_env) + } else { + pass() } - pass(NULL) + invisible() } snapshot_hint <- function(id, show_accept = TRUE, reset_output = TRUE) { diff --git a/R/test-compiled-code.R b/R/test-compiled-code.R index 8544822a6..24f706724 100644 --- a/R/test-compiled-code.R +++ b/R/test-compiled-code.R @@ -25,9 +25,10 @@ expect_cpp_tests_pass <- function(package) { if (!tests_passed) { msg <- paste("C++ unit tests:", info, sep = "\n") - return(fail(msg)) + fail(msg) + } else { + pass() } - pass(NULL) } #' Do C++ tests past? diff --git a/R/verify-output.R b/R/verify-output.R index 99f7af1de..c071c5258 100644 --- a/R/verify-output.R +++ b/R/verify-output.R @@ -64,7 +64,7 @@ verify_output <- function( if (!interactive() && on_cran()) { skip("On CRAN") } - compare_file(path, output, update = TRUE) + expect_file_unchanged_(path, output, update = TRUE) invisible() } diff --git a/man/fail.Rd b/man/fail.Rd index 7626b138e..108c2851b 100644 --- a/man/fail.Rd +++ b/man/fail.Rd @@ -13,7 +13,7 @@ fail( trace = NULL ) -pass(value = NULL) +pass() } \arguments{ \item{message}{Failure message to send to the user. It's best practice to @@ -33,14 +33,12 @@ you're calling \code{fail()} from a helper function; see \item{trace}{An optional backtrace created by \code{\link[rlang:trace_back]{rlang::trace_back()}}. When supplied, the expectation is displayed with the backtrace. Expert use only.} - -\item{value}{Value to return, typically the result of evaluating the -\code{object} argument to the expectation.} } \description{ These are the primitives that you can use to implement your own expectations. -Regardless of how it's called an expectation should either return \code{pass()}, -\code{fail()}, or throw an error (if for example, the arguments are invalid). +Every path through an expectation should either call \code{pass()}, \code{fail()}, +or throw an error (e.g. if the arguments are invalid). Expectations should +always return \code{invisible(act$val)}. Learn more about creating your own expectations in \code{vignette("custom-expectation")}. @@ -52,9 +50,11 @@ expect_length <- function(object, n) { act_n <- length(act$val) if (act_n != n) { msg <- sprintf("\%s has length \%i, not length \%i.", act$lab, act_n, n) - return(fail(msg)) + fail(msg) + } else { + pass() } - pass(act$val) + invisible(act$val) } } diff --git a/tests/testthat/_snaps/expect-self-test.md b/tests/testthat/_snaps/expect-self-test.md index ab0f27e58..5fe0850a6 100644 --- a/tests/testthat/_snaps/expect-self-test.md +++ b/tests/testthat/_snaps/expect-self-test.md @@ -70,7 +70,7 @@ # expect_no are deprecated Code - expect_no_failure(pass(NULL)) + expect_no_failure(pass()) Condition Warning: `expect_no_failure()` was deprecated in testthat 3.3.0. diff --git a/tests/testthat/_snaps/expect-shape.md b/tests/testthat/_snaps/expect-shape.md index f2b6c527b..1b73481bb 100644 --- a/tests/testthat/_snaps/expect-shape.md +++ b/tests/testthat/_snaps/expect-shape.md @@ -39,8 +39,8 @@ expect_shape(array(dim = 1:3), dim = 1:2) Condition Error: - ! Expected `array(dim = 1:3)` to have dim (1, 2). - Actual dim: (1, 2, 3). + ! Expected `array(dim = 1:3)` to have 2 dimensions. + Actual dimensions: 3. --- @@ -48,8 +48,8 @@ expect_shape(array(dim = 1:3), dim = 1:4) Condition Error: - ! Expected `array(dim = 1:3)` to have dim (1, 2, 3, 4). - Actual dim: (1, 2, 3). + ! Expected `array(dim = 1:3)` to have 4 dimensions. + Actual dimensions: 3. # nrow compared correctly diff --git a/tests/testthat/reporters/tests.R b/tests/testthat/reporters/tests.R index 8029f681b..05ad5e88d 100644 --- a/tests/testthat/reporters/tests.R +++ b/tests/testthat/reporters/tests.R @@ -3,7 +3,7 @@ local_edition(2) context("Successes") test_that("Success", { - pass(NULL) + pass() }) context("Failures") diff --git a/tests/testthat/test-expect-self-test.R b/tests/testthat/test-expect-self-test.R index 4c14bd5e4..97ae8f849 100644 --- a/tests/testthat/test-expect-self-test.R +++ b/tests/testthat/test-expect-self-test.R @@ -2,16 +2,16 @@ test_that("expect_failure() requires 1 failure and zero successes", { expect_success(expect_failure(fail())) expect_failure(expect_failure({})) - expect_failure(expect_failure(pass(NULL))) + expect_failure(expect_failure(pass())) expect_failure(expect_failure({ - pass(NULL) + pass() fail() })) expect_failure(expect_failure({ fail() # Following succeed/fail are never reached - pass(NULL) + pass() fail() })) }) @@ -29,7 +29,7 @@ test_that("expect_failure() generates a useful error messages", { } expect_has_success <- function() { fail() - pass(NULL) + pass() } expect_failure_foo <- function() fail("foo") @@ -42,17 +42,17 @@ test_that("expect_failure() generates a useful error messages", { }) test_that("expect_success() requires 1 success and zero failures", { - expect_success(expect_success(pass(NULL))) + expect_success(expect_success(pass())) expect_failure(expect_success({})) expect_failure(expect_success(fail())) expect_failure(expect_success({ - pass(NULL) + pass() fail() })) expect_failure(expect_success({ - pass(NULL) - pass(NULL) + pass() + pass() })) }) @@ -69,12 +69,12 @@ test_that("show_failure", { test_that("expect_success() generates a useful error messages", { expect_no_success <- function() {} expect_many_successes <- function() { - pass(NULL) - pass(NULL) + pass() + pass() } expect_has_failure <- function() { fail() - pass(NULL) + pass() } expect_snapshot_failure({ @@ -90,8 +90,8 @@ test_that("can count successes and failures", { expect_equal(status$n_failure, 0) status <- capture_success_failure({ - pass(NULL) - pass(NULL) + pass() + pass() fail() }) expect_equal(status$n_success, 2) @@ -99,9 +99,9 @@ test_that("can count successes and failures", { # No code run after first fail status <- capture_success_failure({ - pass(NULL) + pass() fail() - pass(NULL) + pass() fail() }) expect_equal(status$n_success, 2) @@ -110,15 +110,15 @@ test_that("can count successes and failures", { test_that("expect_no are deprecated", { expect_snapshot({ - expect_no_failure(pass(NULL)) + expect_no_failure(pass()) expect_no_success(fail()) }) }) test_that("expect_no still work", { withr::local_options(lifecycle_verbosity = "quiet") - expect_success(expect_no_failure(pass(NULL))) + expect_success(expect_no_failure(pass())) expect_failure(expect_no_failure(fail())) expect_success(expect_no_success(fail())) - expect_failure(expect_no_success(pass(NULL))) + expect_failure(expect_no_success(pass())) }) diff --git a/tests/testthat/test-snapshot.R b/tests/testthat/test-snapshot.R index 2eaac72c9..351870d7c 100644 --- a/tests/testthat/test-snapshot.R +++ b/tests/testthat/test-snapshot.R @@ -194,7 +194,7 @@ test_that("expect_snapshot requires a non-empty test label", { expect_error(expect_snapshot(1 + 1)) }) - pass(NULL) # quiet message about this test being empty + pass() # quiet message about this test being empty }) test_that("expect_snapshot validates its inputs", { diff --git a/tests/testthat/test-test-that.R b/tests/testthat/test-test-that.R index 5e4a355ad..a4cea932d 100644 --- a/tests/testthat/test-test-that.R +++ b/tests/testthat/test-test-that.R @@ -9,7 +9,7 @@ test_that("can't access variables from other tests (2)", { test_that("messages are suppressed", { local_edition(2) message("YOU SHOULDN'T SEE ME") - pass(NULL) + pass() }) test_that("errors are captured", { @@ -72,7 +72,7 @@ test_that("return value from test_that", { with_reporter( "", success <- test_that("success", { - pass(NULL) + pass() }) ) expect_true(success) From 832e5d3369793c9161daa82276bdaded83f7feef Mon Sep 17 00:00:00 2001 From: Hadley Wickham Date: Mon, 6 Oct 2025 08:06:18 -0500 Subject: [PATCH 07/22] Fix remaining failure returns --- R/expect-match.R | 3 ++- R/expect-shape.R | 3 ++- R/expectation.R | 8 +++++--- R/snapshot-reporter.R | 3 ++- R/snapshot.R | 3 ++- 5 files changed, 13 insertions(+), 7 deletions(-) diff --git a/R/expect-match.R b/R/expect-match.R index 88354a83b..6c32ccd1d 100644 --- a/R/expect-match.R +++ b/R/expect-match.R @@ -47,7 +47,8 @@ expect_match <- function( if (length(object) == 0) { msg <- sprintf("Expected %s to have at least one element.", act$lab) - return(fail(msg, info = info)) + fail(msg, info = info) + return(invisible(act$val)) } expect_match_( diff --git a/R/expect-shape.R b/R/expect-shape.R index 2463af841..8266d10b6 100644 --- a/R/expect-shape.R +++ b/R/expect-shape.R @@ -51,7 +51,8 @@ expect_shape = function(object, ..., nrow, ncol, dim) { dim_object <- base::dim(object) if (is.null(dim_object)) { - return(fail(sprintf("Expected %s to have dimensions.", act$lab))) + fail(sprintf("Expected %s to have dimensions.", act$lab)) + return(invisible(act$val)) } if (!missing(nrow)) { diff --git a/R/expectation.R b/R/expectation.R index 55f00845a..022135c0e 100644 --- a/R/expectation.R +++ b/R/expectation.R @@ -21,15 +21,17 @@ expect <- function( trace_env = caller_env() ) { if (!ok) { - return(fail( + fail( failure_message, info, srcref = srcref, trace = trace, trace_env = trace_env - )) + ) + } else { + # For backwards compatibility + succeed(failure_message) } - succeed(failure_message) } #' Construct an expectation object diff --git a/R/snapshot-reporter.R b/R/snapshot-reporter.R index 19d93c6ae..5cdb69cc3 100644 --- a/R/snapshot-reporter.R +++ b/R/snapshot-reporter.R @@ -115,7 +115,8 @@ SnapshotReporter <- R6::R6Class( value_enc ) if (fail_on_new) { - return(fail(message, trace_env = trace_env)) + fail(message, trace_env = trace_env) + return() } testthat_warn(message) character() diff --git a/R/snapshot.R b/R/snapshot.R index aa31234cc..e2d5bded1 100644 --- a/R/snapshot.R +++ b/R/snapshot.R @@ -129,7 +129,8 @@ expect_snapshot_ <- function( ) if (!is.null(msg)) { if (error) { - return(fail(msg, trace = state$error[["trace"]])) + fail(msg, trace = state$error[["trace"]]) + return() } else { cnd_signal(state$error) } From be37cf51419d1ba914bbdbfc6e00dc09073123b5 Mon Sep 17 00:00:00 2001 From: Hadley Wickham Date: Mon, 6 Oct 2025 08:07:01 -0500 Subject: [PATCH 08/22] Better --- R/snapshot.R | 1 - 1 file changed, 1 deletion(-) diff --git a/R/snapshot.R b/R/snapshot.R index e2d5bded1..68dad559a 100644 --- a/R/snapshot.R +++ b/R/snapshot.R @@ -130,7 +130,6 @@ expect_snapshot_ <- function( if (!is.null(msg)) { if (error) { fail(msg, trace = state$error[["trace"]]) - return() } else { cnd_signal(state$error) } From 9bba39e7f0c5fff2db05bce1dad50dabd5cd1f86 Mon Sep 17 00:00:00 2001 From: Hadley Wickham Date: Mon, 6 Oct 2025 08:12:32 -0500 Subject: [PATCH 09/22] Add news bullet --- NEWS.md | 1 + 1 file changed, 1 insertion(+) diff --git a/NEWS.md b/NEWS.md index 983e3356f..80f650de6 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,5 +1,6 @@ # testthat (development version) +* Expectations now consistently return the value of the first argument, regardless of whether the expectation succeeds or fails. The primary exception are `expect_message()` and friends which will return the condition. This shouldn't affect existing tests, but will make failures clearer when you chain together multiple expectations (#2246). * `set_state_inspector()` gains `tolerance` argument and ignores minor FP differences by default (@mcol, #2237). * `expect_vector()` fails, instead of erroring, if `object` is not a vector (@plietar, #2224). * New `vignette("mocking")` explains mocking in detail (#1265). From a530c6330a6f12ee1b6d41917915461e0b60421f Mon Sep 17 00:00:00 2001 From: Hadley Wickham Date: Mon, 6 Oct 2025 08:31:02 -0500 Subject: [PATCH 10/22] Polish `expect_named()` --- R/expect-named.R | 10 +++++----- tests/testthat/_snaps/expect-named.md | 16 ++++++++-------- tests/testthat/test-expect-named.R | 2 +- 3 files changed, 14 insertions(+), 14 deletions(-) diff --git a/R/expect-named.R b/R/expect-named.R index 10cc88761..6ec7a26c2 100644 --- a/R/expect-named.R +++ b/R/expect-named.R @@ -44,14 +44,14 @@ expect_named <- function( exp <- quasi_label(enquo(expected), arg = "expected") exp$val <- normalise_names(exp$val, ignore.order, ignore.case) - act_names <- normalise_names(names(act$val), ignore.order, ignore.case) - + act_names <- labelled_value( + normalise_names(names(act$val), ignore.order, ignore.case), + paste0("names of ", act$lab) + ) if (ignore.order) { - act_names <- labelled_value(act_names, paste0("names(", act$lab, ")")) expect_setequal_(act_names, exp) } else { - act_name <- labelled_value(act_names, paste0("names(", act$lab, ")")) - expect_waldo_equal_("equal", act_name, exp) + expect_waldo_equal_("equal", act_names, exp) } invisible(act$val) diff --git a/tests/testthat/_snaps/expect-named.md b/tests/testthat/_snaps/expect-named.md index 1cd4f1e45..08f4f82e8 100644 --- a/tests/testthat/_snaps/expect-named.md +++ b/tests/testthat/_snaps/expect-named.md @@ -12,7 +12,7 @@ expect_named(x, "b") Condition Error: - ! Expected names(`x`) to be equal to "b". + ! Expected names of `x` to be equal to "b". Differences: `actual`: "a" `expected`: "b" @@ -23,7 +23,7 @@ expect_named(x1, c("a", "b"), ignore.order = TRUE) Condition Error: - ! Expected names(`x1`) to have the same values as `c("a", "b")`. + ! Expected names of `x1` to have the same values as `c("a", "b")`. Actual: "a" Expected: "a", "b" Absent: "b" @@ -34,7 +34,7 @@ expect_named(x2, "a", ignore.order = TRUE) Condition Error: - ! Expected names(`x2`) to have the same values as "a". + ! Expected names of `x2` to have the same values as "a". Actual: "a", "b" Expected: "a" Needs: "b" @@ -45,7 +45,7 @@ expect_named(x1, "b", ignore.order = TRUE) Condition Error: - ! Expected names(`x1`) to have the same values as "b". + ! Expected names of `x1` to have the same values as "b". Actual: "a" Expected: "b" Needs: "a" @@ -57,7 +57,7 @@ expect_named(x1, c("a", "b"), ignore.order = FALSE) Condition Error: - ! Expected names(`x1`) to be equal to `c("a", "b")`. + ! Expected names of `x1` to be equal to `c("a", "b")`. Differences: `actual`: "a" `expected`: "a" "b" @@ -68,7 +68,7 @@ expect_named(x2, "a", ignore.order = FALSE) Condition Error: - ! Expected names(`x2`) to be equal to "a". + ! Expected names of `x2` to be equal to "a". Differences: `actual`: "a" "b" `expected`: "a" @@ -76,10 +76,10 @@ --- Code - expect_named(x1, c("b"), ignore.order = FALSE) + expect_named(x1, "b", ignore.order = FALSE) Condition Error: - ! Expected names(`x1`) to be equal to `c("b")`. + ! Expected names of `x1` to be equal to "b". Differences: `actual`: "a" `expected`: "b" diff --git a/tests/testthat/test-expect-named.R b/tests/testthat/test-expect-named.R index 31f6d9354..09bed4846 100644 --- a/tests/testthat/test-expect-named.R +++ b/tests/testthat/test-expect-named.R @@ -35,7 +35,7 @@ test_that("provide useful feedback on failure", { expect_snapshot_failure(expect_named(x1, c("a", "b"), ignore.order = FALSE)) expect_snapshot_failure(expect_named(x2, "a", ignore.order = FALSE)) - expect_snapshot_failure(expect_named(x1, c("b"), ignore.order = FALSE)) + expect_snapshot_failure(expect_named(x1, "b", ignore.order = FALSE)) }) test_that("expect_named validates its inputs", { From 6c40b184fadd502624f468b28b41eab7f60d3b26 Mon Sep 17 00:00:00 2001 From: Hadley Wickham Date: Mon, 6 Oct 2025 08:34:28 -0500 Subject: [PATCH 11/22] Polish expectation tests --- R/expect-self-test.R | 30 ++++++++--------------- tests/testthat/_snaps/expect-self-test.md | 12 ++++----- 2 files changed, 16 insertions(+), 26 deletions(-) diff --git a/R/expect-self-test.R b/R/expect-self-test.R index a0beda495..12cee8d26 100644 --- a/R/expect-self-test.R +++ b/R/expect-self-test.R @@ -46,18 +46,13 @@ capture_success_failure <- function(expr) { expect_success <- function(expr) { status <- capture_success_failure(expr) + expected <- "Expected exactly one success and no failures." if (status$n_success != 1) { - msg <- c( - "Expected one success.", - sprintf("Actually succeeded %i times", status$n_success) - ) - fail(msg) + actual <- sprintf("Actually succeeded %i times", status$n_success) + fail(c(expected, actual)) } else if (status$n_failure > 0) { - msg <- c( - "Expected zero failures.", - sprintf("Actually failed %i times", status$n_failure) - ) - fail(msg) + actual <- sprintf("Actually failed %i times", status$n_failure) + fail(c(expected, actual)) } else { pass() } @@ -70,18 +65,13 @@ expect_success <- function(expr) { expect_failure <- function(expr, message = NULL, ...) { status <- capture_success_failure(expr) + expected <- "Expected exactly one failure and no successes." if (status$n_failure != 1) { - msg <- c( - "Expected one failure.", - sprintf("Actually failed %i times", status$n_failure) - ) - fail(msg) + actual <- sprintf("Actually failed %i times", status$n_failure) + fail(c(expected, actual)) } else if (status$n_success != 0) { - msg <- c( - "Expected zero successes.", - sprintf("Actually succeeded %i times", status$n_success) - ) - fail(msg) + actual <- sprintf("Actually succeeded %i times", status$n_success) + fail(c(expected, actual)) } else { if (is.null(message)) { pass() diff --git a/tests/testthat/_snaps/expect-self-test.md b/tests/testthat/_snaps/expect-self-test.md index 5fe0850a6..ad7c1d82c 100644 --- a/tests/testthat/_snaps/expect-self-test.md +++ b/tests/testthat/_snaps/expect-self-test.md @@ -4,19 +4,19 @@ expect_failure(expect_no_failure()) Condition Error: - ! Expected one failure. + ! Expected exactly one failure and no successes. Actually failed 0 times Code expect_failure(expect_many_failures()) Condition Error: - ! Expected one failure. + ! Expected exactly one failure and no successes. Actually failed 2 times Code expect_failure(expect_has_success()) Condition Error: - ! Expected zero successes. + ! Expected exactly one failure and no successes. Actually succeeded 1 times Code expect_failure(expect_failure_foo(), "bar") @@ -52,19 +52,19 @@ expect_success(expect_no_success()) Condition Error: - ! Expected one success. + ! Expected exactly one success and no failures. Actually succeeded 0 times Code expect_success(expect_many_successes()) Condition Error: - ! Expected one success. + ! Expected exactly one success and no failures. Actually succeeded 2 times Code expect_success(expect_has_failure()) Condition Error: - ! Expected zero failures. + ! Expected exactly one success and no failures. Actually failed 1 times # expect_no are deprecated From 22d01a9432346e3de8264eb9b7142f98b082c6f5 Mon Sep 17 00:00:00 2001 From: Hadley Wickham Date: Mon, 6 Oct 2025 08:39:18 -0500 Subject: [PATCH 12/22] Align `expect_file_unchanged_` --- R/expect-known.R | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/R/expect-known.R b/R/expect-known.R index 4239260b7..c2a6db837 100644 --- a/R/expect-known.R +++ b/R/expect-known.R @@ -82,7 +82,8 @@ expect_file_unchanged_ <- function( lines, ..., update = TRUE, - info = NULL + info = NULL, + trace_env = caller_env() ) { if (!file.exists(path)) { cli::cli_warn("Creating reference output.") @@ -115,7 +116,7 @@ expect_file_unchanged_ <- function( encodeString(path, quote = "'"), paste0(comp, collapse = "\n\n") ) - fail(msg, info = info, trace_env = caller_env()) + fail(msg, info = info, trace_env = trace_env) } else { pass() } From f3126cad881bc997a8d78c3fca77f8c77f081af1 Mon Sep 17 00:00:00 2001 From: Hadley Wickham Date: Mon, 6 Oct 2025 08:39:23 -0500 Subject: [PATCH 13/22] Fix typo --- R/expect-setequal.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/R/expect-setequal.R b/R/expect-setequal.R index 80ad586f7..941fcfeb6 100644 --- a/R/expect-setequal.R +++ b/R/expect-setequal.R @@ -62,7 +62,7 @@ expect_setequal_ <- function( fail(c(msg_exp, msg_act), trace_env = trace_env) } - invisible(act$value) + invisible(act$val) } values <- function(x) { From 7397403fc08af5b2a56241fed65e4e2ab9fdc24f Mon Sep 17 00:00:00 2001 From: Hadley Wickham Date: Mon, 6 Oct 2025 08:44:02 -0500 Subject: [PATCH 14/22] Polish vignette --- vignettes/custom-expectation.Rmd | 51 ++++++++++++++------------------ 1 file changed, 22 insertions(+), 29 deletions(-) diff --git a/vignettes/custom-expectation.Rmd b/vignettes/custom-expectation.Rmd index ee5fd3b04..3dafb1f6a 100644 --- a/vignettes/custom-expectation.Rmd +++ b/vignettes/custom-expectation.Rmd @@ -75,12 +75,11 @@ expect_length <- function(object, n) { act_n <- length(act$val) if (act_n != n) { - msg <- c( + # 2. Fail if expectations are violated + fail(c( sprintf("Expected %s to have length %i.", act$lab, n), sprintf("Actual length: %i.", act_n) - ) - # 2. Fail if expectations are violated - fail(msg) + )) } else { # 3. Pass if expectations are met pass() @@ -93,7 +92,7 @@ expect_length <- function(object, n) { The first step in any expectation is to use `quasi_label()` to capture a "labeled value", i.e., a list that contains both the value (`$val`) for testing and a label (`$lab`) used to make failure messages as informative as possible. This is a pattern that exists for fairly esoteric reasons; you don't need to understand it, just copy and paste it. -Next you need to check each way that `object` could violate the expectation. In this case, there's only one check, but in more complicated cases there can be multiple checks. In most cases, it's easier to check for violations one by one, using an nested if-else statement. That makes it easier to write informative failure messages that first describe what was expected and then what was actually seen. +Next you need to check each way that `object` could violate the expectation. In this case, there's only one check, but in more complicated cases there can be many. Note the specific form of the failure message: the first element describes what we expected, and then the second line reports what we actually saw. If the object is as expected, call `pass()`. This ensures that a success will be registered in the test reporter. @@ -154,21 +153,19 @@ expect_vector_length <- function(object, n) { # It's non-trivial to check if an object is a vector in base R so we # use an rlang helper if (!rlang::is_vector(act$val)) { - msg <- c( + fail(c( sprintf("Expected %s to be a vector", act$lab), sprintf("Actual type: %s", typeof(act$val)) - ) - fail(msg) + )) return(invisible(act$val)) } act_n <- length(act$val) if (act_n != n) { - msg <- c( + fail(c( sprintf("Expected %s to have length %i.", act$lab, n), sprintf("Actual length: %i.", act_n) - ) - fail(msg) + )) } else { pass() } @@ -195,20 +192,17 @@ expect_s3_class <- function(object, class) { act <- quasi_label(rlang::enquo(object)) if (!is.object(act$val)) { - msg <- sprintf("Expected %s to be an object.", act$lab) - fail(msg) + fail(sprintf("Expected %s to be an object.", act$lab)) } else if (isS4(act$val)) { - msg <- c( + fail(c( sprintf("Expected %s to be an S3 object.", act$lab), "Actual OO type: S4" - ) - fail(msg) + )) } else if (!inherits(act$val, class)) { - msg <- c( + fail(c( sprintf("Expected %s to inherit from %s.", act$lab, class), sprintf("Actual class: %s", class(act$val)) - ) - fail(msg) + )) } else { pass() } @@ -258,20 +252,17 @@ expect_s3_object <- function(object, class = NULL) { act <- quasi_label(rlang::enquo(object)) if (!is.object(act$val)) { - msg <- sprintf("Expected %s to be an object.", act$lab) - fail(msg) + fail(sprintf("Expected %s to be an object.", act$lab)) } else if (isS4(act$val)) { - msg <- c( + fail(c( sprintf("Expected %s to be an S3 object.", act$lab), "Actual OO type: S4" - ) - fail(msg) + )) } else if (!is.null(class) && !inherits(act$val, class)) { - msg <- c( + fail(c( sprintf("Expected %s to inherit from %s.", act$lab, class), sprintf("Actual class: %s", class(act$val)) - ) - fail(msg) + )) } else { pass() } @@ -290,8 +281,10 @@ The key challenge is that `fail()` captures a `trace_env`, which should be the e expect_length_ <- function(act, n, trace_env = caller_env()) { act_n <- length(act$val) if (act_n != n) { - msg <- sprintf("%s has length %i, not length %i.", act$lab, act_n, n) - fail(msg, trace_env = trace_env) + fail( + sprintf("%s has length %i, not length %i.", act$lab, act_n, n), + trace_env = trace_env + ) } else { pass() } From bf464204f6bff36e602bd9fde0d590f71898b0bd Mon Sep 17 00:00:00 2001 From: Hadley Wickham Date: Mon, 6 Oct 2025 08:47:53 -0500 Subject: [PATCH 15/22] Eliminate intermediate variable --- R/expect-inheritance.R | 56 +++++++++++++++++------------------------- R/expect-invisible.R | 10 +++----- R/expect-known.R | 5 ++-- R/expect-shape.R | 28 +++++++++------------ R/expect-silent.R | 5 ++-- R/expect-that.R | 3 +-- R/old-school.R | 3 +-- R/test-compiled-code.R | 3 +-- man/fail.Rd | 3 +-- 9 files changed, 45 insertions(+), 71 deletions(-) diff --git a/R/expect-inheritance.R b/R/expect-inheritance.R index c25197d1d..316626816 100644 --- a/R/expect-inheritance.R +++ b/R/expect-inheritance.R @@ -70,11 +70,10 @@ expect_type <- function(object, type) { act_type <- typeof(act$val) if (!identical(act_type, type)) { - msg <- c( + fail(c( sprintf("Expected %s to have type %s.", act$lab, format_class(type)), sprintf("Actual type: %s", format_class(act_type)) - ) - fail(msg) + )) } else { pass() } @@ -95,30 +94,26 @@ expect_s3_class <- function(object, class, exact = FALSE) { if (identical(class, NA)) { if (isS3(object)) { - msg <- sprintf("Expected %s not to be an S3 object.", act$lab) - fail(msg) + fail(sprintf("Expected %s not to be an S3 object.", act$lab)) } else { pass() } } else if (is.character(class)) { if (!isS3(act$val)) { - msg <- c( + fail(c( sprintf("Expected %s to be an S3 object.", act$lab), sprintf("Actual OO type: %s.", oo_type(act$val)) - ) - fail(msg) + )) } else if (exact && !identical(class(act$val), class)) { - msg <- c( + fail(c( sprintf("Expected %s to have class %s.", act$lab, exp_lab), sprintf("Actual class: %s.", act$class) - ) - fail(msg) + )) } else if (!inherits(act$val, class)) { - msg <- c( + fail(c( sprintf("Expected %s to inherit from %s.", act$lab, exp_lab), sprintf("Actual class: %s.", act$class) - ) - fail(msg) + )) } else { pass() } @@ -138,24 +133,21 @@ expect_s4_class <- function(object, class) { if (identical(class, NA)) { if (isS4(object)) { - msg <- sprintf("Expected %s not to be an S4 object.", act$lab) - fail(msg) + fail(sprintf("Expected %s not to be an S4 object.", act$lab)) } else { pass() } } else if (is.character(class)) { if (!isS4(act$val)) { - msg <- c( + fail(c( sprintf("Expected %s to be an S4 object.", act$lab), sprintf("Actual OO type: %s.", oo_type(act$val)) - ) - fail(msg) + )) } else if (!methods::is(act$val, class)) { - msg <- c( + fail(c( sprintf("Expected %s to inherit from %s.", act$lab, exp_lab), sprintf("Actual class: %s.", act$class) - ) - fail(msg) + )) } else { pass() } @@ -173,19 +165,17 @@ expect_r6_class <- function(object, class) { check_string(class) if (!inherits(act$val, "R6")) { - msg <- c( + fail(c( sprintf("Expected %s to be an R6 object.", act$lab), sprintf("Actual OO type: %s.", oo_type(act$val)) - ) - fail(msg) + )) } else if (!inherits(act$val, class)) { act_class <- format_class(class(act$val)) exp_class <- format_class(class) - msg <- c( + fail(c( sprintf("Expected %s to inherit from %s.", act$lab, exp_class), sprintf("Actual class: %s.", act_class) - ) - fail(msg) + )) } else { pass() } @@ -204,21 +194,19 @@ expect_s7_class <- function(object, class) { act <- quasi_label(enquo(object)) if (!S7::S7_inherits(object)) { - msg <- c( + fail(c( sprintf("Expected %s to be an S7 object.", act$lab), sprintf("Actual OO type: %s.", oo_type(act$val)) - ) - fail(msg) + )) } else if (!S7::S7_inherits(object, class)) { exp_class <- attr(class, "name", TRUE) act_class <- setdiff(base::class(object), "S7_object") act_class_desc <- paste0("<", act_class, ">", collapse = "/") - msg <- c( + fail(c( sprintf("Expected %s to inherit from <%s>.", act$lab, exp_class), sprintf("Actual class: %s.", act_class_desc) - ) - fail(msg) + )) } else { pass() } diff --git a/R/expect-invisible.R b/R/expect-invisible.R index 14709393f..cc88f4182 100644 --- a/R/expect-invisible.R +++ b/R/expect-invisible.R @@ -25,11 +25,10 @@ expect_invisible <- function(call, label = NULL) { vis <- withVisible(call) if (!identical(vis$visible, FALSE)) { - msg <- c( + fail(c( sprintf("Expected %s to return invisibly.", lab), "Actual visibility: visible." - ) - fail(msg) + )) } else { pass() } @@ -43,11 +42,10 @@ expect_visible <- function(call, label = NULL) { vis <- withVisible(call) if (!identical(vis$visible, TRUE)) { - msg <- c( + fail(c( sprintf("Expected %s to return visibly.", lab), "Actual visibility: invisible." - ) - fail(msg) + )) } else { pass() } diff --git a/R/expect-known.R b/R/expect-known.R index c2a6db837..c8ef59fab 100644 --- a/R/expect-known.R +++ b/R/expect-known.R @@ -248,12 +248,11 @@ expect_known_hash <- function(object, hash = NULL) { pass() } else { if (hash != act_hash) { - msg <- sprintf( + fail(sprintf( "Expected value to hash to %s.\nActual hash: %s", hash, act_hash - ) - fail(msg) + )) } else { pass() } diff --git a/R/expect-shape.R b/R/expect-shape.R index 8266d10b6..5617d7d71 100644 --- a/R/expect-shape.R +++ b/R/expect-shape.R @@ -28,11 +28,10 @@ expect_length <- function(object, n) { act$n <- length(act$val) if (act$n != n) { - msg <- c( + fail(c( sprintf("Expected %s to have length %i.", act$lab, n), sprintf("Actual length: %i.", act$n) - ) - fail(msg) + )) } else { pass() } @@ -60,11 +59,10 @@ expect_shape = function(object, ..., nrow, ncol, dim) { act$nrow <- dim_object[1L] if (!identical(as.integer(act$nrow), as.integer(nrow))) { - msg <- c( + fail(c( sprintf("Expected %s to have %i rows.", act$lab, nrow), sprintf("Actual rows: %i.", act$nrow) - ) - fail(msg) + )) } else { pass() } @@ -72,19 +70,17 @@ expect_shape = function(object, ..., nrow, ncol, dim) { check_number_whole(ncol, allow_na = TRUE) if (length(dim_object) == 1L) { - msg <- sprintf("Expected %s to have two or more dimensions.", act$lab) - fail(msg) + fail(sprintf("Expected %s to have two or more dimensions.", act$lab)) return(invisible(act$val)) } act$ncol <- dim_object[2L] if (!identical(as.integer(act$ncol), as.integer(ncol))) { - msg <- c( + fail(c( sprintf("Expected %s to have %i columns.", act$lab, ncol), sprintf("Actual columns: %i.", act$ncol) - ) - fail(msg) + )) } else { pass() } @@ -96,17 +92,15 @@ expect_shape = function(object, ..., nrow, ncol, dim) { act$dim <- dim_object if (length(act$dim) != length(dim)) { - msg <- c( + fail(c( sprintf("Expected %s to have %i dimensions.", act$lab, length(dim)), sprintf("Actual dimensions: %i.", length(act$dim)) - ) - fail(msg) + )) } else if (!identical(as.integer(act$dim), as.integer(dim))) { - msg <- c( + fail(c( sprintf("Expected %s to have dim (%s).", act$lab, toString(dim)), sprintf("Actual dim: (%s).", toString(act$dim)) - ) - fail(msg) + )) } else { pass() } diff --git a/R/expect-silent.R b/R/expect-silent.R index c5a3f9b48..adcc11666 100644 --- a/R/expect-silent.R +++ b/R/expect-silent.R @@ -27,11 +27,10 @@ expect_silent <- function(object) { ) if (length(outputs) != 0) { - msg <- c( + fail(c( sprintf("Expected %s to run silently.", act$lab), sprintf("Actual noise: %s.", paste(outputs, collapse = ", ")) - ) - fail(msg) + )) } else { pass() } diff --git a/R/expect-that.R b/R/expect-that.R index 0fb61564e..0299e22ac 100644 --- a/R/expect-that.R +++ b/R/expect-that.R @@ -29,8 +29,7 @@ #' #' act_n <- length(act$val) #' if (act_n != n) { -#' msg <- sprintf("%s has length %i, not length %i.", act$lab, act_n, n) -#' fail(msg) +#' fail(sprintf("%s has length %i, not length %i.", act$lab, act_n, n)) #' } else { #' pass() #' } diff --git a/R/old-school.R b/R/old-school.R index 2cac26689..1ee6b70f5 100644 --- a/R/old-school.R +++ b/R/old-school.R @@ -147,8 +147,7 @@ takes_less_than <- function(amount) { duration <- system.time(force(expr))["elapsed"] if (duration >= amount) { - msg <- paste0("took ", duration, " seconds, which is more than ", amount) - fail(msg) + fail(paste0("took ", duration, " seconds, which is more than ", amount)) } else { pass() } diff --git a/R/test-compiled-code.R b/R/test-compiled-code.R index 24f706724..80374ca91 100644 --- a/R/test-compiled-code.R +++ b/R/test-compiled-code.R @@ -24,8 +24,7 @@ expect_cpp_tests_pass <- function(package) { info <- paste(output[-1], collapse = "\n") if (!tests_passed) { - msg <- paste("C++ unit tests:", info, sep = "\n") - fail(msg) + fail(paste("C++ unit tests:", info, sep = "\n")) } else { pass() } diff --git a/man/fail.Rd b/man/fail.Rd index 108c2851b..f7ca02211 100644 --- a/man/fail.Rd +++ b/man/fail.Rd @@ -49,8 +49,7 @@ expect_length <- function(object, n) { act_n <- length(act$val) if (act_n != n) { - msg <- sprintf("\%s has length \%i, not length \%i.", act$lab, act_n, n) - fail(msg) + fail(sprintf("\%s has length \%i, not length \%i.", act$lab, act_n, n)) } else { pass() } From 0281227e853455aa38c09862e89cf7a6f90457dc Mon Sep 17 00:00:00 2001 From: Hadley Wickham Date: Mon, 6 Oct 2025 09:51:06 -0500 Subject: [PATCH 16/22] Rework `expect_match_()` --- R/expect-match.R | 45 ++++++++++++++++++++++----------------------- 1 file changed, 22 insertions(+), 23 deletions(-) diff --git a/R/expect-match.R b/R/expect-match.R index 6c32ccd1d..224fcd309 100644 --- a/R/expect-match.R +++ b/R/expect-match.R @@ -62,6 +62,7 @@ expect_match <- function( label = label, negate = FALSE ) + invisible(act$val) } #' @describeIn expect_match Check that a string doesn't match a regular @@ -96,6 +97,7 @@ expect_no_match <- function( label = label, negate = TRUE ) + invisible(act$val) } expect_match_ <- function( @@ -115,31 +117,28 @@ expect_match_ <- function( condition <- if (negate) !matches else matches ok <- if (all) all(condition) else any(condition) - if (ok) { - pass() - return(invisible(act$val)) - } - - values <- show_text(act$val, condition) - if (length(act$val) == 1) { - which <- "" + if (!ok) { + values <- show_text(act$val, condition) + if (length(act$val) == 1) { + which <- "" + } else { + which <- if (all) "every element of " else "some element of " + } + match <- if (negate) "not to match" else "to match" + + msg_exp <- sprintf( + "Expected %s%s %s %s %s.", + which, + act$lab, + match, + if (fixed) "string" else "regexp", + encodeString(regexp, quote = '"') + ) + msg_act <- c(paste0("Actual ", title, ':'), values) + fail(c(msg_exp, msg_act), info = info, trace_env = trace_env) } else { - which <- if (all) "every element of " else "some element of " + pass() } - match <- if (negate) "not to match" else "to match" - - msg_exp <- sprintf( - "Expected %s%s %s %s %s.", - which, - act$lab, - match, - if (fixed) "string" else "regexp", - encodeString(regexp, quote = '"') - ) - msg_act <- c(paste0("Actual ", title, ':'), values) - fail(c(msg_exp, msg_act), info = info, trace_env = trace_env) - - invisible(act$val) } From fb417365160853c05d91b5dc8108ceb00f95726e Mon Sep 17 00:00:00 2001 From: Hadley Wickham Date: Mon, 6 Oct 2025 09:57:39 -0500 Subject: [PATCH 17/22] Eliminate early returns --- R/expect-shape.R | 26 +++++++++++--------------- 1 file changed, 11 insertions(+), 15 deletions(-) diff --git a/R/expect-shape.R b/R/expect-shape.R index 5617d7d71..219c79cb5 100644 --- a/R/expect-shape.R +++ b/R/expect-shape.R @@ -51,10 +51,7 @@ expect_shape = function(object, ..., nrow, ncol, dim) { dim_object <- base::dim(object) if (is.null(dim_object)) { fail(sprintf("Expected %s to have dimensions.", act$lab)) - return(invisible(act$val)) - } - - if (!missing(nrow)) { + } else if (!missing(nrow)) { check_number_whole(nrow, allow_na = TRUE) act$nrow <- dim_object[1L] @@ -71,18 +68,17 @@ expect_shape = function(object, ..., nrow, ncol, dim) { if (length(dim_object) == 1L) { fail(sprintf("Expected %s to have two or more dimensions.", act$lab)) - return(invisible(act$val)) - } - - act$ncol <- dim_object[2L] - - if (!identical(as.integer(act$ncol), as.integer(ncol))) { - fail(c( - sprintf("Expected %s to have %i columns.", act$lab, ncol), - sprintf("Actual columns: %i.", act$ncol) - )) } else { - pass() + act$ncol <- dim_object[2L] + + if (!identical(as.integer(act$ncol), as.integer(ncol))) { + fail(c( + sprintf("Expected %s to have %i columns.", act$lab, ncol), + sprintf("Actual columns: %i.", act$ncol) + )) + } else { + pass() + } } } else { # !missing(dim) From 963e37b5957c5e73a9f58b7e6a06df771640c266 Mon Sep 17 00:00:00 2001 From: Hadley Wickham Date: Mon, 6 Oct 2025 10:28:34 -0500 Subject: [PATCH 18/22] Refactor `expect_comparison()` --- R/expect-comparison.R | 22 ++++++++++++++-------- tests/testthat/_snaps/expect-comparison.md | 2 +- 2 files changed, 15 insertions(+), 9 deletions(-) diff --git a/R/expect-comparison.R b/R/expect-comparison.R index 3556f9c6c..f2bf997aa 100644 --- a/R/expect-comparison.R +++ b/R/expect-comparison.R @@ -28,20 +28,25 @@ expect_compare_ <- function( operator <- match.arg(operator) op <- match.fun(operator) - actual_op <- switch(operator, "<" = ">=", "<=" = ">", ">" = "<=", ">=" = "<") - cmp <- op(act$val, exp$val) if (length(cmp) != 1 || !is.logical(cmp)) { cli::cli_abort( - "Result of comparison must be a single logical value.", + "Result of comparison must be `TRUE`, `FALSE`, or `NA`", call = trace_env ) - } - if (isTRUE(cmp)) { + } else if (!isTRUE(cmp)) { + msg <- failure_compare(act, exp, operator) + fail(msg, trace_env = trace_env) + } else { pass() - return(invisible(act$val)) } + invisible(act$val) +} + +failure_compare <- function(act, exp, operator) { + actual_op <- switch(operator, "<" = ">=", "<=" = ">", ">" = "<=", ">=" = "<") + diff <- act$val - exp$val msg_exp <- sprintf("Expected %s %s %s.", act$lab, operator, exp$lab) @@ -67,9 +72,10 @@ expect_compare_ <- function( actual_op ) } - fail(c(msg_exp, msg_act, msg_diff), trace_env = trace_env) - invisible(act$val) + + c(msg_exp, msg_act, msg_diff) } + #' @export #' @rdname comparison-expectations expect_lt <- function(object, expected, label = NULL, expected.label = NULL) { diff --git a/tests/testthat/_snaps/expect-comparison.md b/tests/testthat/_snaps/expect-comparison.md index 30c210eab..3f9aeec72 100644 --- a/tests/testthat/_snaps/expect-comparison.md +++ b/tests/testthat/_snaps/expect-comparison.md @@ -82,5 +82,5 @@ expect_lt(1:10, 5) Condition Error in `expect_lt()`: - ! Result of comparison must be a single logical value. + ! Result of comparison must be `TRUE`, `FALSE`, or `NA` From 5d8887d710d736c7fddf3b0871074f0aec53f8ee Mon Sep 17 00:00:00 2001 From: Hadley Wickham Date: Mon, 6 Oct 2025 10:29:29 -0500 Subject: [PATCH 19/22] More to `expect_match()` --- R/expect-match.R | 30 ++++++++++++++++-------------- 1 file changed, 16 insertions(+), 14 deletions(-) diff --git a/R/expect-match.R b/R/expect-match.R index 224fcd309..7abc76446 100644 --- a/R/expect-match.R +++ b/R/expect-match.R @@ -46,22 +46,24 @@ expect_match <- function( check_bool(all) if (length(object) == 0) { - msg <- sprintf("Expected %s to have at least one element.", act$lab) - fail(msg, info = info) - return(invisible(act$val)) + fail( + sprintf("Expected %s to have at least one element.", act$lab), + info = info + ) + } else { + expect_match_( + act = act, + regexp = regexp, + perl = perl, + fixed = fixed, + ..., + all = all, + info = info, + label = label, + negate = FALSE + ) } - expect_match_( - act = act, - regexp = regexp, - perl = perl, - fixed = fixed, - ..., - all = all, - info = info, - label = label, - negate = FALSE - ) invisible(act$val) } From 8294b85138b8e123da8ca093d5ebef34ed0fb5bb Mon Sep 17 00:00:00 2001 From: Hadley Wickham Date: Mon, 6 Oct 2025 10:30:12 -0500 Subject: [PATCH 20/22] Remove early return in example --- vignettes/custom-expectation.Rmd | 20 ++++++++++---------- 1 file changed, 10 insertions(+), 10 deletions(-) diff --git a/vignettes/custom-expectation.Rmd b/vignettes/custom-expectation.Rmd index 3dafb1f6a..eca501ebf 100644 --- a/vignettes/custom-expectation.Rmd +++ b/vignettes/custom-expectation.Rmd @@ -157,18 +157,18 @@ expect_vector_length <- function(object, n) { sprintf("Expected %s to be a vector", act$lab), sprintf("Actual type: %s", typeof(act$val)) )) - return(invisible(act$val)) - } - - act_n <- length(act$val) - if (act_n != n) { - fail(c( - sprintf("Expected %s to have length %i.", act$lab, n), - sprintf("Actual length: %i.", act_n) - )) } else { - pass() + act_n <- length(act$val) + if (act_n != n) { + fail(c( + sprintf("Expected %s to have length %i.", act$lab, n), + sprintf("Actual length: %i.", act_n) + )) + } else { + pass() + } } + invisible(act$val) } ``` From 1a048b437fb6df9018c83cc3ce80c2cb9a416ef6 Mon Sep 17 00:00:00 2001 From: Hadley Wickham Date: Mon, 6 Oct 2025 10:43:09 -0500 Subject: [PATCH 21/22] Be more explicit about returned values --- R/expect-comparison.R | 6 ++++-- R/expect-constant.R | 7 ++++++- R/expect-equality.R | 6 ++---- R/expect-named.R | 42 +++++++++++++++++++----------------------- R/expect-setequal.R | 1 + 5 files changed, 32 insertions(+), 30 deletions(-) diff --git a/R/expect-comparison.R b/R/expect-comparison.R index f2bf997aa..2558e8bd5 100644 --- a/R/expect-comparison.R +++ b/R/expect-comparison.R @@ -40,8 +40,6 @@ expect_compare_ <- function( } else { pass() } - - invisible(act$val) } failure_compare <- function(act, exp, operator) { @@ -83,6 +81,7 @@ expect_lt <- function(object, expected, label = NULL, expected.label = NULL) { exp <- quasi_label(enquo(expected), expected.label) expect_compare_("<", act, exp) + invisible(act$val) } #' @export @@ -92,6 +91,7 @@ expect_lte <- function(object, expected, label = NULL, expected.label = NULL) { exp <- quasi_label(enquo(expected), expected.label) expect_compare_("<=", act, exp) + invisible(act$val) } #' @export @@ -101,6 +101,7 @@ expect_gt <- function(object, expected, label = NULL, expected.label = NULL) { exp <- quasi_label(enquo(expected), expected.label) expect_compare_(">", act, exp) + invisible(act$val) } #' @export @@ -110,6 +111,7 @@ expect_gte <- function(object, expected, label = NULL, expected.label = NULL) { exp <- quasi_label(enquo(expected), expected.label) expect_compare_(">=", act, exp) + invisible(act$val) } diff --git a/R/expect-constant.R b/R/expect-constant.R index 76f3ff078..b4b0917d4 100644 --- a/R/expect-constant.R +++ b/R/expect-constant.R @@ -31,7 +31,9 @@ NULL expect_true <- function(object, info = NULL, label = NULL) { act <- quasi_label(enquo(object), label) exp <- labelled_value(TRUE, "TRUE") + expect_waldo_constant_(act, exp, info = info, ignore_attr = TRUE) + invisible(act$val) } #' @export @@ -39,7 +41,9 @@ expect_true <- function(object, info = NULL, label = NULL) { expect_false <- function(object, info = NULL, label = NULL) { act <- quasi_label(enquo(object), label) exp <- labelled_value(FALSE, "FALSE") + expect_waldo_constant_(act, exp, info = info, ignore_attr = TRUE) + invisible(act$val) } #' Do you expect `NULL`? @@ -59,7 +63,9 @@ expect_false <- function(object, info = NULL, label = NULL) { expect_null <- function(object, info = NULL, label = NULL) { act <- quasi_label(enquo(object), label) exp <- labelled_value(NULL, "NULL") + expect_waldo_constant_(act, exp, info = info) + invisible(act$val) } expect_waldo_constant_ <- function( @@ -86,5 +92,4 @@ expect_waldo_constant_ <- function( } else { pass() } - invisible(act$val) } diff --git a/R/expect-equality.R b/R/expect-equality.R index 379339542..f59cfc156 100644 --- a/R/expect-equality.R +++ b/R/expect-equality.R @@ -86,8 +86,8 @@ expect_equal <- function( ) fail(msg, info = info) } - invisible(act$val) } + invisible(act$val) } @@ -124,8 +124,8 @@ expect_identical <- function( ) fail(msg, info = info) } - invisible(act$val) } + invisible(act$val) } expect_waldo_equal_ <- function( @@ -153,8 +153,6 @@ expect_waldo_equal_ <- function( ) fail(msg, info = info, trace_env = trace_env) } - - invisible(act$val) } #' Is an object equal to the expected value, ignoring attributes? diff --git a/R/expect-named.R b/R/expect-named.R index 6ec7a26c2..a313ecf71 100644 --- a/R/expect-named.R +++ b/R/expect-named.R @@ -38,20 +38,27 @@ expect_named <- function( act <- quasi_label(enquo(object), label) if (missing(expected)) { - return(expect_has_names_(act)) - } + act_names <- names(act$val) + if (is.null(act_names)) { + msg <- sprintf("Expected %s to have names.", act$lab) + fail(msg) + } else { + pass() + } + } else { + exp <- quasi_label(enquo(expected), arg = "expected") - exp <- quasi_label(enquo(expected), arg = "expected") + exp$val <- normalise_names(exp$val, ignore.order, ignore.case) + act_names <- labelled_value( + normalise_names(names(act$val), ignore.order, ignore.case), + paste0("names of ", act$lab) + ) - exp$val <- normalise_names(exp$val, ignore.order, ignore.case) - act_names <- labelled_value( - normalise_names(names(act$val), ignore.order, ignore.case), - paste0("names of ", act$lab) - ) - if (ignore.order) { - expect_setequal_(act_names, exp) - } else { - expect_waldo_equal_("equal", act_names, exp) + if (ignore.order) { + expect_setequal_(act_names, exp) + } else { + expect_waldo_equal_("equal", act_names, exp) + } } invisible(act$val) @@ -71,14 +78,3 @@ normalise_names <- function(x, ignore.order = FALSE, ignore.case = FALSE) { x } - -expect_has_names_ <- function(act, trace_env = caller_env()) { - act_names <- names(act$val) - if (is.null(act_names)) { - msg <- sprintf("Expected %s to have names.", act$lab) - fail(msg, trace_env = trace_env) - } else { - pass() - } - invisible(act$val) -} diff --git a/R/expect-setequal.R b/R/expect-setequal.R index 941fcfeb6..d52e80f08 100644 --- a/R/expect-setequal.R +++ b/R/expect-setequal.R @@ -90,6 +90,7 @@ expect_mapequal <- function(object, expected) { exp <- quasi_label(enquo(expected)) expect_waldo_equal_("equal", act, exp, list_as_map = TRUE) + invisible(act$val) } #' @export From 843e34d42cae20903945bb3eba2a981fc552527a Mon Sep 17 00:00:00 2001 From: Hadley Wickham Date: Mon, 6 Oct 2025 12:12:43 -0500 Subject: [PATCH 22/22] Update advice --- vignettes/custom-expectation.Rmd | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) diff --git a/vignettes/custom-expectation.Rmd b/vignettes/custom-expectation.Rmd index eca501ebf..27b381a88 100644 --- a/vignettes/custom-expectation.Rmd +++ b/vignettes/custom-expectation.Rmd @@ -288,13 +288,13 @@ expect_length_ <- function(act, n, trace_env = caller_env()) { } else { pass() } - - invisible(act$val) } expect_length <- function(object, n) { act <- quasi_label(rlang::enquo(object)) + expect_length_(act, n) + invisible(act$val) } ``` @@ -302,6 +302,7 @@ A few recommendations: * The helper shouldn't be user-facing, so we give it a `_` suffix to make that clear. * It's typically easiest for a helper to take the labeled value produced by `quasi_label()`. -* Your helper should usually call both `fail()` and `pass()` and be returned from the wrapping expectation. +* Your helper should usually be called for its side effects (i.e. it calls `fail()` and `pass()`). +* You should return `invisible(act$val)` from the parent expecatation as usual. Again, you're probably not writing so many expectations that it makes sense for you to go to this effort, but it is important for testthat to get it right.