Merge pull request #458 from RConsortium/nameOfClass.S7_base_class

add `nameOfClass.S7_base_class` method
RConsortium · Oct 10, 2024 · 46318e0 · 46318e0
2 parents d804fe8 + e64a091
commit 46318e0
Show file tree

Hide file tree

Showing 3 changed files with 21 additions and 0 deletions.
diff --git a/NAMESPACE b/NAMESPACE
@@ -99,6 +99,7 @@ if (getRversion() >= "4.3.0") S3method(chooseOpsMethod, S7_super)
 if (getRversion() >= "4.3.0") S3method(matrixOps, S7_object)
 if (getRversion() >= "4.3.0") S3method(matrixOps, S7_super)
 if (getRversion() >= "4.3.0") S3method(nameOfClass, S7_class, S7_class_name)
+if (getRversion() >= "4.3.0") S3method(nameOfClass,S7_base_class)
 importFrom(stats,setNames)
 importFrom(utils,getFromNamespace)
 importFrom(utils,globalVariables)

diff --git a/R/base.R b/R/base.R
@@ -14,6 +14,8 @@ new_base_class <- function(name, constructor_name = name) {
     }
   }
 
+  validator <- utils::removeSource(validator)
+
   out <- list(
     class = name,
     constructor_name = constructor_name,
@@ -24,6 +26,11 @@ new_base_class <- function(name, constructor_name = name) {
   out
 }
 
+#' @rawNamespace if (getRversion() >= "4.3.0") S3method(nameOfClass,S7_base_class)
+nameOfClass.S7_base_class <- function(x) {
+  x[["class"]]
+}
+
 base_default <- function(type) {
   switch(type,
     logical = logical(),

diff --git a/tests/testthat/test-base.R b/tests/testthat/test-base.R
@@ -338,3 +338,16 @@ test_that("Base S3 classes can be properties", {
   expect_error(Foo(x = 1), "@x must be S3<POSIXt>, not <double>")
 
 })
+
+
+test_that("inherits() works with S7_base_class", {
+  # nameOfClass() introduced in R 4.3
+  skip_if(getRversion() < "4.3")
+
+  # test nameOfClass.S7_base_class
+  expect_true(inherits("foo", class_character))
+
+  Foo := new_class(class_character)
+  expect_true(inherits(Foo(), "character"))
+  expect_true(inherits(Foo(), class_character))
+})