Rearrange functions

Author: hadley

R/expect-inheritance.R

@@ -121,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) {
@@ -177,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?
 #'
@@ -228,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/inheritance-expectations.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'.

tests/testthat/_snaps/expect-inheritance.md

@@ -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", {