From c86a5d8550273b0de45f7b15c0bfb68fb48a9c19 Mon Sep 17 00:00:00 2001 From: Michael Lawrence Date: Mon, 6 Jul 2026 04:03:53 -0700 Subject: [PATCH 1/9] use the correct registration environment for S4 methods --- R/method-register-S3.R | 3 ++- tests/testthat/test-method-register-S3.R | 32 ++++++++++++++++++++++++ 2 files changed, 34 insertions(+), 1 deletion(-) diff --git a/R/method-register-S3.R b/R/method-register-S3.R index 2c9f0a5c..c9d81dfe 100644 --- a/R/method-register-S3.R +++ b/R/method-register-S3.R @@ -5,6 +5,7 @@ register_S3_method <- function( envir = parent.frame(), call = sys.call(-1L) ) { + S4_envir <- envir sig <- signature[[1]] class <- switch( @@ -31,7 +32,7 @@ register_S3_method <- function( } if (should_register_S4_method(generic, signature)) { - register_S4_method(generic$name, signature, method, envir, call = call) + register_S4_method(generic$name, signature, method, S4_envir, call = call) } } diff --git a/tests/testthat/test-method-register-S3.R b/tests/testthat/test-method-register-S3.R index 77ba65a5..b8ba6c0d 100644 --- a/tests/testthat/test-method-register-S3.R +++ b/tests/testthat/test-method-register-S3.R @@ -86,6 +86,38 @@ test_that("internal generics register S4 methods for S4-backed S7 classes", { expect_equal(dim(object), c(1L, 2L)) }) +test_that("base closures register S4 methods for S4-backed S7 classes", { + defer({ + try(methods::removeMethod("unlist", "S4regUnlistChild"), silent = TRUE) + S4_remove_classes(c( + "S4regUnlistParent", + "S4regUnlistChild", + "S4regUnlistShim" + )) + }) + + setClass("S4regUnlistParent", contains = "VIRTUAL") + S4regUnlistChild := new_class( + parent = getClass("S4regUnlistParent"), + properties = list(x = class_integer), + package = NULL + ) + method(unlist, S4regUnlistChild) <- function( + x, + recursive = TRUE, + use.names = TRUE + ) { + x@x + } + S4regUnlistChild_S4 <- S4_contains(S4regUnlistChild) + setClass("S4regUnlistShim", contains = S4regUnlistChild_S4) + + object <- methods::new("S4regUnlistShim", x = 1L) + + expect_equal(unlist(object), 1L) + expect_true(methods::hasMethod("unlist", "S4regUnlistChild")) +}) + test_that("internal replacement generics can register full S4 signatures", { on.exit({ try( From a609ddad8dfc1ded6f5391dd20c62c5706348ded Mon Sep 17 00:00:00 2001 From: Michael Lawrence Date: Mon, 6 Jul 2026 05:20:07 -0700 Subject: [PATCH 2/9] allow for lazy evaluation of a call to new_object() in a constructor, ie we check the actual sys.parent(), not just -1L --- R/class.R | 2 +- tests/testthat/test-class.R | 9 +++++++++ 2 files changed, 10 insertions(+), 1 deletion(-) diff --git a/R/class.R b/R/class.R index ca1640f1..3e09950b 100644 --- a/R/class.R +++ b/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.") } diff --git a/tests/testthat/test-class.R b/tests/testthat/test-class.R index c5dd7975..a8671eae 100644 --- a/tests/testthat/test-class.R +++ b/tests/testthat/test-class.R @@ -299,6 +299,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` From e4bba924f81666304714d1b5b82fdd5449346c32 Mon Sep 17 00:00:00 2001 From: Michael Lawrence Date: Mon, 6 Jul 2026 05:55:34 -0700 Subject: [PATCH 3/9] delegate to non-default initialize() when not an S4 object, ie just an S7 extension of S4 --- R/S4.R | 12 ++++++++ tests/testthat/test-S4.R | 59 ++++++++++++++++++++++++++++++++++++++++ 2 files changed, 71 insertions(+) diff --git a/R/S4.R b/R/S4.R index b97666cc..f565859b 100644 --- a/R/S4.R +++ b/R/S4.R @@ -416,6 +416,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) diff --git a/tests/testthat/test-S4.R b/tests/testthat/test-S4.R index f7512701..bcfcbf6f 100644 --- a/tests/testthat/test-S4.R +++ b/tests/testthat/test-S4.R @@ -702,6 +702,65 @@ 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("S4 initialization sets S4 slots on subclasses of S7 classes", { on.exit(S4_remove_classes(c( "ParentForSlots", From d9e4f052d9841c46ac011ac9cd6cf1ab371b2ba0 Mon Sep 17 00:00:00 2001 From: Michael Lawrence Date: Mon, 6 Jul 2026 05:58:26 -0700 Subject: [PATCH 4/9] constructor wraps new_object() call in initialize() to ensure parent S4 object is properly initialized; assumes that the inherited initialize() method has the same semantics as the default one --- R/constructor.R | 8 ++++++++ 1 file changed, 8 insertions(+) diff --git a/R/constructor.R b/R/constructor.R index 50d48b3b..6f16d06f 100644 --- a/R/constructor.R +++ b/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, From d2b754e25d8b1236c179b818ca7b4460461edf05 Mon Sep 17 00:00:00 2001 From: Michael Lawrence Date: Tue, 7 Jul 2026 07:53:19 -0700 Subject: [PATCH 5/9] ensure S7 cannot override an S4 slot with an encapsulated property, with related cleanup --- R/S4.R | 7 +++--- R/class.R | 28 ++++++++++++++++++++++ R/property.R | 4 ++++ tests/testthat/test-S4.R | 51 +++++++++++++++++++++++++++++++++++----- 4 files changed, 80 insertions(+), 10 deletions(-) diff --git a/R/S4.R b/R/S4.R index f565859b..48174553 100644 --- a/R/S4.R +++ b/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) } diff --git a/R/class.R b/R/class.R index 3e09950b..a0d7bcc9 100644 --- a/R/class.R +++ b/R/class.R @@ -485,6 +485,10 @@ check_prop_overrides <- function( call = sys.call(-1L) ) { overridden <- intersect(names(child_props), names(parent_props)) + parent_S4 <- if (is_S4_class(parent)) parent else S4_ancestor(parent) + if (!is.null(parent_S4)) { + check_S4_slot_overrides(child_props, parent_S4, call = call) + } for (prop in overridden) { child_prop <- child_props[[prop]] @@ -516,3 +520,27 @@ check_prop_overrides <- function( } } } + +check_S4_slot_overrides <- function( + child_props, + parent_S4, + call = sys.call(-1L) +) { + 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) + } +} diff --git a/R/property.R b/R/property.R index 948146bd..50dfb94b 100644 --- a/R/property.R +++ b/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) +} diff --git a/tests/testthat/test-S4.R b/tests/testthat/test-S4.R index bcfcbf6f..4a705a5b 100644 --- a/tests/testthat/test-S4.R +++ b/tests/testthat/test-S4.R @@ -464,7 +464,7 @@ 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", @@ -472,7 +472,7 @@ test_that("S4_contains rejects properties with custom accessors", { ) expect_error( methods::new("S4regContainsDynamicChild"), - "custom getter" + "custom getter or setter" ) S4regContainsSetter <- new_class( @@ -491,7 +491,7 @@ 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", @@ -499,7 +499,7 @@ test_that("S4_contains rejects properties with custom accessors", { ) expect_error( methods::new("S4regContainsSetterChild"), - "custom setter" + "custom getter or setter" ) }) @@ -761,6 +761,45 @@ test_that("S7 constructors dispatch to S4 parent initialize methods", { 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", @@ -864,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" ) }) From bd4e0e19ed56256a848125397d10ee36e71202c2 Mon Sep 17 00:00:00 2001 From: Michael Lawrence Date: Tue, 7 Jul 2026 08:43:05 -0700 Subject: [PATCH 6/9] class_extends() correctly detects inheritance between S4 and S7 --- R/class-spec.R | 16 ++++++++++++--- tests/testthat/test-class.R | 41 +++++++++++++++++++++++++++++++++++++ 2 files changed, 54 insertions(+), 3 deletions(-) diff --git a/R/class-spec.R b/R/class-spec.R index ef20b9f7..5e25262e 100644 --- a/R/class-spec.R +++ b/R/class-spec.R @@ -396,15 +396,25 @@ 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) + } +} + obj_type <- function(x) { if (identical(x, quote(expr = ))) { "missing" diff --git a/tests/testthat/test-class.R b/tests/testthat/test-class.R index a8671eae..04a9eb8f 100644 --- a/tests/testthat/test-class.R +++ b/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), From 36d225e45e466c310ec71fbaca7987f07f234cbd Mon Sep 17 00:00:00 2001 From: Michael Lawrence Date: Tue, 7 Jul 2026 16:34:23 -0700 Subject: [PATCH 7/9] explicit NULL return Co-authored-by: Hadley Wickham --- R/class-spec.R | 2 ++ 1 file changed, 2 insertions(+) diff --git a/R/class-spec.R b/R/class-spec.R index 5e25262e..1ff4fd56 100644 --- a/R/class-spec.R +++ b/R/class-spec.R @@ -412,6 +412,8 @@ class_extends_S4_name <- function(class) { class@className } else if (is_class(class)) { S7_class_name(class) + } else { + NULL } } From ab070fc6ba3da8c5fdf2d06ecdd0a82cd3bf9897 Mon Sep 17 00:00:00 2001 From: Michael Lawrence Date: Tue, 7 Jul 2026 17:01:14 -0700 Subject: [PATCH 8/9] format fix --- R/class-spec.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/R/class-spec.R b/R/class-spec.R index 1ff4fd56..d4cee692 100644 --- a/R/class-spec.R +++ b/R/class-spec.R @@ -413,7 +413,7 @@ class_extends_S4_name <- function(class) { } else if (is_class(class)) { S7_class_name(class) } else { - NULL + NULL } } From 328a84cf1baf587966af03f3f03b4ce82b1817fe Mon Sep 17 00:00:00 2001 From: Michael Lawrence Date: Wed, 8 Jul 2026 07:08:08 -0700 Subject: [PATCH 9/9] address a couple of style comments --- R/class.R | 14 +++++++++----- R/method-register-S3.R | 7 +++---- 2 files changed, 12 insertions(+), 9 deletions(-) diff --git a/R/class.R b/R/class.R index a0d7bcc9..371e90f6 100644 --- a/R/class.R +++ b/R/class.R @@ -485,10 +485,7 @@ check_prop_overrides <- function( call = sys.call(-1L) ) { overridden <- intersect(names(child_props), names(parent_props)) - parent_S4 <- if (is_S4_class(parent)) parent else S4_ancestor(parent) - if (!is.null(parent_S4)) { - check_S4_slot_overrides(child_props, parent_S4, call = call) - } + check_S4_slot_overrides(child_props, parent, call = call) for (prop in overridden) { child_prop <- child_props[[prop]] @@ -523,9 +520,14 @@ check_prop_overrides <- function( check_S4_slot_overrides <- function( child_props, - parent_S4, + 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) { @@ -543,4 +545,6 @@ check_S4_slot_overrides <- function( ) stop2(msg, call = call) } + + invisible() } diff --git a/R/method-register-S3.R b/R/method-register-S3.R index c9d81dfe..6cdbedd9 100644 --- a/R/method-register-S3.R +++ b/R/method-register-S3.R @@ -5,7 +5,6 @@ register_S3_method <- function( envir = parent.frame(), call = sys.call(-1L) ) { - S4_envir <- envir sig <- signature[[1]] class <- switch( @@ -27,12 +26,12 @@ 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)) { - register_S4_method(generic$name, signature, method, S4_envir, call = call) + register_S4_method(generic$name, signature, method, envir, call = call) } }