Bring expect_setequal() and friends up to code (#2145)

* Approved way of wrapping `expect_error()
* Modern style argument checking
* Use `testthat_warn`

Author: hadley

R/expect-equality.R

@@ -123,7 +123,7 @@ expect_waldo_equal_ <- function(
   type,
   act,
   exp,
-  info,
+  info = NULL,
   ...,
   trace_env = caller_env()
 ) {

R/expect-setequal.R

@@ -27,12 +27,10 @@ expect_setequal <- function(object, expected) {
   act <- quasi_label(enquo(object))
   exp <- quasi_label(enquo(expected))
 
-  if (!is_vector(act$val) || !is_vector(exp$val)) {
-    abort("`object` and `expected` must both be vectors")
-  }
-
+  check_vector(object)
+  check_vector(expected)
   if (!is.null(names(act$val)) && !is.null(names(exp$val))) {
-    warn("expect_setequal() ignores names")
+    testthat_warn("expect_setequal() ignores names")
   }
 
   act_miss <- unique(act$val[!act$val %in% exp$val])
@@ -79,24 +77,22 @@ expect_mapequal <- function(object, expected) {
   act <- quasi_label(enquo(object))
   exp <- quasi_label(enquo(expected))
 
-  if (!is_vector(act$val) || !is_vector(exp$val)) {
-    abort("`object` and `expected` must both be vectors")
-  }
+  check_vector(object)
+  check_map_names(object)
+  check_vector(expected)
+  check_map_names(expected)
 
   # Length-0 vectors are OK whether named or unnamed.
   if (length(act$val) == 0 && length(exp$val) == 0) {
-    warn("`object` and `expected` are empty lists")
+    testthat_warn("`object` and `expected` are empty lists")
     return(pass(act$val))
   }
 
   act_nms <- names(act$val)
   exp_nms <- names(exp$val)
-
-  check_names_ok(act_nms, "object")
-  check_names_ok(exp_nms, "expected")
-
   if (setequal(act_nms, exp_nms)) {
-    return(expect_equal(act$val[exp_nms], exp$val))
+    act <- labelled_value(act$val[exp_nms], act$lab)
+    return(expect_waldo_equal_("equal", act, exp))
   }
 
   act_miss <- setdiff(exp_nms, act_nms)
@@ -114,27 +110,16 @@ expect_mapequal <- function(object, expected) {
   pass(act$val)
 }
 
-check_names_ok <- function(x, label) {
-  if (anyDuplicated(x)) {
-    stop("Duplicate names in `", label, "`: ", unique(x[duplicated(x)]))
-  }
-  if (any(x == "")) {
-    stop("All elements in `", label, "` must be named")
-  }
-}
-
 #' @export
 #' @rdname expect_setequal
 expect_contains <- function(object, expected) {
   act <- quasi_label(enquo(object))
   exp <- quasi_label(enquo(expected))
 
-  if (!is_vector(act$val) || !is_vector(exp$val)) {
-    abort("`object` and `expected` must both be vectors")
-  }
+  check_vector(object)
+  check_vector(expected)
 
   exp_miss <- !exp$val %in% act$val
-
   if (any(exp_miss)) {
     return(fail(paste0(
       act$lab,
@@ -155,12 +140,10 @@ expect_in <- function(object, expected) {
   act <- quasi_label(enquo(object))
   exp <- quasi_label(enquo(expected))
 
-  if (!is_vector(act$val) || !is_vector(exp$val)) {
-    abort("`object` and `expected` must both be vectors")
-  }
+  check_vector(object)
+  check_vector(expected)
 
   act_miss <- !act$val %in% exp$val
-
   if (any(act_miss)) {
     return(fail(paste0(
       act$lab,
@@ -174,3 +157,44 @@ expect_in <- function(object, expected) {
 
   pass(act$val)
 }
+
+# Helpers ----------------------------------------------------------------------
+
+check_map_names <- function(
+  x,
+  error_arg = caller_arg(x),
+  error_call = caller_env()
+) {
+  nms <- names2(x)
+
+  if (anyDuplicated(nms)) {
+    dups <- unique(nms[duplicated(nms)])
+    cli::cli_abort(
+      c(
+        "All elements in {.arg {error_arg}} must have unique names.",
+        x = "Duplicate names: {.str {dups}}"
+      ),
+      call = error_call
+    )
+  }
+  if (any(nms == "")) {
+    empty <- which(nms == "")
+    cli::cli_abort(
+      c(
+        "All elements in {.arg {error_arg}} must have names.",
+        x = "Empty names at position{?s}: {empty}"
+      ),
+      call = error_call
+    )
+  }
+}
+
+check_vector <- function(
+  x,
+  error_arg = caller_arg(x),
+  error_call = caller_env()
+) {
+  if (!is_vector(x)) {
+    stop_input_type(x, "a vector", arg = error_arg, call = error_call)
+  }
+}

tests/testthat/_snaps/expect-setequal.md

@@ -1,3 +1,16 @@
+# checks inputs
+
+    Code
+      expect_setequal(sum, 1)
+    Condition
+      Error in `expect_setequal()`:
+      ! `object` must be a vector, not a primitive function.
+    Code
+      expect_setequal(1, sum)
+    Condition
+      Error in `expect_setequal()`:
+      ! `expected` must be a vector, not a primitive function.
+
 # useful message on failure
 
     "actual" (`actual`) and "expected" (`expected`) don't have the same values.
@@ -37,6 +50,43 @@
     * Only in `expected`: 3, 4, 5, 6, 7, 8, 9, 10, 11, ...
 
 
+# check inputs
+
+    Code
+      expect_mapequal(sum, named)
+    Condition
+      Error in `expect_mapequal()`:
+      ! `object` must be a vector, not a primitive function.
+    Code
+      expect_mapequal(named, sum)
+    Condition
+      Error in `expect_mapequal()`:
+      ! `expected` must be a vector, not a primitive function.
+    Code
+      expect_mapequal(unnamed, named)
+    Condition
+      Error in `expect_mapequal()`:
+      ! All elements in `object` must have names.
+      x Empty names at position: 1
+    Code
+      expect_mapequal(named, unnamed)
+    Condition
+      Error in `expect_mapequal()`:
+      ! All elements in `expected` must have names.
+      x Empty names at position: 1
+    Code
+      expect_mapequal(named, duplicated)
+    Condition
+      Error in `expect_mapequal()`:
+      ! All elements in `expected` must have unique names.
+      x Duplicate names: "x"
+    Code
+      expect_mapequal(duplicated, named)
+    Condition
+      Error in `expect_mapequal()`:
+      ! All elements in `object` must have unique names.
+      x Duplicate names: "x"
+
 # expect_contains() gives useful message on failure
 
     `x1` (`actual`) doesn't fully contain all the values in `x2` (`expected`).

tests/testthat/test-expect-setequal.R

@@ -25,8 +25,11 @@ test_that("warns if both inputs are named", {
   expect_warning(expect_setequal(c(a = 1), c(b = 1)), "ignores names")
 })
 
-test_that("error for non-vectors", {
-  expect_error(expect_setequal(sum, sum), "be vectors")
+test_that("checks inputs", {
+  expect_snapshot(error = TRUE, {
+    expect_setequal(sum, 1)
+    expect_setequal(1, sum)
+  })
 })
 
 test_that("useful message on failure", {
@@ -72,14 +75,21 @@ test_that("fails if values don't match", {
   expect_failure(expect_mapequal(list(a = 1, b = 2), list(a = 1, b = 3)))
 })
 
-test_that("error for non-vectors", {
-  expect_error(expect_mapequal(sum, sum), "be vectors")
-  expect_error(expect_mapequal(NULL, NULL), "be vectors")
-})
+test_that("check inputs", {
+  unnamed <- list(1)
+  named <- list(a = 1)
+  duplicated <- list(x = 1, x = 2)
+
+  expect_snapshot(error = TRUE, {
+    expect_mapequal(sum, named)
+    expect_mapequal(named, sum)
+
+    expect_mapequal(unnamed, named)
+    expect_mapequal(named, unnamed)
 
-test_that("error if any unnamed values", {
-  expect_error(expect_mapequal(list(1, b = 2), list(1, b = 2)))
-  expect_error(expect_mapequal(list(1, b = 2), list(b = 2, 1)))
+    expect_mapequal(named, duplicated)
+    expect_mapequal(duplicated, named)
+  })
 })
 
 test_that("succeeds if comparing empty named and unnamed vectors", {