WIP on expect_all_equal()

NAMESPACE

@@ -79,6 +79,9 @@ export(equals_reference)
 export(evaluate_promise)
 export(exp_signal)
 export(expect)
+export(expect_all_equal)
+export(expect_all_false)
+export(expect_all_true)
 export(expect_condition)
 export(expect_contains)
 export(expect_cpp_tests_pass)

R/expect-all.R

@@ -0,0 +1,67 @@
+#' Do you expect every value in a vector to have this value?
+#'
+#' These expectations are similar to `expect_true(all(x == "x"))`,
+#' `expect_true(all(x))` and `expect_true(all(!x))` but give more informative
+#' failure messages if the expectations are not met.
+#'
+#' @inheritParams expect_equal
+#' @export
+#' @examples
+#' x1 <- c(1, 1, 1, 1, 1, 1)
+#' expect_all_equal(x1, 1)
+#'
+#' x2 <- c(1, 1, 1, 2, 1, 1, 1, 1, 1, 1, 1, 2)
+#' show_failure(expect_all_equal(x2, 1))
+#'
+#' # expect_all_true() and expect_all_false() are helpers for common cases
+#' show_failure(expect_all_true(rpois(100, 10) < 20))
+#' show_failure(expect_all_false(rpois(100, 10) > 20))
+expect_all_equal <- function(object, expected) {
+  act <- quasi_label(enquo(object))
+  exp <- quasi_label(enquo(expected))
+
+  expect_all_equal_(act, exp)
+  invisible(act$val)
+}
+
+#' @export
+#' @rdname expect_all_equal
+expect_all_true <- function(object) {
+  act <- quasi_label(enquo(object))
+  exp <- labelled_value(TRUE, "TRUE")
+
+  expect_all_equal_(act, exp)
+  invisible(act$val)
+}
+
+#' @export
+#' @rdname expect_all_equal
+expect_all_false <- function(object) {
+  act <- quasi_label(enquo(object))
+  exp <- labelled_value(FALSE, "FALSE")
+
+  expect_all_equal_(act, exp)
+  invisible(act$val)
+}
+
+
+expect_all_equal_ <- function(act, exp, trace_env = caller_env()) {
+  check_vector(act$val, error_call = trace_env, error_arg = "object")
+  if (length(act$val) == 0) {
+    cli::cli_abort("{.arg object} must not be empty.", call = trace_env)
+  }
+
+  check_vector(exp$val, error_call = trace_env, error_arg = "expected")
+  if (length(exp$val) != 1) {
+    cli::cli_abort("{.arg expected} must be length 1.", call = trace_env)
+  }
+
+  exp$val <- rep(exp$val, length(act$val))
+  names(exp$val) <- names(act$val)
+  expect_waldo_equal_(
+    "Expected every element of %s to equal %s.",
+    act,
+    exp,
+    trace_env = trace_env
+  )
+}

R/expect-constant.R

@@ -12,17 +12,17 @@
 #' @examples
 #' expect_true(2 == 2)
 #' # Failed expectations will throw an error
-#' \dontrun{
-#' expect_true(2 != 2)
-#' }
-#' expect_true(!(2 != 2))
-#' # or better:
-#' expect_false(2 != 2)
+#' show_failure(expect_true(2 != 2))
 #'
-#' a <- 1:3
-#' expect_true(length(a) == 3)
-#' # but better to use more specific expectation, if available
-#' expect_equal(length(a), 3)
+#' # where possible, use more specific expectations, to get more informative
+#' # error messages
+#' a <- 1:4
+#' show_failure(expect_true(length(a) == 3))
+#' show_failure(expect_equal(length(a), 3))
+#' 
+#' x <- c(TRUE, TRUE, FALSE, TRUE)
+#' show_failure(expect_true(all(x)))
+#' show_failure(expect_all_true(x))
 #' @name logical-expectations
 NULL
 

_pkgdown.yml

@@ -27,6 +27,7 @@ reference:
 - title: Expectations
 - subtitle: Values
   contents:
+  - expect_all_equal
   - expect_gt
   - expect_length
   - expect_match

tests/testthat/_snaps/expect-all.md

@@ -0,0 +1,56 @@
+# validates its inputs
+
+    Code
+      expect_all_equal(mean, 1)
+    Condition
+      Error in `expect_all_equal()`:
+      ! `object` must be a vector, not a function.
+    Code
+      expect_all_equal(logical(), 1)
+    Condition
+      Error in `expect_all_equal()`:
+      ! `object` must not be empty.
+    Code
+      expect_all_equal(1:10, mean)
+    Condition
+      Error in `expect_all_equal()`:
+      ! `expected` must be a vector, not a function.
+    Code
+      expect_all_equal(1:10, 1:2)
+    Condition
+      Error in `expect_all_equal()`:
+      ! `expected` must be length 1.
+
+# can compare atomic vectors
+
+    Code
+      expect_all_equal(x, TRUE)
+    Condition
+      Error:
+      ! Expected every element of `x` to equal TRUE.
+      Differences:
+      `actual[2:8]`:   TRUE TRUE TRUE FALSE TRUE TRUE TRUE
+      `expected[2:8]`: TRUE TRUE TRUE TRUE  TRUE TRUE TRUE
+
+# can compare named lists
+
+    Code
+      expect_all_equal(x, list(1))
+    Condition
+      Error:
+      ! Expected every element of `x` to equal `list(1)`.
+      Differences:
+        `actual$c`: 2.0
+      `expected$c`: 1.0
+
+# truncates very long differences
+
+    Code
+      expect_all_equal(x, FALSE)
+    Condition
+      Error:
+      ! Expected every element of `x` to equal FALSE.
+      Differences:
+      `actual`:   TRUE  TRUE  TRUE  TRUE  TRUE  TRUE  TRUE  TRUE  TRUE  TRUE 
+      `expected`: FALSE FALSE FALSE FALSE FALSE FALSE FALSE FALSE FALSE FALSE
+

tests/testthat/test-expect-all.R

@@ -0,0 +1,33 @@
+test_that("validates its inputs", {
+  expect_snapshot(error = TRUE, {
+    expect_all_equal(mean, 1)
+    expect_all_equal(logical(), 1)
+    expect_all_equal(1:10, mean)
+    expect_all_equal(1:10, 1:2)
+  })
+})
+
+test_that("can compare atomic vectors", {
+  x <- rep(TRUE, 10)
+  expect_success(expect_all_equal(x, TRUE))
+
+  x[5] <- FALSE
+  expect_snapshot_failure(expect_all_equal(x, TRUE))
+})
+
+test_that("can compare named lists", {
+  x <- list(a = 1, b = 1, c = 2, d = 1, e = 1)
+  expect_snapshot_failure(expect_all_equal(x, list(1)))
+})
+
+test_that("truncates very long differences", {
+  x <- rep(TRUE, 10)
+  expect_snapshot_failure(expect_all_equal(x, FALSE))
+})
+
+test_that("has TRUE and FALSE helpers", {
+  x1 <- rep(TRUE, 10)
+  x2 <- rep(FALSE, 10)
+  expect_success(expect_all_true(x1))
+  expect_success(expect_all_false(x2))
+})