Add more informative feedback in expect_named() (#2130)

Fixes #2091. Fixes #1558.

Author: EmilHvitfeldt

NEWS.md

@@ -1,5 +1,7 @@
 # testthat (development version)
 
+* `expect_named()` now gives more informative errors (#2091).
+* `expect_*()` functions consistently and rigorously check their inputs (#1754). 
 * `test_that()` no longer warns about the absence of `{}` since it no longer seems to be necessary.
 * `test_that()`, `describe()`, and `it()` can now be arbitrarily nested. Each component will skip only if it and its subtests don't contain any expectations. The interactive stop reporter has been fixed so it doesn't duplicate failures. (#2063, #2188).
 * Test filtering now works with `it()`, and the `desc` argument can take a character vector in order to recursively filter subtests (i.e. `it()` nested inside of `describe()`) (#2118).

R/expect-equality.R

@@ -126,7 +126,8 @@ expect_waldo_equal_ <- function(
   exp,
   info = NULL,
   ...,
-  trace_env = caller_env()
+  trace_env = caller_env(),
+  error_prefix = NULL
 ) {
   comp <- waldo_compare(
     act$val,
@@ -145,6 +146,7 @@ expect_waldo_equal_ <- function(
       "`expected`",
       paste0(comp, collapse = "\n\n")
     )
+    msg <- paste0(error_prefix, msg)
     return(fail(msg, info = info, trace_env = trace_env))
   }
   pass(act$val)

R/expect-named.R

@@ -36,27 +36,24 @@ expect_named <- function(
   check_bool(ignore.case)
 
   act <- quasi_label(enquo(object), label)
-  act$names <- names(act$val)
 
   if (missing(expected)) {
-    if (identical(act$names, NULL)) {
-      msg <- sprintf("%s does not have names.", act$lab)
-      return(fail(msg))
-    }
-  } else {
-    exp_names <- normalise_names(expected, ignore.order, ignore.case)
-    act$names <- normalise_names(act$names, ignore.order, ignore.case)
+    return(expect_has_names_(act))
+  }
+
+  exp <- quasi_label(enquo(expected), arg = "expected")
 
-    if (!identical(act$names, exp_names)) {
-      msg <- sprintf(
-        "Names of %s (%s) don't match %s",
-        act$lab,
-        paste0("'", act$names, "'", collapse = ", "),
-        paste0("'", exp_names, "'", collapse = ", ")
-      )
-      return(fail(msg, info = info))
-    }
+  exp$val <- normalise_names(exp$val, ignore.order, ignore.case)
+  act_names <- normalise_names(names(act$val), ignore.order, ignore.case)
+
+  if (ignore.order) {
+    act <- labelled_value(act_names, act$lab)
+    return(expect_setequal_(act, exp, error_prefix = "Names of "))
+  } else {
+    act <- labelled_value(act_names, act$lab)
+    return(expect_waldo_equal_("equal", act, exp, error_prefix = "Names of "))
   }
+
   pass(act$val)
 }
 
@@ -74,3 +71,12 @@ 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 (identical(act_names, NULL)) {
+    msg <- sprintf("%s does not have names.", act$lab)
+    return(fail(msg, trace_env = trace_env))
+  }
+  return(pass(act$val))
+}

R/expect-setequal.R

@@ -34,11 +34,23 @@ expect_setequal <- function(object, expected) {
     testthat_warn("expect_setequal() ignores names")
   }
 
+  expect_setequal_(act, exp)
+}
+
+expect_setequal_ <- function(
+  act,
+  exp,
+  trace_env = caller_env(),
+  error_prefix = NULL
+) {
   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)) {
-    return(fail(paste0(
+    msg <- paste0(
+      if (!is.null(error_prefix)) {
+        error_prefix
+      },
       act$lab,
       " (`actual`) and ",
       exp$lab,
@@ -49,7 +61,8 @@ expect_setequal <- function(object, expected) {
       if (length(exp_miss)) {
         paste0("* Only in `expected`: ", values(exp_miss), "\n")
       }
-    )))
+    )
+    return(fail(msg, trace_env = trace_env))
   }
   pass(act$val)
 }

tests/testthat/_snaps/expect-named.md

@@ -1,3 +1,43 @@
+# provide useful feedback on failure
+
+    Names of c(a = 1) (`actual`) and c("a", "b") (`expected`) don't have the same values.
+    * Only in `expected`: "b"
+    
+
+---
+
+    Names of c(a = 1, b = 1) (`actual`) and c("a") (`expected`) don't have the same values.
+    * Only in `actual`: "b"
+    
+
+---
+
+    Names of c(a = 1) (`actual`) and c("b") (`expected`) don't have the same values.
+    * Only in `actual`: "a"
+    * Only in `expected`: "b"
+    
+
+---
+
+    Names of c(a = 1) (`actual`) is not equal to c("a", "b") (`expected`).
+    
+    `actual`:   "a"    
+    `expected`: "a" "b"
+
+---
+
+    Names of c(a = 1, b = 1) (`actual`) is not equal to c("a") (`expected`).
+    
+    `actual`:   "a" "b"
+    `expected`: "a"    
+
+---
+
+    Names of c(a = 1) (`actual`) is not equal to c("b") (`expected`).
+    
+    `actual`:   "a"
+    `expected`: "b"
+
 # expect_named validates its inputs
 
     Code

tests/testthat/test-expect-named.R

@@ -20,9 +20,41 @@ test_that("expected_named optionally ignores order", {
   ))
 })
 
+test_that("provide useful feedback on failure", {
+  expect_snapshot_error(
+    expect_named(c(a = 1), c("a", "b"), ignore.order = TRUE)
+  )
+  expect_snapshot_error(
+    expect_named(c(a = 1, b = 1), c("a"), ignore.order = TRUE)
+  )
+  expect_snapshot_error(
+    expect_named(c(a = 1), c("b"), ignore.order = TRUE)
+  )
+
+  expect_snapshot_error(
+    expect_named(c(a = 1), c("a", "b"), ignore.order = FALSE)
+  )
+  expect_snapshot_error(
+    expect_named(c(a = 1, b = 1), c("a"), ignore.order = FALSE)
+  )
+  expect_snapshot_error(
+    expect_named(c(a = 1), c("b"), ignore.order = FALSE)
+  )
+})
+
 test_that("expect_named validates its inputs", {
   expect_snapshot(error = TRUE, {
     expect_named(c(a = 1), "a", ignore.order = "yes")
     expect_named(c(a = 1), "a", ignore.case = "yes")
   })
 })
+
+test_that("expect_named accepts glue for 'expected'", {
+  n <- structure(
+    c("v1", "v2", "v3", "v4", "v5"),
+    class = c("glue", "character")
+  )
+  v <- set_names(1:5, n)
+
+  expect_named(v, n)
+})