Implement expect_S7_class() (#2017)

Fixes #1580. Closes #2016.

DESCRIPTION

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

NAMESPACE

@@ -117,6 +117,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_error()` and friends now error if you supply `...` but not `pattern` (#1932).
 * New `expect_no_failure()`, `expect_no_success()` and `expect_snapshot_failure()` provide more options for testing expectations.
 * `expect_error()` and friends no longer give an uninformative error if they fail inside a magrittr pipe (#1994).

R/expect-inheritance.R

@@ -12,6 +12,8 @@
 #' * `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 = "/"),
+        attr(class, "name", TRUE)
+      )
+    )
+  }
+
+  invisible(act$val)
+}
+
 #' @export
 #' @rdname inheritance-expectations
 expect_s4_class <- function(object, class) {

tests/testthat/_snaps/expect-inheritance.md

@@ -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/test-expect-inheritance.R

@@ -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))
+})