diff --git a/R/expect-equality.R b/R/expect-equality.R index 31a668a6e..f3345ca18 100644 --- a/R/expect-equality.R +++ b/R/expect-equality.R @@ -123,7 +123,7 @@ expect_waldo_equal_ <- function( type, act, exp, - info, + info = NULL, ..., trace_env = caller_env() ) { diff --git a/R/expect-setequal.R b/R/expect-setequal.R index 2b42b78d7..87f6556da 100644 --- a/R/expect-setequal.R +++ b/R/expect-setequal.R @@ -27,12 +27,10 @@ expect_setequal <- function(object, expected) { act <- quasi_label(enquo(object), arg = "object") exp <- quasi_label(enquo(expected), arg = "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), arg = "object") exp <- quasi_label(enquo(expected), arg = "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), arg = "object") exp <- quasi_label(enquo(expected), arg = "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), arg = "object") exp <- quasi_label(enquo(expected), arg = "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) + } +} diff --git a/tests/testthat/_snaps/expect-setequal.md b/tests/testthat/_snaps/expect-setequal.md index 87ccd0fe9..944d87485 100644 --- a/tests/testthat/_snaps/expect-setequal.md +++ b/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`). diff --git a/tests/testthat/test-expect-setequal.R b/tests/testthat/test-expect-setequal.R index 96c8ae569..0617eabf7 100644 --- a/tests/testthat/test-expect-setequal.R +++ b/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", {