Merge branch 'main' into parallel-max-fail

Author: hadley

NAMESPACE

@@ -114,6 +114,7 @@ export(expect_no_warning)
 export(expect_null)
 export(expect_output)
 export(expect_output_file)
+export(expect_r6_class)
 export(expect_reference)
 export(expect_s3_class)
 export(expect_s4_class)

NEWS.md

@@ -1,6 +1,8 @@
 # testthat (development version)
 
 * `ParallelProgressReporter` now respect `max_failures` (#1162).
+* New `expect_r6_class()` (#2030).
+* `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).
 * `try_again()` is now publicised. The first argument is now the number of retries, not tries (#2050).

R/auto-test.R

@@ -1,24 +1,18 @@
 #' Watches code and tests for changes, rerunning tests as appropriate.
 #'
+#' @description
+#' `r lifecycle::badge("superseded")`
+#'
 #' The idea behind `auto_test()` is that you just leave it running while
 #' you develop your code.  Every time you save a file it will be automatically
 #' tested and you can easily see if your changes have caused any test
-#'  failures.
+#' failures.
 #'
 #' The current strategy for rerunning tests is as follows:
 #'
 #' - if any code has changed, then those files are reloaded and all tests
 #'   rerun
 #' - otherwise, each new or modified test is run
-#'
-#' In the future, `auto_test()` might implement one of the following more
-#' intelligent alternatives:
-#'
-#' - Use codetools to build up dependency tree and then rerun tests only
-#'   when a dependency changes.
-#' - Mimic ruby's autotest and rerun only failing tests until they pass,
-#'   and then rerun all tests.
-#
 #' @seealso [auto_test_package()]
 #' @export
 #' @param code_path path to directory containing code
@@ -27,7 +21,7 @@
 #' @param env environment in which to execute test suite.
 #' @param hash Passed on to [watch()]. When FALSE, uses less accurate
 #'   modification time stamps, but those are faster for large files.
-#' @keywords debugging
+#' @keywords internal
 auto_test <- function(
   code_path,
   test_path,
@@ -67,15 +61,12 @@ auto_test <- function(
   watch(c(code_path, test_path), watcher, hash = hash)
 }
 
-#' Watches a package for changes, rerunning tests as appropriate.
-#'
 #' @param pkg path to package
 #' @export
 #' @param reporter test reporter to use
 #' @param hash Passed on to [watch()].  When FALSE, uses less accurate
 #'   modification time stamps, but those are faster for large files.
-#' @keywords debugging
-#' @seealso [auto_test()] for details on how method works
+#' @rdname auto_test
 auto_test_package <- function(
   pkg = ".",
   reporter = default_reporter(),

R/compare.R

@@ -16,8 +16,8 @@ compare <- function(x, y, ...) {
 }
 
 comparison <- function(equal = TRUE, message = "Equal") {
-  stopifnot(is.logical(equal), length(equal) == 1)
-  stopifnot(is.character(message))
+  check_bool(equal)
+  check_character(message)
 
   structure(
     list(

R/expect-condition.R

@@ -114,6 +114,10 @@ expect_error <- function(
   info = NULL,
   label = NULL
 ) {
+  check_string(regexp, allow_null = TRUE, allow_na = TRUE)
+  check_string(class, allow_null = TRUE)
+  check_bool(inherit)
+
   if (edition_get() >= 3) {
     expect_condition_matching_(
       "error",
@@ -158,6 +162,11 @@ expect_warning <- function(
   info = NULL,
   label = NULL
 ) {
+  check_string(regexp, allow_null = TRUE, allow_na = TRUE)
+  check_string(class, allow_null = TRUE)
+  check_bool(inherit)
+  check_bool(all)
+
   if (edition_get() >= 3) {
     if (!missing(all)) {
       warn("The `all` argument is deprecated")
@@ -207,6 +216,11 @@ expect_message <- function(
   info = NULL,
   label = NULL
 ) {
+  check_string(regexp, allow_null = TRUE, allow_na = TRUE)
+  check_string(class, allow_null = TRUE)
+  check_bool(inherit)
+  check_bool(all)
+
   if (edition_get() >= 3) {
     expect_condition_matching_(
       "message",
@@ -239,6 +253,10 @@ expect_condition <- function(
   info = NULL,
   label = NULL
 ) {
+  check_string(regexp, allow_null = TRUE, allow_na = TRUE)
+  check_string(class, allow_null = TRUE)
+  check_bool(inherit)
+
   if (edition_get() >= 3) {
     expect_condition_matching_(
       "condition",

R/expect-equality.R

@@ -65,6 +65,7 @@ expect_equal <- function(
 ) {
   act <- quasi_label(enquo(object), label)
   exp <- quasi_label(enquo(expected), expected.label)
+  check_number_decimal(tolerance, min = 0, allow_null = TRUE)
 
   if (edition_get() >= 3) {
     expect_waldo_equal_("equal", act, exp, info, ..., tolerance = tolerance)

R/expect-inheritance.R

@@ -12,15 +12,24 @@
 #' * `expect_s4_class(x, class)` checks that `x` is an S4 object that
 #'   [is()] `class`.
 #' * `expect_s4_class(x, NA)` checks that `x` isn't an S4 object.
+#' * `expect_r6_class(x, class)` checks that `x` an R6 object that
+#'   inherits from `class`.
 #' * `expect_s7_class(x, Class)` checks that `x` is an S7 object that
 #'   [S7::S7_inherits()] from `Class`
 #'
 #' See [expect_vector()] for testing properties of objects created by vctrs.
 #'
 #' @param type String giving base type (as returned by [typeof()]).
-#' @param class Either a character vector of class names, or
-#'  for `expect_s3_class()` and `expect_s4_class()`, an `NA` to assert
-#'  that `object` isn't an S3 or S4 object.
+#' @param class
+#'  * `expect_type()`: a single string giving an R base type.
+#'  * `expect_s3_class()`: a character vector of class names or `NA` to assert
+#'    that `object` isn't an S3 object. If you provide multiple class names,
+#'    the test will pass if `object` inherits from any of them, unless
+#'    `exact = TRUE`.
+#'  * `expect_s4_class()`: a character vector of class names or `NA` to assert
+#'    that `object` isn't an S4 object.
+#'  * `expect_r6_class()`: a string.
+#'  * `expect_s7_class()`: an [S7::S7_class()] object.
 #' @inheritParams expect_that
 #' @family expectations
 #' @examples
@@ -31,6 +40,15 @@
 #' # A data frame is built from a list:
 #' expect_type(x, "list")
 #'
+#' f <- factor(c("a", "b", "c"))
+#' o <- ordered(f)
+#'
+#' # Using multiple class names tests if the object inherits from any of them
+#' expect_s3_class(f, c("ordered", "factor"))
+#' # Use exact = TRUE to test for exact match
+#' show_failure(expect_s3_class(f, c("ordered", "factor"), exact = TRUE))
+#' expect_s3_class(o, c("ordered", "factor"), exact = TRUE)
+#'
 #' # An integer vector is an atomic vector of type "integer"
 #' expect_type(x$x, "integer")
 #' # It is not an S3 object
@@ -46,7 +64,7 @@ NULL
 #' @export
 #' @rdname inheritance-expectations
 expect_type <- function(object, type) {
-  stopifnot(is.character(type), length(type) == 1)
+  check_string(type)
 
   act <- quasi_label(enquo(object))
   act_type <- typeof(act$val)
@@ -66,9 +84,11 @@ expect_type <- function(object, type) {
 #' @export
 #' @rdname inheritance-expectations
 #' @param exact If `FALSE`, the default, checks that `object` inherits
-#'   from `class`. If `TRUE`, checks that object has a class that's identical
-#'   to `class`.
+#'   from any element of `class`. If `TRUE`, checks that object has a class
+#'   that's identical to `class`.
 expect_s3_class <- function(object, class, exact = FALSE) {
+  check_bool(exact)
+
   act <- quasi_label(enquo(object))
   act$class <- format_class(class(act$val))
   exp_lab <- format_class(class)
@@ -98,36 +118,7 @@ expect_s3_class <- function(object, class, exact = FALSE) {
       }
     }
   } else {
-    abort("`class` must be a NA or a character vector")
-  }
-
-  pass(act$val)
-}
-
-#' @export
-#' @rdname inheritance-expectations
-expect_s7_class <- function(object, class) {
-  check_installed("S7")
-  if (!inherits(class, "S7_class")) {
-    stop_input_type(class, "an S7 class object")
-  }
-
-  act <- quasi_label(enquo(object))
-
-  if (!S7::S7_inherits(object)) {
-    return(fail(sprintf("%s is not an S7 object", act$lab)))
-  }
-
-  if (!S7::S7_inherits(object, class)) {
-    obj_class <- setdiff(base::class(object), "S7_object")
-    class_desc <- paste0("<", obj_class, ">", collapse = "/")
-    msg <- sprintf(
-      "%s inherits from %s not <%s>.",
-      act$lab,
-      class_desc,
-      attr(class, "name", TRUE)
-    )
-    return(fail(msg))
+    stop_input_type(class, c("a character vector", "NA"))
   }
 
   pass(act$val)
@@ -160,13 +151,60 @@ expect_s4_class <- function(object, class) {
       }
     }
   } else {
-    abort("`class` must be a NA or a character vector")
+    stop_input_type(class, c("a character vector", "NA"))
   }
 
   pass(act$val)
 }
 
-isS3 <- function(x) is.object(x) && !isS4(x)
+#' @export
+#' @rdname inheritance-expectations
+expect_r6_class <- function(object, class) {
+  act <- quasi_label(enquo(object))
+  check_string(class)
+
+  if (!inherits(act$val, "R6")) {
+    return(fail(sprintf("%s is not an R6 object.", act$lab)))
+  }
+
+  if (!inherits(act$val, class)) {
+    act_class <- format_class(class(act$val))
+    exp_class <- format_class(class)
+    msg <- sprintf("%s inherits from %s not %s.", act$lab, act_class, exp_class)
+    return(fail(msg))
+  }
+
+  pass(act$val)
+}
+
+#' @export
+#' @rdname inheritance-expectations
+expect_s7_class <- function(object, class) {
+  check_installed("S7")
+  if (!inherits(class, "S7_class")) {
+    stop_input_type(class, "an S7 class object")
+  }
+
+  act <- quasi_label(enquo(object))
+
+  if (!S7::S7_inherits(object)) {
+    return(fail(sprintf("%s is not an S7 object", act$lab)))
+  }
+
+  if (!S7::S7_inherits(object, class)) {
+    obj_class <- setdiff(base::class(object), "S7_object")
+    class_desc <- paste0("<", obj_class, ">", collapse = "/")
+    msg <- sprintf(
+      "%s inherits from %s not <%s>.",
+      act$lab,
+      class_desc,
+      attr(class, "name", TRUE)
+    )
+    return(fail(msg))
+  }
+
+  pass(act$val)
+}
 
 #' Does an object inherit from a given class?
 #'
@@ -175,19 +213,20 @@ isS3 <- function(x) is.object(x) && !isS4(x)
 #'
 #' `expect_is()` is an older form that uses [inherits()] without checking
 #' whether `x` is S3, S4, or neither. Instead, I'd recommend using
-#' [expect_type()], [expect_s3_class()] or [expect_s4_class()] to more clearly
-#' convey your  intent.
+#' [expect_type()], [expect_s3_class()], or [expect_s4_class()] to more clearly
+#' convey your intent.
 #'
 #' @section 3rd edition:
 #' `r lifecycle::badge("deprecated")`
 #'
 #' `expect_is()` is formally deprecated in the 3rd edition.
 #'
 #' @keywords internal
+#' @param class Class name passed to `inherits()`.
 #' @inheritParams expect_type
 #' @export
 expect_is <- function(object, class, info = NULL, label = NULL) {
-  stopifnot(is.character(class))
+  check_character(class)
   edition_deprecate(
     3,
     "expect_is()",
@@ -210,6 +249,9 @@ expect_is <- function(object, class, info = NULL, label = NULL) {
   pass(act$val)
 }
 
+# Helpers ----------------------------------------------------------------------
+
+isS3 <- function(x) is.object(x) && !isS4(x)
 
 format_class <- function(x) {
   paste0(encodeString(x, quote = "'"), collapse = "/")

R/expect-known.R

@@ -58,6 +58,10 @@ expect_known_output <- function(
   print = FALSE,
   width = 80
 ) {
+  check_string(file)
+  check_bool(update)
+  check_bool(print)
+  check_number_whole(width, min = 1)
   edition_deprecate(
     3,
     "expect_known_output()",
@@ -131,6 +135,10 @@ expect_output_file <- function(
   print = FALSE,
   width = 80
 ) {
+  check_string(file)
+  check_bool(update)
+  check_bool(print)
+  check_number_whole(width, min = 1)
   # Code is a copy of expect_known_output()
   edition_deprecate(
     3,
@@ -158,6 +166,9 @@ expect_known_value <- function(
   label = NULL,
   version = 2
 ) {
+  check_string(file)
+  check_bool(update)
+  check_number_whole(version, min = 1)
   edition_deprecate(
     3,
     "expect_known_value()",

R/expect-length.R

@@ -14,7 +14,7 @@
 #' expect_length(1:10, 1)
 #' }
 expect_length <- function(object, n) {
-  stopifnot(is.numeric(n), length(n) == 1)
+  check_number_whole(n, min = 0)
 
   act <- quasi_label(enquo(object))
   act$n <- length(act$val)

R/expect-match.R

@@ -77,8 +77,11 @@ expect_no_match <- function(
 ) {
   # Capture here to avoid environment-related messiness
   act <- quasi_label(enquo(object), label)
-  stopifnot(is.character(regexp), length(regexp) == 1)
-  stopifnot(is.character(act$val))
+  check_character(object)
+  check_string(regexp)
+  check_bool(perl)
+  check_bool(fixed)
+  check_bool(all)
 
   expect_match_(
     act = act,