WIP on expect_all_equal()

Fixes #1836. Fixes #2235

Author: hadley

R/expect-all.R

@@ -0,0 +1,20 @@
+expect_all_equal <- function(object, expected) {
+  act <- quasi_label(enquo(object))
+  exp <- quasi_label(enquo(expected))
+
+  check_vector(act$val, error_arg = "object")
+  if (length(act$val) == 0) {
+    cli::cli_abort("{.arg object} must not be empty.")
+  }
+
+  check_vector(exp$val, error_arg = "expected")
+  if (length(exp$val) != 1) {
+    cli::cli_abort("{.arg expected} must be length 1.")
+  }
+
+  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)
+
+  invisible(act$val)
+}

R/expect-match.R

@@ -120,7 +120,12 @@ expect_match_ <- function(
   ok <- if (all) all(condition) else any(condition)
 
   if (!ok) {
-    values <- show_text(act$val, condition)
+    labels <- ifelse(
+      condition,
+      cli::col_green(cli::symbol$tick),
+      cli::col_red(cli::symbol$cross)
+    )
+    values <- show_text(act$val, labels)
     if (length(act$val) == 1) {
       which <- ""
     } else {
@@ -144,15 +149,15 @@ expect_match_ <- function(
 }
 
 # Adapted from print.ellmer_prompt
-show_text <- function(x, matches = NULL, max_items = 20, max_lines = NULL) {
-  matches <- matches %||% rep(TRUE, length(x))
+show_text <- function(x, labels = NULL, max_items = 20, max_lines = NULL) {
+  labels <- labels %||% seq_along(x)
   max_lines <- max_lines %||% (max_items * 25)
 
   n <- length(x)
   n_extra <- length(x) - max_items
   if (n_extra > 0) {
     x <- x[seq_len(max_items)]
-    matches <- matches[seq_len(max_items)]
+    labels <- labels[seq_len(max_items)]
   }
 
   if (length(x) == 0) {
@@ -161,13 +166,7 @@ show_text <- function(x, matches = NULL, max_items = 20, max_lines = NULL) {
 
   bar <- if (cli::is_utf8_output()) "\u2502" else "|"
 
-  id <- ifelse(
-    matches,
-    cli::col_green(cli::symbol$tick),
-    cli::col_red(cli::symbol$cross)
-  )
-
-  indent <- paste0(id, " ", bar, " ")
+  indent <- paste0(labels, " ", bar, " ")
   exdent <- paste0("  ", cli::col_grey(bar), " ")
 
   x[is.na(x)] <- cli::col_red("<NA>")

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 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/_snaps/expect-match.md

@@ -149,45 +149,37 @@
       Actual text:
       x | test
 
-# show_text() shows success and failure
-
-    Code
-      base::writeLines(show_text(c("a", "b"), c(TRUE, FALSE)))
-    Output
-      ✔ │ a
-      ✖ │ b
-
 # show_text() truncates values and lines
 
     Code
       base::writeLines(show_text(lines, max_lines = 3))
     Output
-      ✔ │ a
+      1 │ a
         │ b
         │ ...
       ... and 8 more.
       
     Code
       base::writeLines(show_text(lines, max_items = 3))
     Output
-      ✔ │ a
+      1 │ a
         │ b
         │ c
-      ✔ │ d
+      2 │ d
         │ e
         │ f
-      ✔ │ g
+      3 │ g
         │ h
         │ i
       ... and 6 more.
       
     Code
       base::writeLines(show_text(lines, max_items = 2, max_lines = 4))
     Output
-      ✔ │ a
+      1 │ a
         │ b
         │ c
-      ✔ │ d
+      2 │ d
         │ ...
       ... and 8 more.
       

tests/testthat/test-expect-all.R

@@ -0,0 +1,26 @@
+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 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))
+})

tests/testthat/test-expect-match.R

@@ -69,13 +69,6 @@ test_that("empty string is never a match", {
 
 # show_text() ------------------------------------------------------------------
 
-test_that("show_text() shows success and failure", {
-  local_reproducible_output(unicode = TRUE)
-  expect_snapshot({
-    base::writeLines(show_text(c("a", "b"), c(TRUE, FALSE)))
-  })
-})
-
 test_that("show_text() truncates values and lines", {
   local_reproducible_output(unicode = TRUE)
   lines <- map_chr(