Create chk_s7_class()

NAMESPACE

@@ -76,11 +76,13 @@ export(chk_off)
 export(chk_on)
 export(chk_orderset)
 export(chk_proportion)
+export(chk_r6_class)
 export(chk_range)
 export(chk_raw)
 export(chk_s3_class)
 export(chk_s3_class_strict)
 export(chk_s4_class)
+export(chk_s7_class)
 export(chk_scalar)
 export(chk_setequal)
 export(chk_sorted)
@@ -167,11 +169,13 @@ export(vld_null)
 export(vld_number)
 export(vld_numeric)
 export(vld_orderset)
+export(vld_r6_class)
 export(vld_range)
 export(vld_raw)
 export(vld_s3_class)
 export(vld_s3_class_strict)
 export(vld_s4_class)
+export(vld_s7_class)
 export(vld_scalar)
 export(vld_setequal)
 export(vld_sorted)

R/chk-r6-class.R

@@ -0,0 +1,60 @@
+#' Check Inherits from R6 Class
+#'
+#' @description
+#' Checks inherits from R6 class using
+#'
+#' `inherits(x, "R6") && inherits(x, class)`
+#'
+#' @details
+#' All R6 objects inherit from the class `'R6'`, so `chk_r6_class(x, "R6")`
+#' checks that `x` is an R6 object of any class.
+#' R6 class generators (as returned by [R6::R6Class()]) are not themselves
+#' R6 objects.
+#'
+#' @inheritParams params
+#' @inherit params return
+#'
+#' @family id_checkers
+#'
+#' @seealso [inherits()]
+#' @seealso For more details about the use of this function,
+#' please read the article
+#' `vignette("chk-families")`.
+#'
+#' @examplesIf requireNamespace("R6", quietly = TRUE)
+#' # chk_r6_class
+#' chk_r6_class(R6::R6Class("exampleR6class")$new(), "exampleR6class")
+#' try(chk_r6_class(1, "numeric"))
+#' @export
+chk_r6_class <- function(x, class, x_name = NULL) {
+  if (vld_r6_class(x, class)) {
+    return(invisible(x))
+  }
+  if (is.null(x_name)) {
+    x_name <- deparse_backtick_chk(substitute(x))
+  }
+  .class <- cc(class, conj = " or ", chk = FALSE)
+  abort_chk(
+    x_name,
+    " must inherit from R6 class",
+    if (length(class) == 1) " " else "es ",
+    .class,
+    ", not ",
+    object_type(x),
+    " class",
+    if (length(class(x)) == 1) " " else "es ",
+    cc(class(x), conj = " and "),
+    ".",
+    x = x,
+    .class = .class
+  )
+}
+
+#' @describeIn chk_r6_class Validate Inherits from R6 Class
+#'
+#' @examplesIf requireNamespace("R6", quietly = TRUE)
+#' # vld_r6_class
+#' vld_r6_class(R6::R6Class("exampleR6class")$new(), "exampleR6class")
+#' vld_r6_class(1, "numeric")
+#' @export
+vld_r6_class <- function(x, class) inherits(x, "R6") && inherits(x, class)

R/chk-s3-class.R

