Make S7_inherits() more flexible (#347)

NEWS.md

@@ -1,5 +1,8 @@
 # S7 (development version)
 
+* `S7_inherits()` now accepts `class = NULL` to test if an object is any
+  sort of S7 object (#347).
+
 * Classes get a more informative print method (#346).
 
 * External methods are now registered using an attribute of the S3 methods 

R/inherits.R

@@ -1,13 +1,15 @@
 #' Does this object inherit from an S7 class?
 #'
 #' * `S7_inherits()` returns `TRUE` or `FALSE`.
-#' * `check_is_S7()` throws an error.
+#' * `check_is_S7()` throws an error if `x` isn't the specified `class`.
 #'
 #' @param x An object
-#' @param class An S7 class. Can be omitted in `check_is_S7()`.
+#' @param class An S7 class or `NULL`. If `NULL`, tests whether `x` is an
+#'   S7 object without testing for a specific class.
 #' @param arg Argument name used in error message.
-#' @returns `S7_inherits()` returns a single `TRUE` or `FALSE`;
-#'   `check_is_S7()` returns nothing; it's called for its side-effects.
+#' @returns
+#' * `S7_inherits()` returns a single `TRUE` or `FALSE`.
+#' * `check_is_S7()` returns nothing; it's called for its side-effects.
 #' @export
 #' @examples
 #' foo1 <- new_class("foo1")
@@ -19,28 +21,27 @@
 #'
 #' S7_inherits(foo1(), foo2)
 #' try(check_is_S7(foo1(), foo2))
-S7_inherits <- function(x, class) {
-  if (!inherits(class, "S7_class")) {
-    stop("`class` is not an <S7_class>")
+S7_inherits <- function(x, class = NULL) {
+  if (!(is.null(class) || inherits(class, "S7_class"))) {
+    stop("`class` must be an <S7_class> or NULL")
   }
 
-  inherits(x, "S7_object") && inherits(x, S7_class_name(class))
+  inherits(x, "S7_object") &&
+    (is.null(class) || inherits(x, S7_class_name(class)))
 }
 
 #' @export
 #' @rdname S7_inherits
 check_is_S7 <- function(x, class = NULL, arg = deparse(substitute(x))) {
-  if (is.null(class)) {
-    if (!inherits(x, "S7_object")) {
-      msg <- sprintf("`%s` must be an <S7_object>, not a %s", arg, obj_desc(x))
-      stop(msg, call. = FALSE)
-    }
-  } else {
-    if (!S7_inherits(x, class)) {
-      msg <- sprintf("`%s` must be a %s, not a %s", arg, class_desc(class), obj_desc(x))
-      stop(msg, call. = FALSE)
-    }
+  if (S7_inherits(x, class)) {
+    return(invisible())
   }
 
-  invisible()
+  msg <- sprintf(
+    "`%s` must be %s, not a %s",
+    arg,
+    if (is.null(class)) "an <S7_object>" else paste0("a ", class_desc(class)),
+    obj_desc(x)
+  )
+  stop(msg, call. = FALSE)
 }

tests/testthat/_snaps/inherits.md

@@ -3,7 +3,7 @@
     Code
       S7_inherits(1:10, "x")
     Error <simpleError>
-      `class` is not an <S7_class>
+      `class` must be an <S7_class> or NULL
 
 # throws informative error
 

tests/testthat/test-inherits.R

@@ -2,9 +2,11 @@ test_that("it works", {
   foo1 <- new_class("foo1")
   foo2 <- new_class("foo2", parent = foo1)
 
+  expect_true(S7_inherits(foo1(), NULL))
   expect_true(S7_inherits(foo1(), foo1))
   expect_true(S7_inherits(foo2(), foo1))
   expect_false(S7_inherits(foo1(), foo2))
+  expect_false(S7_inherits(1, NULL))
 })
 
 test_that("checks that input is a class", {