in obj_type(), isS4() takes precedence over has_S4_class(), since an S4 object is just that, even if it inherits from an S7 class and thus carries an S7_class slot.

Author: lawremi

R/class-spec.R

@@ -322,10 +322,10 @@ class_inherits <- function(x, what) {
 obj_type <- function(x) {
   if (identical(x, quote(expr = ))) {
     "missing"
-  } else if (has_S7_class(x)) {
-    "S7"
   } else if (isS4(x)) {
     "S4"
+  } else if (has_S7_class(x)) {
+    "S7"
   } else if (is.object(x)) {
     "S3"
   } else {

R/class.R

@@ -427,7 +427,11 @@ S7_class <- function(object) {
     obj_type(object),
     missing = class_missing,
     S7 = attr(object, "S7_class", exact = TRUE),
-    S4 = methods::getClass(class(object)),
+    S4 = if (has_S7_class(object)) {
+      methods::slot(object, "S7_class")
+    } else {
+      methods::getClass(class(object))
+    },
     S3 = new_S3_class(class(object)),
     base = base_S7_class(object)
   )

tests/testthat/test-S4.R

@@ -128,6 +128,32 @@ describe("S4_register", {
     expect_equal(prop(object, "x"), 1)
     expect_equal(prop(object, "y"), "a")
     expect_true(methods::validObject(object))
+    expect_equal(S7_class(object), S4regContainsChild)
+    expect_match(obj_desc(object), "^S4<")
+
+    expect_equal(
+      S4_to_S7_class(getClass("S4regContainsS4Child")),
+      getClass("S4regContainsS4Child")
+    )
+    expect_contains(
+      obj_dispatch(object),
+      c(
+        S4_class_name(getClass("S4regContainsS4Child")),
+        S4regContainsChild_old
+      )
+    )
+
+    S4regContainsDispatch <- new_generic("S4regContainsDispatch", "x")
+    method(S4regContainsDispatch, S4regContainsChild) <- function(x) {
+      "S7"
+    }
+    method(
+      S4regContainsDispatch,
+      getClass("S4regContainsS4Child")
+    ) <- function(x) {
+      "S4"
+    }
+    expect_equal(S4regContainsDispatch(object), "S4")
 
     invalid <- object
     methods::slot(invalid, "y") <- "bad"