Back out conditional S4 extension handling

Author: t-kalinowski

R/class-spec.R

@@ -331,7 +331,7 @@ class_extends <- function(child, parent) {
   } else if (is_S4_class(child) || is_S4_class(parent)) {
     is_S4_class(child) &&
       is_S4_class(parent) &&
-      S4_extends_unconditionally(child, parent)
+      S4_extends_simple(child, parent)
   } else if (is_class(parent) && parent@name == "S7_object") {
     is_class(child)
   } else {
@@ -395,14 +395,14 @@ union_contains_any <- function(x) {
   is_union(x) && any(vlapply(x$classes, is_class_any))
 }
 
-S4_extends_unconditionally <- function(child, parent) {
+S4_extends_simple <- function(child, parent) {
   extension <- methods::extends(
     child@className,
     parent@className,
     fullInfo = TRUE
   )
   isTRUE(extension) ||
-    (isS4(extension) && !methods::is(extension, "conditionalExtension"))
+    (isS4(extension) && isTRUE(methods::slot(extension, "simple")))
 }
 
 # Suppress @className false positive

tests/testthat/test-class.R

@@ -122,41 +122,6 @@ describe("inheritance", {
       "must narrow"
     )
   })
-  it("child properties can't narrow with conditional S4 extensions", {
-    on.exit(S4_remove_classes(c(
-      "S4PropertyConditionalChild",
-      "S4PropertyConditionalParent"
-    )))
-    S4PropertyConditionalParent <- methods::setClass(
-      "S4PropertyConditionalParent",
-      slots = c(x = "numeric")
-    )
-    S4PropertyConditionalChild <- methods::setClass(
-      "S4PropertyConditionalChild",
-      slots = c(x = "numeric")
-    )
-    suppressWarnings(methods::setIs(
-      "S4PropertyConditionalChild",
-      "S4PropertyConditionalParent",
-      test = function(object) length(object@x) > 0
-    ))
-
-    Parent <- new_class(
-      "Parent",
-      properties = list(x = S4PropertyConditionalParent),
-      package = NULL
-    )
-
-    expect_error(
-      new_class(
-        "Child",
-        Parent,
-        properties = list(x = S4PropertyConditionalChild),
-        package = NULL
-      ),
-      "must narrow"
-    )
-  })
   it("child properties can narrow parent unions that include any", {
     Parent <- new_class(
       "Parent",