high priorty S4 compatibility fixes

R/S4.R

@@ -239,15 +239,14 @@ S4_check_contains <- function(class, call = sys.call(-1L)) {
   }
 
   for (prop in class@properties) {
-    if (prop_is_dynamic(prop) || prop_has_setter(prop)) {
+    if (prop_is_encapsulated(prop)) {
       msg <- sprintf(
         paste0(
           "Can't extend S7 class %s with S4 because property %s has a ",
-          "custom %s."
+          "custom getter or setter."
         ),
         class_desc(class),
-        prop$name,
-        if (prop_is_dynamic(prop)) "getter" else "setter"
+        prop$name
       )
       stop2(msg, call = call)
     }
@@ -416,6 +415,18 @@ S4_initialize <- function(.Object, ...) {
     S4_check_contains(S7_class(.Object))
   }
 
+  if (!isS4(.Object)) {
+    class <- S7_class(.Object)
+    parent <- S4_ancestor(class)
+    parent_initialize <- methods::selectMethod(
+      "initialize",
+      parent@className
+    )
+    if (!inherits(parent_initialize, "derivedDefaultMethod")) {
+      return(parent_initialize(.Object, ...))
+    }
+  }
+
   args <- list(...)
   if (length(args) == 0) {
     return(.Object)

R/class-spec.R

@@ -396,15 +396,27 @@ class_extends <- function(child, parent) {
     parent <- resolve_external_class_req(parent)
     class_extends(child, parent)
   } else if (is_S4_class(child) || is_S4_class(parent)) {
-    is_S4_class(child) &&
-      is_S4_class(parent) &&
-      methods::extends(child@className, parent@className)
+    child <- class_extends_S4_name(child)
+    parent <- class_extends_S4_name(parent)
+    !is.null(child) &&
+      !is.null(parent) &&
+      methods::extends(child, parent)
   } else {
     # handle S7, S3, and base types.
     class_dispatch_extends(class_dispatch(parent), class_dispatch(child))
   }
 }
 
+class_extends_S4_name <- function(class) {
+  if (is_S4_class(class)) {
+    class@className
+  } else if (is_class(class)) {
+    S7_class_name(class)
+  } else {
+    NULL
+  }
+}
+
 obj_type <- function(x) {
   if (identical(x, quote(expr = ))) {
     "missing"

R/class.R

@@ -347,7 +347,7 @@ check_parent <- function(parent, class, call = sys.call(-1L)) {
 #' @rdname new_class
 #' @export
 new_object <- function(`_parent`, ...) {
-  class <- sys.function(-1)
+  class <- sys.function(sys.parent())
   if (!inherits(class, "S7_class")) {
     stop2("`new_object()` must be called from within a constructor.")
   }
@@ -485,6 +485,7 @@ check_prop_overrides <- function(
   call = sys.call(-1L)
 ) {
   overridden <- intersect(names(child_props), names(parent_props))
+  check_S4_slot_overrides(child_props, parent, call = call)
 
   for (prop in overridden) {
     child_prop <- child_props[[prop]]
@@ -516,3 +517,34 @@ check_prop_overrides <- function(
     }
   }
 }
+
+check_S4_slot_overrides <- function(
+  child_props,
+  parent,
+  call = sys.call(-1L)
+) {
+  parent_S4 <- if (is_S4_class(parent)) parent else S4_ancestor(parent)
+  if (is.null(parent_S4)) {
+    return(invisible())
+  }
+
+  overridden <- intersect(names(child_props), names(parent_S4@slots))
+
+  for (prop in overridden) {
+    child_prop <- child_props[[prop]]
+    if (!prop_is_encapsulated(child_prop)) {
+      next
+    }
+
+    msg <- sprintf(
+      paste0(
+        "Can't override inherited S4 slot %s with a property that has a ",
+        "custom getter or setter."
+      ),
+      prop
+    )
+    stop2(msg, call = call)
+  }
+
+  invisible()
+}

R/constructor.R

@@ -38,6 +38,14 @@ new_constructor <- function(
         bquote(S7::new_object(.(parent_call), ..(self_args)), splice = TRUE)
       }
 
+    if (is_S4_class(parent)) {
+      parent_nms <- names2(class_properties(parent))
+      new_object_call <- as.call(c(
+        list(quote(methods::initialize), new_object_call),
+        as_names(parent_nms)
+      ))
+    }
+
     return(new_S7_constructor(
       new_function(
         args = arg_info$self,

R/method-register-S3.R

@@ -26,8 +26,8 @@ register_S3_method <- function(
     register_local_s3_method(generic, class, method)
   } else {
     # Register external generics in their own namespace.
-    envir <- environment(generic$generic) %||% envir
-    registerS3method(generic$name, class, method, envir)
+    S3_envir <- environment(generic$generic) %||% envir
+    registerS3method(generic$name, class, method, S3_envir)
   }
 
   if (should_register_S4_method(generic, signature)) {

R/property.R

@@ -608,3 +608,7 @@ prop_is_read_only <- function(prop) {
 prop_has_setter <- function(prop) is.function(prop$setter)
 
 prop_is_dynamic <- function(prop) is.function(prop$getter)
+
+prop_is_encapsulated <- function(prop) {
+  prop_is_dynamic(prop) || prop_has_setter(prop)
+}

tests/testthat/test-S4.R

@@ -464,15 +464,15 @@ test_that("S4_contains rejects properties with custom accessors", {
   expect_no_error(S4_register(S4regContainsDynamic))
   expect_error(
     S4_contains(S4regContainsDynamic),
-    "custom getter"
+    "custom getter or setter"
   )
   methods::setClass(
     "S4regContainsDynamicChild",
     contains = "S7::S4regContainsDynamic"
   )
   expect_error(
     methods::new("S4regContainsDynamicChild"),
-    "custom getter"
+    "custom getter or setter"
   )
 
   S4regContainsSetter <- new_class(
@@ -491,15 +491,15 @@ test_that("S4_contains rejects properties with custom accessors", {
   expect_no_error(S4_register(S4regContainsSetter))
   expect_error(
     S4_contains(S4regContainsSetter),
-    "custom setter"
+    "custom getter or setter"
   )
   methods::setClass(
     "S4regContainsSetterChild",
     contains = "S7::S4regContainsSetter"
   )
   expect_error(
     methods::new("S4regContainsSetterChild"),
-    "custom setter"
+    "custom getter or setter"
   )
 })
 
@@ -702,6 +702,104 @@ test_that("S7 classes can extend S4 classes", {
   expect_error(Child(x = "x", y = "a"))
 })
 
+test_that("S7 constructors dispatch to S4 parent initialize methods", {
+  defer(S4_remove_classes(c(
+    "S4regParentInitialize",
+    "S4regChildInitialize",
+    "S4regVirtualInitialize",
+    "S4regVirtualChildInitialize"
+  )))
+  setClass("S4regParentInitialize", slots = list(x = "ANY", y = "matrix"))
+  setMethod(
+    "initialize",
+    "S4regParentInitialize",
+    function(.Object, x = NULL, y, value = x) {
+      .Object@x <- list(value)
+      .Object@y <- y + 1
+      .Object
+    }
+  )
+  S4regChildInitialize := new_class(
+    parent = getClass("S4regParentInitialize"),
+    package = NULL
+  )
+
+  y <- matrix(1, nrow = 1)
+  object <- S4regChildInitialize(x = 1, y = y)
+
+  expect_equal(object@x, list(1))
+  expect_equal(object@y, y + 1)
+  expect_identical(methods::validObject(object), TRUE)
+
+  object <- methods::initialize(object, value = 2, y = y)
+  expect_equal(object@x, list(2))
+  expect_equal(object@y, y + 1)
+
+  setClass(
+    "S4regVirtualInitialize",
+    contains = "VIRTUAL",
+    slots = list(x = "ANY", y = "matrix")
+  )
+  setMethod(
+    "initialize",
+    "S4regVirtualInitialize",
+    function(.Object, x = NULL, y, value = x) {
+      .Object@x <- list(value)
+      .Object@y <- y + 1
+      .Object
+    }
+  )
+  S4regVirtualChildInitialize := new_class(
+    parent = getClass("S4regVirtualInitialize"),
+    package = NULL
+  )
+
+  object <- S4regVirtualChildInitialize(x = 1, y = y)
+
+  expect_equal(object@x, list(1))
+  expect_equal(object@y, y + 1)
+  expect_identical(methods::validObject(object), TRUE)
+})
+
+test_that("S7 classes can not override S4 slots with custom accessors", {
+  defer(S4_remove_classes(c(
+    "S4regAccessorParent",
+    "S4regAccessorMiddle"
+  )))
+  setClass("S4regAccessorParent", slots = list(x = "numeric"))
+
+  expect_error(
+    new_class(
+      "S4regAccessorChild",
+      parent = getClass("S4regAccessorParent"),
+      properties = list(
+        x = new_property(class_numeric, getter = function(self) 1)
+      ),
+      package = NULL
+    ),
+    "custom getter or setter"
+  )
+
+  S4regAccessorMiddle := new_class(
+    parent = getClass("S4regAccessorParent"),
+    package = NULL
+  )
+  expect_error(
+    new_class(
+      "S4regAccessorChild",
+      parent = S4regAccessorMiddle,
+      properties = list(
+        x = new_property(
+          class_numeric,
+          setter = function(self, value) self
+        )
+      ),
+      package = NULL
+    ),
+    "custom getter or setter"
+  )
+})
+
 test_that("S4 initialization sets S4 slots on subclasses of S7 classes", {
   on.exit(S4_remove_classes(c(
     "ParentForSlots",
@@ -805,13 +903,13 @@ test_that("S4 classes can not extend S7-over-S4 classes with property setters",
   expect_true(attr(Child2(x = 1, y = "a"), "setter_called", exact = TRUE))
   expect_error(
     S4_contains(Child2),
-    "custom setter"
+    "custom getter or setter"
   )
 
   methods::setClass("S4Child2", contains = "Child2")
   expect_error(
     methods::new("S4Child2"),
-    "custom setter"
+    "custom getter or setter"
   )
 })
 

tests/testthat/test-class.R

@@ -116,6 +116,47 @@ test_that("inheritance lets child properties narrow with S4 inheritance", {
   expect_s4_class(Child(x = x)@x, "S4PropertyChild")
 })
 
+test_that("inheritance lets S7 children narrow S4 parent properties", {
+  Animal := local_S4_class()
+  Kennel := local_S4_class(slots = list(dog = "Animal"))
+  Dog := new_class(parent = Animal, package = NULL)
+
+  DogKennel := new_class(
+    parent = Kennel,
+    properties = list(dog = Dog),
+    package = NULL
+  )
+  dog <- Dog()
+
+  expect_equal(prop(DogKennel(dog = dog), "dog"), dog)
+})
+
+test_that("inheritance lets S4 children narrow S7 parent properties", {
+  defer(S4_remove_classes(c(
+    "S4PropertyS7Parent",
+    "S4PropertyS7Child"
+  )))
+
+  S4PropertyS7Parent := new_class(package = NULL)
+  S4_register(S4PropertyS7Parent)
+  setClass(
+    "S4PropertyS7Child",
+    contains = S4_contains(S4PropertyS7Parent)
+  )
+  S4PropertyParent := new_class(
+    properties = list(x = S4PropertyS7Parent),
+    package = NULL
+  )
+  S4PropertyChild := new_class(
+    parent = S4PropertyParent,
+    properties = list(x = getClass("S4PropertyS7Child")),
+    package = NULL
+  )
+
+  x <- methods::new("S4PropertyS7Child")
+  expect_s4_class(S4PropertyChild(x = x)@x, "S4PropertyS7Child")
+})
+
 test_that("inheritance doesn't let child properties narrow S7_object with base or S3 classes", {
   Parent := new_class(
     properties = list(x = S7_object),
@@ -299,6 +340,15 @@ test_that("new_object() gives useful error if called directly", {
   expect_snapshot(new_object(), error = TRUE)
 })
 
+test_that("new_object() can be forced lazily from a constructor", {
+  Foo := new_class(
+    constructor = function() identity(new_object(S7_object())),
+    package = NULL
+  )
+
+  expect_equal(S7_class(Foo()), Foo)
+})
+
 test_that("new_object() errors if `_parent` doesn't inherit from the parent class (#409)", {
   Bar := new_class(package = NULL)
   # `_parent` should be `Bar()`, not the class spec `Bar`