Implement expect_S7_class()

Fixes #1580. Closes #2016.

Author: hadley

DESCRIPTION

@@ -43,6 +43,7 @@ Suggests:
     knitr,
     rmarkdown,
     rstudioapi,
+    S7,
     shiny,
     usethis,
     vctrs (>= 0.1.0),

NAMESPACE

@@ -115,6 +115,7 @@ export(expect_output_file)
 export(expect_reference)
 export(expect_s3_class)
 export(expect_s4_class)
+export(expect_s7_class)
 export(expect_setequal)
 export(expect_silent)
 export(expect_snapshot)

NEWS.md

@@ -1,5 +1,6 @@
 # testthat (development version)
 
+* New `expect_s7_class()` for testing if an object is an S7 class (#1580).
 * `expect_setequal()` correctly identifies what is missing where (#1962).
 * `expect_true()` and `expect_false()` give better errors if `actual` isn't a vector (#1996).
 * `expect_no_*()` expectations no longer incorrectly emit a passing test result if they in fact fail (#1997).

R/expect-inheritance.R

@@ -8,10 +8,12 @@
 #' * `expect_type(x, type)` checks that `typeof(x)` is `type`.
 #' * `expect_s3_class(x, class)` checks that `x` is an S3 object that
 #'   [inherits()] from `class`
-#' * `expect_s3_class(x, NA)` checks that `x` isn't an S3 object.
+#' * `expect_s3_class(x, NA)` checks that `x` is an S3 object.
 #' * `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_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.
 #'
@@ -92,6 +94,33 @@ expect_s3_class <- function(object, class, exact = FALSE) {
   invisible(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), arg = "object")
+
+  if (!S7::S7_inherits(object)) {
+    fail(sprintf("%s is not an S7 object", act$lab))
+  } else {
+    expect(
+      S7::S7_inherits(object, class),
+      sprintf(
+        "%s inherits from %s not <%s>.",
+        act$lab,
+        paste0("<", setdiff(base::class(object), "S7_object"), ">", collapse = "/"),
+        class@name
+      )
+    )
+  }
+
+  invisible(act$val)
+}
+
 #' @export
 #' @rdname inheritance-expectations
 expect_s4_class <- function(object, class) {

man/inheritance-expectations.Rd

@@ -18,3 +18,19 @@
 
     `x` inherits from 'a'/'b' not 'c'/'d'.
 
+# checks its inputs
+
+    Code
+      expect_s7_class(1, 1)
+    Condition
+      Error in `expect_s7_class()`:
+      ! `class` must be an S7 class object, not the number 1.
+
+# can check with actual class
+
+    Foo() inherits from <Foo> not <Bar>.
+
+---
+
+    Baz() inherits from <Baz>/<Foo> not <Bar>.
+

tests/testthat/_snaps/expect-inheritance.md

@@ -56,8 +56,24 @@ test_that("test_s3_class can request exact match", {
   expect_success(expect_s3_class(x, c("a", "b"), exact = TRUE))
 })
 
-
 test_that("expect_s3_class allows unquoting of first argument", {
   f <- factor("a")
   expect_success(expect_s3_class(!! rlang::quo(f), "factor"))
 })
+
+
+# expect_s7_class --------------------------------------------------------
+
+test_that("checks its inputs", {
+  expect_snapshot(expect_s7_class(1, 1), error = TRUE)
+})
+
+test_that("can check with actual class", {
+  Foo <- S7::new_class("Foo")
+  Bar <- S7::new_class("Bar")
+  expect_success(expect_s7_class(Foo(), class = Foo))
+  expect_snapshot_failure(expect_s7_class(Foo(), class = Bar))
+
+  Baz <- S7::new_class("Baz", parent = Foo)
+  expect_snapshot_failure(expect_s7_class(Baz(), class = Bar))
+})