Create chk_s3_class_strict()

NAMESPACE

@@ -78,6 +78,7 @@ export(chk_proportion)
 export(chk_range)
 export(chk_raw)
 export(chk_s3_class)
+export(chk_s3_class_strict)
 export(chk_s4_class)
 export(chk_scalar)
 export(chk_setequal)
@@ -167,6 +168,7 @@ export(vld_orderset)
 export(vld_range)
 export(vld_raw)
 export(vld_s3_class)
+export(vld_s3_class_strict)
 export(vld_s4_class)
 export(vld_scalar)
 export(vld_setequal)

R/chk-s3-class-strict.R

@@ -0,0 +1,53 @@
+#' Check Type
+#'
+#' @description
+#' Checks inherits strictly from S3 class using
+#'
+#' `is.object(x, class) && !isS4(x) && !inherits(x, "R6") && !inherits(x, "S7_object")`
+#'
+#' @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")`.
+#'
+#' @examples
+#' # chk_s3_class_strict
+#' chk_s3_class_strict(1, "numeric")
+#' try(chk_s3_class_strict(getClass("MethodDefinition"), "classRepresentation"))
+#' @export
+chk_s3_class_strict <- function(x, class, x_name = NULL) {
+  if (vld_s3_class_strict(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 strictly inherit from an S3 class called ",
+    .class,
+    x = x,
+    .class = .class
+  )
+}
+
+#' @describeIn chk_s3_class_strict Validate Inherits from S3 Class
+#'
+#' @examples
+#' # vld_s3_class_strict
+#' vld_s3_class_strict(numeric(0), "numeric")
+#' vld_s3_class_strict(getClass("MethodDefinition"), "classRepresentation")
+#' @export
+vld_s3_class_strict <- function(x, class) {
+  inherits(x, class) &&
+    is.object(x) &&
+    !isS4(x) && # R5 classes count as S4
+    !inherits(x, "R6") &&
+    !inherits(x, "S7_object")
+}

tests/testthat/test-chk-s3-class-strict.R

@@ -0,0 +1,89 @@
+test_that("vld_s3_class_strict", {
+  expect_false(vld_s3_class_strict(NULL, "NULL")) # base objects are not S3
+  expect_false(vld_s3_class_strict(1, "numeric"))
+  expect_false(vld_s3_class_strict(1L, "integer"))
+  expect_false(vld_s3_class_strict(list(), "list"))
+  expect_true(vld_s3_class_strict(factor(1), "factor"))
+  expect_true(vld_s3_class_strict(data.frame(), "data.frame"))
+
+  setClass("exampleS4class", slots = c(value = "numeric"))
+  expect_true(class(new("exampleS4class")) == "exampleS4class")
+  expect_false(vld_s3_class_strict(new("exampleS4class"), "exampleS4class"))
+  invisible(removeClass("exampleS4class"))
+
+  expect_true(
+    class(setRefClass("exampleRefClass", fields = "value")$new()) ==
+      "exampleRefClass"
+  )
+  expect_true(isS4(setRefClass("exampleRefClass", fields = "value")$new()))
+  expect_false(
+    vld_s3_class_strict(
+      setRefClass("exampleRefClass", fields = "value")$new(),
+      "exampleRefClass"
+    )
+  )
+
+  expect_true(R6::is.R6(R6::R6Class("exampleR6class")$new()))
+  expect_false(vld_s3_class_strict(R6::R6Class("example")$new(),
+                                   "R6ClassGenerator"))
+
+  S7_generator <- S7::new_class("exampleS7class")
+  expect_true(S7::S7_inherits(S7_generator(), S7_generator))
+  expect_false(vld_s3_class_strict(S7_generator(), "S7ClassGenerator"))
+
+  x <- list()
+  class(x) <- c("a", "b")
+  expect_true(vld_s3_class_strict(x, "a"))
+  expect_true(vld_s3_class_strict(x, "b"))
+  expect_false(vld_s3_class_strict(
+    getClass("MethodDefinition"),
+    "classRepresentation"
+  ))
+})
+
+test_that("chk_s3_class_strict", {
+  expect_identical(chk_s3_class_strict(factor(1), "factor"), factor(1), "factor")
+  expect_invisible(chk_s3_class_strict(factor(1), "factor"))
+
+  expect_error(chk_s3_class_strict(1L, "integer"),
+               "^`1L` must strictly inherit from an S3 class called 'integer'\\.$")
+
+  expect_chk_error(
+    chk_s3_class_strict(1, "integer"),
+    "^`1` must strictly inherit from an S3 class called 'integer'\\.$"
+  )
+  expect_chk_error(
+    chk_s3_class_strict(matrix(1), "numeric"),
+    "`matrix\\(1\\)` must strictly inherit from an S3 class called 'numeric'\\.$"
+  )
+  x <- list()
+  class(x) <- c("a", "b")
+  expect_chk_error(chk_s3_class_strict(x, "c"),
+                   "^`x` must strictly inherit from an S3 class called 'c'"
+  )
+  expect_chk_error(
+    chk_s3_class_strict(x, "c", x_name = "object name"),
+    "Object name must strictly inherit from an S3 class called 'c'"
+  )
+
+  foo <- 1
+  class(foo) <- "a"
+  expect_chk_error(
+    chk_s3_class_strict(foo, c("b", "c")),
+    "`foo` must strictly inherit from an S3 class called 'b' or 'c'."
+  )
+
+  expect_chk_error(chk_s3_class_strict(
+    setRefClass("exampleRefClass", fields = "value")$new(),
+    "exampleRefClass"
+  ),
+  "^`setRefClass\\(\"exampleRefClass\", fields = \"value\"\\)\\$new\\(\\)` must strictly inherit from an S3 class called 'exampleRefClass'\\.$"
+  )
+
+  expect_true(R6::is.R6(R6::R6Class("exampleR6class")$new()))
+  expect_false(vld_s3_class_strict(R6::R6Class("example")$new(), "R6ClassGenerator"))
+
+  S7_generator <- S7::new_class("exampleS7class")
+  expect_true(inherits(S7_generator(), S7_generator))
+  expect_false(vld_s3_class_strict(S7_generator(), "S7ClassGenerator"))
+})