Add more informative feedback in expect_named()

NEWS.md

@@ -1,5 +1,6 @@
 # testthat (development version)
 
+* `expect_named()` now gives more informative errors (#2091).
 * `expect_*()` functions consistently and rigorously check their inputs (#1754). 
 * `JunitReporter()` no longer fails with `"no applicable method for xml_add_child"` for warnings outside of tests (#1913). Additionally, warnings now save their backtraces.
 * `JunitReporter()` strips ANSI escapes in more placese (#1852, #2032).

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,9 @@ expect_waldo_equal_ <- function(
       "`expected`",
       paste0(comp, collapse = "\n\n")
     )
+    if (!is.null(error_prefix)) {
+      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

@@ -33,11 +33,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,
@@ -48,7 +60,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)
+})