Merged origin/main into new-snapshot-fail-on-ci

Author: hadley

NAMESPACE

@@ -192,6 +192,7 @@ export(skip_on_os)
 export(skip_on_travis)
 export(skip_unless_r)
 export(snapshot_accept)
+export(snapshot_reject)
 export(snapshot_review)
 export(source_dir)
 export(source_file)

NEWS.md

@@ -1,5 +1,13 @@
 # testthat (development version)
 
+* `local_mock()` and `with_mock()` have been deprecated because they are no longer permitted in R 4.5.
+* `snapshot_review()` now passes `...` on to `shiny::runApp()` (#1928).
+* `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).
+* New `snapshot_reject()` rejects all modified snapshots by deleting the `.new` variants (#1923).
 * New `SlowReporter` makes it easier to find the slowest tests in your package. The easiest way to run it is with `devtools::test(reporter = "slow")` (#1466).
 * Power `expect_mapequal()` with `waldo::compare(list_as_map = TRUE)` (#1521).
 * On CRAN, `test_that()` now automatically skips if a package is not installed (#1585). Practically, this means that you no longer need to check that suggested packages are installed. (We don't do this in the tidyverse because we think it has limited payoff, but other styles advise differently.)

R/describe.R

@@ -60,7 +60,8 @@
 describe <- function(description, code) {
   local_description_push(description)
 
-  test_code(code, parent.frame(), skip_on_empty = FALSE)
+  code <- substitute(code)
+  test_code(code, parent.frame())
 }
 
 #' @export
@@ -69,5 +70,5 @@ it <- function(description, code = NULL) {
   local_description_push(description)
 
   code <- substitute(code)
-  test_code(code, env = parent.frame(), skip_on_empty = FALSE)
+  test_code(code, parent.frame())
 }

R/edition.R

@@ -27,8 +27,8 @@ edition_deprecate <- function(in_edition, what, instead = NULL) {
     return()
   }
 
-  warn(c(
-    paste0("`", what, "` was deprecated in ", edition_name(in_edition), "."),
+  cli::cli_warn(c(
+    "{.code {what}} was deprecated in {edition_name(in_edition)}.",
     i = instead
   ))
 }
@@ -40,7 +40,7 @@ edition_require <- function(in_edition, what) {
     return()
   }
 
-  stop(paste0("`", what, "` requires ", edition_name(in_edition), "."))
+  cli::cli_abort("{.code {what}} requires {edition_name(in_edition)}.")
 }
 
 edition_name <- function(x) {

R/expect-comparison.R

@@ -39,8 +39,8 @@ expect_compare_ <- function(
 
   cmp <- op(act$val, exp$val)
   if (length(cmp) != 1 || !is.logical(cmp)) {
-    abort(
-      "Result of comparison must be a single logical value",
+    cli::cli_abort(
+      "Result of comparison must be a single logical value.",
       call = trace_env
     )
   }
@@ -112,14 +112,14 @@ expect_gte <- function(object, expected, label = NULL, expected.label = NULL) {
 #' @param ... All arguments passed on to `expect_lt()`/`expect_gt()`.
 #' @keywords internal
 expect_less_than <- function(...) {
-  warning("Deprecated: please use `expect_lt()` instead", call. = FALSE)
+  cli::cli_warn("Deprecated: please use {.fn expect_lt} instead.")
   expect_lt(...)
 }
 
 #' @rdname expect_less_than
 #' @export
 expect_more_than <- function(...) {
-  warning("Deprecated: please use `expect_gt()` instead", call. = FALSE)
+  cli::cli_warn("Deprecated: please use {.fn expect_gt} instead.")
   expect_gt(...)
 }
 

R/expect-condition.R

@@ -169,7 +169,7 @@ expect_warning <- function(
 
   if (edition_get() >= 3) {
     if (!missing(all)) {
-      warn("The `all` argument is deprecated")
+      cli::cli_warn("The {.arg all} argument is deprecated.")
     }
 
     expect_condition_matching_(

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-known.R

@@ -79,7 +79,7 @@ expect_known_output <- function(
 
 compare_file <- function(path, lines, ..., update = TRUE, info = NULL) {
   if (!file.exists(path)) {
-    warning("Creating reference output", call. = FALSE)
+    cli::cli_warn("Creating reference output.")
     brio::write_lines(lines, path)
     return(pass(NULL))
   }
@@ -88,11 +88,11 @@ compare_file <- function(path, lines, ..., update = TRUE, info = NULL) {
   if (update) {
     brio::write_lines(lines, path)
     if (!all_utf8(lines)) {
-      warning("New reference output is not UTF-8 encoded", call. = FALSE)
+      cli::cli_warn("New reference output is not UTF-8 encoded.")
     }
   }
   if (!all_utf8(old_lines)) {
-    warning("Reference output is not UTF-8 encoded", call. = FALSE)
+    cli::cli_warn("Reference output is not UTF-8 encoded.")
   }
 
   comp <- waldo_compare(
@@ -178,7 +178,7 @@ expect_known_value <- function(
   act <- quasi_label(enquo(object), label)
 
   if (!file.exists(file)) {
-    warning("Creating reference value", call. = FALSE)
+    cli::cli_warn("Creating reference value.")
     saveRDS(object, file, version = version)
   } else {
     ref_val <- readRDS(file)
@@ -232,7 +232,7 @@ expect_known_hash <- function(object, hash = NULL) {
   }
 
   if (is.null(hash)) {
-    warning(paste0("No recorded hash: use ", substr(act_hash, 1, 10)))
+    cli::cli_warn("No recorded hash: use {substr(act_hash, 1, 10)}.")
   } else {
     if (hash != act_hash) {
       msg <- sprintf("Value hashes to %s, not %s", act_hash, hash)

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)
 }
@@ -131,35 +144,6 @@ expect_in <- function(object, expected) {
 
 # 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),