Improve expect_s3_class() documentation (#2159)

Fixes #2401

Author: hadley

R/expect-inheritance.R

@@ -18,9 +18,15 @@
 #' 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_s7_class()`: an [S7::S7_class()] object.
 #' @inheritParams expect_that
 #' @family expectations
 #' @examples
@@ -31,6 +37,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
@@ -66,8 +81,8 @@ 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)
 
@@ -106,35 +121,6 @@ expect_s3_class <- function(object, class, exact = FALSE) {
   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)
-}
-
 #' @export
 #' @rdname inheritance-expectations
 expect_s4_class <- function(object, class) {
@@ -162,13 +148,40 @@ 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_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?
 #'
@@ -177,15 +190,16 @@ 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) {
@@ -212,6 +226,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 = "/")

man/expect_is.Rd

@@ -31,6 +31,14 @@
       Error in `expect_s3_class()`:
       ! `exact` must be `TRUE` or `FALSE`, not the string "yes".
 
+---
+
+    Code
+      expect_s4_class(factor("a"), 1)
+    Condition
+      Error in `expect_s4_class()`:
+      ! `class` must be a character vector or NA, not the number 1.
+
 # test_s3_class respects class hierarchy
 
     `x` inherits from 'a'/'b' not 'c'.

man/inheritance-expectations.Rd

@@ -81,6 +81,14 @@ test_that("expect_s4_class allows unquoting of first argument", {
   expect_success(expect_s4_class(!!rlang::quo(obj), "new_class"))
 })
 
+
+test_that("expect_s3_class validates its inputs", {
+  expect_snapshot(error = TRUE, {
+    expect_s4_class(factor("a"), 1)
+  })
+})
+
+
 # expect_s7_class --------------------------------------------------------
 
 test_that("can check with actual class", {