Implement expect_r6_class() (#2162)

Fixes #2030

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,5 +1,6 @@
 # testthat (development version)
 
+* 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).

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_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`
 #'
@@ -26,6 +28,7 @@
 #'    `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
@@ -154,6 +157,26 @@ expect_s4_class <- function(object, class) {
   pass(act$val)
 }
 
+#' @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) {

man/inheritance-expectations.Rd

@@ -47,6 +47,18 @@
 
     `x` inherits from 'a'/'b' not 'c'/'d'.
 
+# expect_r6_class generates useful failures
+
+    `x` is not an R6 object.
+
+# expect_r6_class validates its inputs
+
+    Code
+      expect_r6_class(1, c("Person", "Student"))
+    Condition
+      Error in `expect_r6_class()`:
+      ! `class` must be a single string, not a character vector.
+
 # can check with actual class
 
     Foo() inherits from <Foo> not <Bar>.

tests/testthat/_snaps/expect-inheritance.md

@@ -88,6 +88,35 @@ test_that("expect_s3_class validates its inputs", {
   })
 })
 
+# expect_r6_class --------------------------------------------------------
+
+test_that("expect_r6_class succeeds when object inherits from expected class", {
+  Person <- R6::R6Class("Person")
+  Student <- R6::R6Class("Student", inherit = Person)
+
+  person <- Person$new()
+  student <- Student$new()
+
+  expect_success(expect_r6_class(person, "Person"))
+  expect_success(expect_r6_class(student, "Student"))
+  expect_success(expect_r6_class(student, "Person"))
+})
+
+test_that("expect_r6_class generates useful failures", {
+  x <- 1
+  person <- R6::R6Class("Person")$new()
+
+  expect_snapshot_failure({
+    expect_r6_class(x, "Student")
+    expect_r6_class(person, "Student")
+  })
+})
+
+test_that("expect_r6_class validates its inputs", {
+  expect_snapshot(error = TRUE, {
+    expect_r6_class(1, c("Person", "Student"))
+  })
+})
 
 # expect_s7_class --------------------------------------------------------