@@ -36,11 +36,13 @@ chk_s3_class <- function(x, class, x_name = NULL) {
   .class <- cc(class, conj = " or ", chk = FALSE)
   abort_chk(
     x_name,
-    " must inherit from S3 class", if (length(class) == 1) " " else "es ",
+    " must inherit from S3 class",
+    if (length(class) == 1) " " else "es ",
     .class,
     ", not ",
-    if (vld_s4_class(x, class(x))) "S4" else if (inherits(x, "R6")) "R6" else "S3",
-    " class", if (length(class(x)) == 1) " " else "es ",
+    object_type(x),
+    " class",
+    if (length(class(x)) == 1) " " else "es ",
     cc(class(x), conj = " and "),
     ".",
     x = x,

R/chk-s4-class.R

@@ -30,11 +30,13 @@ chk_s4_class <- function(x, class, x_name = NULL) {
   .class <- cc(class, conj = " or ", chk = FALSE)
   abort_chk(
     x_name,
-    " must inherit from S4 class", if (length(class) == 1) " " else "es ",
+    " must inherit from S4 class",
+    if (length(class) == 1) " " else "es ",
     .class,
     ", not ",
-    if (vld_s4_class(x, class(x))) "S4" else if (inherits(x, "R6")) "R6" else "S3",
-    " class", if (length(class(x)) == 1) " " else "es ",
+    object_type(x),
+    " class",
+    if (length(class(x)) == 1) " " else "es ",
     cc(class(x), conj = " and "),
     ".",
     x = x,
@@ -49,4 +51,6 @@ chk_s4_class <- function(x, class, x_name = NULL) {
 #' vld_s4_class(numeric(0), "numeric")
 #' vld_s4_class(getClass("MethodDefinition"), "classRepresentation")
 #' @export
-vld_s4_class <- function(x, class) isS4(x) && any(sapply(class, \(.c) methods::is(x, .c)))
+vld_s4_class <- function(x, class) {
+  isS4(x) && any(sapply(class, \(.c) methods::is(x, .c)))
+}

R/chk-s7-class.R

@@ -0,0 +1,72 @@
+#' Check Inherits from S7 Class
+#'
+#' @description
+#' Checks inherits from S7 class using
+#'
+#' `inherits(x, "S7_object") && inherits(x, class)`
+#'
+#' @details
+#' All S7 objects inherit from the class `'S7_object'`, so
+#' `chk_s7_class(x, "S7_object")` checks that `x` is an S7 object of any class.
+#'
+#' S7 is self-describing, so an S7 class generator (as returned by
+#' [S7::new_class()]) is itself an S7 object, of class `'S7_class'`.
+#' It is not an object of the class it generates.
+#'
+#' `class` is a character vector of class names matching those in `class(x)`.
+#' S7 qualifies class names with the package they are defined in, so an S7
+#' class defined in package `foo` is matched by `'foo::ClassName'` and not by
+#' `'ClassName'`.
+#' S7 class objects are not accepted as `class`.
+#'
+#' @inheritParams params
+#' @inherit params return
+#'
+#' @family id_checkers
+#'
+#' @seealso [inherits()]
+#' @seealso For more details about the use of this function,
+#' please read the article
+#' `vignette("chk-families")`.
+#'
+#' @examplesIf requireNamespace("S7", quietly = TRUE)
+#' # chk_s7_class
+#' Foo <- S7::new_class("Foo", package = "mypkg")
+#' chk_s7_class(Foo(), "mypkg::Foo")
+#' try(chk_s7_class(1, "numeric"))
+#' @export
+chk_s7_class <- function(x, class, x_name = NULL) {
+  if (vld_s7_class(x, class)) {
+    return(invisible(x))
+  }
+  if (is.null(x_name)) {
+    x_name <- deparse_backtick_chk(substitute(x))
+  }
+  .class <- cc(class, conj = " or ", chk = FALSE)
+  abort_chk(
+    x_name,
+    " must inherit from S7 class",
+    if (length(class) == 1) " " else "es ",
+    .class,
+    ", not ",
+    object_type(x),
+    " class",
+    if (length(class(x)) == 1) " " else "es ",
+    cc(class(x), conj = " and "),
+    ".",
+    x = x,
+    .class = .class
+  )
+}
+
+#' @describeIn chk_s7_class Validate Inherits from S7 Class
+#'
+#' @examplesIf requireNamespace("S7", quietly = TRUE)
+#' # vld_s7_class
+#' Foo <- S7::new_class("Foo", package = "mypkg")
+#' vld_s7_class(Foo(), "mypkg::Foo")
+#' vld_s7_class(1, "numeric")
+#' @export
+vld_s7_class <- function(x, class) {
+  inherits(x, "S7_object") && inherits(x, class)
+}

R/internal.R

@@ -16,3 +16,17 @@
 
   anyDuplicated(x)
 }
+
+# the class system an object belongs to, for reporting in error messages
+# R5 reference classes count as S4; base objects count as S3
+object_type <- function(x) {
+  if (vld_s4_class(x, class(x))) {
+    "S4"
+  } else if (inherits(x, "R6")) {
+    "R6"
+  } else if (inherits(x, "S7_object")) {
+    "S7"
+  } else {
+    "S3"
+  }
+}

_pkgdown.yml

@@ -126,9 +126,11 @@ reference:
   contents:
   - chk_is
   - chk_class
+  - chk_r6_class
   - chk_s3_class
   - chk_s3_class_strict
   - chk_s4_class
+  - chk_s7_class
 - title: REGEX Checker
   desc: Check if the function input matches a REGEX
   contents: