From 5bb9a203849ed8fc07c61605e8c8d8914e8226d2 Mon Sep 17 00:00:00 2001 From: Michael Lawrence Date: Tue, 2 Jun 2026 16:08:12 -0700 Subject: [PATCH 001/132] use isClassUnion() instead of direct class check --- R/S4.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/R/S4.R b/R/S4.R index a1814e782..e3083e739 100644 --- a/R/S4.R +++ b/R/S4.R @@ -51,7 +51,7 @@ S4_to_S7_class <- function(x, error_base = "", call = sys.call(-1L)) { )) } - if (methods::is(x, "ClassUnionRepresentation")) { + if (methods::isClassUnion(x)) { subclasses <- Filter(function(y) y@distance == 1, x@subclasses) subclasses <- lapply(subclasses, function(x) methods::getClass(x@subClass)) do.call("new_union", subclasses) From f72d4f7baa17f733bba1745bf207152d88fe8cc8 Mon Sep 17 00:00:00 2001 From: Michael Lawrence Date: Tue, 2 Jun 2026 16:27:09 -0700 Subject: [PATCH 002/132] pass className attribute directly to preserve package --- R/S4.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/R/S4.R b/R/S4.R index e3083e739..5fcad8e96 100644 --- a/R/S4.R +++ b/R/S4.R @@ -45,7 +45,7 @@ S4_to_S7_class <- function(x, error_base = "", call = sys.call(-1L)) { # Convert generator function to class if (methods::is(x, "classGeneratorFunction")) { return(S4_to_S7_class( - methods::getClass(as.character(x@className)), + methods::getClass(x@className), error_base, call = call )) From b39346c6d92e6bde88426b5c7bae86aba1ab1aea Mon Sep 17 00:00:00 2001 From: Michael Lawrence Date: Tue, 2 Jun 2026 16:32:02 -0700 Subject: [PATCH 003/132] since proper S4 classes can extend old classes, be stricter when reducing to an S3 class, and use methods::extends() to capture the entire class vector, not just the first class --- R/S4.R | 7 +++++-- 1 file changed, 5 insertions(+), 2 deletions(-) diff --git a/R/S4.R b/R/S4.R index 5fcad8e96..778917095 100644 --- a/R/S4.R +++ b/R/S4.R @@ -62,8 +62,11 @@ S4_to_S7_class <- function(x, error_base = "", call = sys.call(-1L)) { return(basic_classes[[x@className]]) } } - if (methods::extends(x, "oldClass")) { - new_S3_class(as.character(x@className)) + if ( + methods::extends(x, "oldClass") && + x@className %in% attr(x@prototype, ".S3Class") + ) { + new_S3_class(methods::extends(x)) } else { x } From d2f6a2a172a877f077ea2e82442abd57ba1e2a9a Mon Sep 17 00:00:00 2001 From: Michael Lawrence Date: Tue, 2 Jun 2026 17:23:14 -0700 Subject: [PATCH 004/132] fix is_oldClass() and use it in S4_to_S7_class() --- R/S4.R | 8 +++----- tests/testthat/test-S4.R | 14 ++++++++++++++ 2 files changed, 17 insertions(+), 5 deletions(-) diff --git a/R/S4.R b/R/S4.R index 778917095..2f95b25c1 100644 --- a/R/S4.R +++ b/R/S4.R @@ -62,10 +62,7 @@ S4_to_S7_class <- function(x, error_base = "", call = sys.call(-1L)) { return(basic_classes[[x@className]]) } } - if ( - methods::extends(x, "oldClass") && - x@className %in% attr(x@prototype, ".S3Class") - ) { + if (is_oldClass(x)) { new_S3_class(methods::extends(x)) } else { x @@ -132,7 +129,8 @@ S4_class_dispatch <- function(x) { } is_oldClass <- function(x) { - x@virtual && methods::extends(x, "oldClass") && x@className != "oldClass" + methods::extends(x, "oldClass") && + x@className %in% attr(x@prototype, ".S3Class") } S4_class_name <- function(x) { diff --git a/tests/testthat/test-S4.R b/tests/testthat/test-S4.R index 094ddf73e..61bfe0be7 100644 --- a/tests/testthat/test-S4.R +++ b/tests/testthat/test-S4.R @@ -121,6 +121,20 @@ test_that("S4_class_dispatch ignores unions", { expect_equal(S4_class_dispatch("Foo2"), "S4/S7::Foo2") }) +test_that("S4_class_dispatch dispatches through the full S3 old-class hierarchy", { + setOldClass(c("S4OldS3a", "S4OldS3b")) + defer(S4_remove_classes(c("S4OldS3Child", "S4OldS3a", "S4OldS3b"))) + setClass("S4OldS3Child", contains = "S4OldS3a") + + generic <- new_generic("S4OldS3Generic", "x") + method(generic, new_S3_class("S4OldS3b")) <- function(x) "S3 parent" + + object <- methods::new("S4OldS3Child") + + expect_contains(obj_dispatch(object), "S4OldS3b") + expect_equal(generic(object), "S3 parent") +}) + test_that("S4_class_dispatch includes virtual classes", { Foo1 := local_S4_class() Foo2 := local_S4_class(contains = "Foo1") From c0e431c15c16e6b0c90da8105ed4c9b25e59b388 Mon Sep 17 00:00:00 2001 From: Michael Lawrence Date: Tue, 26 May 2026 02:59:33 -0700 Subject: [PATCH 005/132] initial implementation passing a simple test that does not depend on @() behavior, which needs to change in base R. --- R/S4.R | 89 +++++++++++++++++++++++++++++++++++++++- R/class-spec.R | 28 +++++++++---- R/class.R | 30 ++++++++++---- R/constructor.R | 33 ++++++++++++++- R/inherits.R | 15 ++++++- tests/testthat/test-S4.R | 30 ++++++++++++++ 6 files changed, 207 insertions(+), 18 deletions(-) diff --git a/R/S4.R b/R/S4.R index 2f95b25c1..ca464cb27 100644 --- a/R/S4.R +++ b/R/S4.R @@ -36,6 +36,27 @@ S4_register <- function(class, env = parent.frame()) { invisible() } +S4_register_subclass <- function(name, parent, properties, package = NULL, + env = parent.frame()) { + slots <- vcapply( + Filter(prop_is_s4_slot, properties), + function(prop) S4_slot_class(prop$class) + ) + + args <- list( + Class = name, + contains = parent@className, + slots = slots, + where = topenv(env) + ) + if (!is.null(package)) { + args$package <- package + } + + do.call(methods::setClass, args) + methods::getClass(name, where = topenv(env)) +} + is_S4_class <- function(x) inherits(x, "classRepresentation") S4_to_S7_class <- function(x, error_base = "", call = sys.call(-1L)) { @@ -76,6 +97,68 @@ S4_to_S7_class <- function(x, error_base = "", call = sys.call(-1L)) { } } +S4_slot_properties <- function(class) { + properties <- Map(S4_slot_property, class@slots, names(class@slots)) + names(properties) <- names(class@slots) + properties +} + +S4_slot_property <- function(class, name) { + prop <- new_property( + class = S4_slot_as_class(class), + getter = S4_slot_getter(name), + setter = S4_slot_setter(name), + name = name + ) + attr(prop, "S4_slot") <- TRUE + prop +} + +S4_slot_as_class <- function(class) { + S4_to_S7_class(methods::getClass(class)) +} + +S4_slot_getter <- function(name) { + force(name) + function(self) { + methods::slot(self, name) + } +} + +S4_slot_setter <- function(name) { + force(name) + function(self, value) { + methods::slot(self, name) <- value + self + } +} + +mark_S4_slot_properties <- function(properties) { + for (name in names(properties)) { + if (!prop_is_dynamic(properties[[name]])) { + attr(properties[[name]], "S4_slot") <- TRUE + } + } + properties +} + +prop_is_s4_slot <- function(prop) { + isTRUE(attr(prop, "S4_slot", exact = TRUE)) +} + +S4_slot_class <- function(class) { + switch(class_type(class), + NULL = "NULL", + missing = "ANY", + any = "ANY", + S4 = as.character(class@className), + S7_base = class_register(class), + S7_S3 = class_register(class), + S7 = "ANY", + S7_union = "ANY" + ) +} + S4_basic_classes <- function() { list( NULL = NULL, @@ -191,8 +274,10 @@ find_package_with_symbol <- function(name, env, exclude = NULL) { S4_remove_classes <- function(classes, where = parent.frame()) { for (class in classes) { - suppressWarnings(methods::removeClass(class, topenv(where))) + suppressWarnings( + try(methods::removeClass(class, topenv(where)), silent = TRUE) + ) } } -globalVariables(c("superClass", "virtual")) +globalVariables(c("slots", "superClass", "virtual")) diff --git a/R/class-spec.R b/R/class-spec.R index 59741cae6..536b8ccb6 100644 --- a/R/class-spec.R +++ b/R/class-spec.R @@ -79,6 +79,15 @@ class_type <- function(x) { } } +class_properties <- function(x) { + switch( + class_type(x), + S7 = attr(x, "properties", exact = TRUE) %||% list(), + S4 = S4_slot_properties(x), + list() + ) +} + class_friendly <- function(x) { switch( class_type(x), @@ -190,12 +199,13 @@ class_constructor <- function(.x) { } class_validate <- function(class, object) { + if (is_S4_class(class)) { + methods::validObject(object) + return(NULL) + } + validator <- switch( class_type(class), - S4 = function(object) { - check <- methods::validObject(object, test = TRUE) - if (isTRUE(check)) NULL else check - }, S7 = class@validator, S7_base = class$validator, S7_S3 = class$validator, @@ -253,7 +263,11 @@ class_dispatch <- function(x) { missing = "MISSING", any = character(), S4 = S4_class_dispatch(methods::extends(x)), - S7 = c(S7_class_name(x), class_dispatch(x@parent)), + S7 = c( + S7_class_name(x), + class_dispatch(x@parent), + if (is_S4_class(x@parent)) "S7_object" + ), S7_base = c(x$class, "S7_object"), S7_S3 = c(x$class, "S7_object"), stop2("Unsupported class type.", call = NULL) @@ -300,7 +314,7 @@ class_inherits <- function(x, what) { missing = FALSE, any = TRUE, S4 = isS4(x) && methods::is(x, what), - S7 = inherits(x, "S7_object") && inherits(x, S7_class_name(what)), + S7 = S7_inherits(x, what), S7_base = what$class == base_class(x), S7_union = any(vlapply(what$classes, class_inherits, x = x)), S7_S3 = !isS4(x) && class_dispatch_extends(what$class, class(x)), @@ -343,7 +357,7 @@ class_extends <- function(child, parent) { obj_type <- function(x) { if (identical(x, quote(expr = ))) { "missing" - } else if (inherits(x, "S7_object")) { + } else if (has_S7_class(x)) { "S7" } else if (isS4(x)) { "S4" diff --git a/R/class.R b/R/class.R index 4cbf99bf0..6ee1f5aa8 100644 --- a/R/class.R +++ b/R/class.R @@ -131,18 +131,32 @@ new_class <- function( } } - # Combine properties from parent, overriding as needed - parent_props <- attr(parent, "properties", exact = TRUE) %||% list() new_props <- as_properties(properties) check_prop_names(new_props) + + s4_class <- NULL + if (is_S4_class(parent)) { + new_props <- mark_S4_slot_properties(new_props) + s4_class <- S4_register_subclass(name, parent, new_props, + package = package, + env = parent.frame() + ) + } + + # Combine properties from parent, overriding as needed + parent_props <- class_properties(parent) check_prop_overrides(new_props, parent_props, name, parent) + all_props <- modify_list(parent_props, new_props) + constructor_props <- if (is_S4_class(parent)) all_props else new_props if (is.null(constructor)) { constructor <- new_constructor( parent, - new_props, + constructor_props, envir = parent.frame(), - package = package + package = package, + name = name, + s4_class = s4_class ) } @@ -151,7 +165,7 @@ new_class <- function( attr(object, "name") <- name attr(object, "parent") <- parent attr(object, "package") <- package - attr(object, "properties") <- modify_list(parent_props, new_props) + attr(object, "properties") <- all_props attr(object, "abstract") <- abstract attr(object, "constructor") <- constructor attr(object, "validator") <- validator @@ -249,7 +263,9 @@ c.S7_class <- function(...) { stop2("Can not combine S7 class objects.") } -can_inherit <- function(x) is_base_class(x) || is_S3_class(x) || is_class(x) +can_inherit <- function(x) { + is_base_class(x) || is_S3_class(x) || is_class(x) || is_S4_class(x) +} check_can_inherit <- function( x, @@ -258,7 +274,7 @@ check_can_inherit <- function( ) { if (!can_inherit(x)) { msg <- sprintf( - "`%s` must be an S7 class, S3 class, or base type, not %s.", + "`%s` must be an S7 class, S4 class, S3 class, or base type, not %s.", arg, class_friendly(x) ) diff --git a/R/constructor.R b/R/constructor.R index 528ae3712..685df8276 100644 --- a/R/constructor.R +++ b/R/constructor.R @@ -2,7 +2,9 @@ new_constructor <- function( parent, properties, envir = asNamespace("S7"), - package = NULL + package = NULL, + name = NULL, + s4_class = NULL ) { properties <- as_properties(properties) @@ -37,6 +39,35 @@ new_constructor <- function( )) } + if (is_S4_class(parent)) { + if (is.null(s4_class)) { + s4_class <- parent + } + + arg_info <- constructor_args(parent, properties, envir, package) + self_args <- as_names(names(arg_info$self)) + + parent_name <- ".S4_parent" + parent_fun <- class_constructor(s4_class) + args <- arg_info$self + + s4_args <- self_args[vlapply(properties[names(self_args)], prop_is_s4_slot)] + parent_call <- new_call(parent_name, s4_args) + body <- new_call( + if (has_S7_symbols(envir, "new_object")) { + "new_object" + } else { + c("S7", "new_object") + }, + c(list(parent_call), self_args) + ) + + env <- new.env(parent = envir) + env[[parent_name]] <- parent_fun + + return(new_function(args, body, env)) + } + # We need a name so we get a compact constructor, and the actual function # which we'll embed in the constructor's environment if (is_class(parent)) { diff --git a/R/inherits.R b/R/inherits.R index adb558879..4b06cc022 100644 --- a/R/inherits.R +++ b/R/inherits.R @@ -40,12 +40,25 @@ S7_inherits <- function(x, class = NULL) { class <- as_class(class) if (is.null(class)) { - inherits(x, "S7_object") + has_S7_class(x) } else { class_inherits(x, class) } } +has_S7_class <- function(x) { + class_name_in_attr(x, "S7_object") && + ( + class_name_in_attr(x, "S7_class") || + !is.null(attr(x, "S7_class", exact = TRUE)) + ) +} + +class_name_in_attr <- function(x, name) { + any(identical(name, class(x)) || name %in% attr(x, "class", exact = TRUE)) +} + + #' @export #' @rdname S7_inherits # called from src/prop.c diff --git a/tests/testthat/test-S4.R b/tests/testthat/test-S4.R index 61bfe0be7..a14832035 100644 --- a/tests/testthat/test-S4.R +++ b/tests/testthat/test-S4.R @@ -62,6 +62,36 @@ test_that("errors on non-S4 classes", { expect_snapshot(S4_to_S7_class(1), error = TRUE) }) +test_that("S7 classes can extend S4 classes", { + on.exit(S4_remove_classes(c("Parent", "Child"))) + setClass("Parent", slots = list(x = "numeric")) + + Child <- new_class( + "Child", + parent = getClass("Parent"), + properties = list(y = class_character), + package = NULL + ) + child <- Child(x = 1, y = "a") + + expect_true(isS4(child)) + expect_true(methods::is(child, "Parent")) + expect_true(methods::validObject(child)) + expect_true(S7_inherits(child, Child)) + expect_equal(prop_names(child), c("x", "y")) + expect_equal(prop(child, "x"), 1) + expect_equal(prop(child, "y"), "a") + + prop(child, "x") <- 2 + prop(child, "y") <- "b" + expect_equal(prop(child, "x"), 2) + expect_equal(prop(child, "y"), "b") + expect_equal(methods::slot(child, "x"), 2) + expect_equal(methods::slot(child, "y"), "b") + + expect_error(Child(x = "x", y = "a")) +}) + test_that("S4_class_dispatch returns name of base class", { Foo1 := local_S4_class(slots = list("x" = "numeric")) From b555430d731ca4506b43ae2298b3ebe17ac7a8e1 Mon Sep 17 00:00:00 2001 From: Michael Lawrence Date: Tue, 26 May 2026 03:23:36 -0700 Subject: [PATCH 006/132] route S4 class registration through S4_register() and setOldClass(); S4_register() can now communicate any S7 class structure through the S4class= argument. --- R/S4.R | 116 +++++++++++++++++++++------------------ R/class-spec.R | 4 +- R/class.R | 13 +---- R/constructor.R | 39 ++----------- tests/testthat/test-S4.R | 22 +++++++- 5 files changed, 92 insertions(+), 102 deletions(-) diff --git a/R/S4.R b/R/S4.R index ca464cb27..3d28e5a79 100644 --- a/R/S4.R +++ b/R/S4.R @@ -1,8 +1,9 @@ #' Register an S7 or S3 class with S4 #' #' If you want to use [method<-] to register a method for an S4 generic with -#' an S7 class or an S3 class (created by [new_S3_class()]), you need to call -#' `S4_register()` once. +#' an S7 class that does not extend an S4 class, or an S3 class created by +#' [new_S3_class()], you need to call `S4_register()` once. Classes created by +#' [new_class()] with an S4 parent are registered automatically. #' #' @param class An S7 class created with [new_class()], or an S3 class created #' with [new_S3_class()]. @@ -20,11 +21,14 @@ #' #' S4_generic(Foo()) S4_register <- function(class, env = parent.frame()) { - if (is_class(class)) { - classes <- class_dispatch(class) - } else if (is_S3_class(class)) { - classes <- class$class - } else { + where <- topenv(env) + + if (is_S3_class(class)) { + methods::setOldClass(class$class, where = where) + return(invisible()) + } + + if (!is_class(class)) { msg <- sprintf( "`class` must be an S7 class or an S3 class, not a %s.", obj_desc(class) @@ -32,29 +36,65 @@ S4_register <- function(class, env = parent.frame()) { stop2(msg) } - methods::setOldClass(classes, where = topenv(env)) + classes <- class_dispatch(class) + if ( + "S7_object" %in% classes && + !methods::isClass("S7_object", where = where) + ) { + methods::setOldClass("S7_object", where = where) + } + + s4_slots <- S4_slots_from_properties(class@properties) + if (length(s4_slots) > 0 || is_S4_class(class@parent)) { + methods::setOldClass( + classes, + S4Class = S4_transient_class(class, env, s4_slots), + where = where + ) + } else { + methods::setOldClass(classes, where = where) + } invisible() } -S4_register_subclass <- function(name, parent, properties, package = NULL, - env = parent.frame()) { - slots <- vcapply( - Filter(prop_is_s4_slot, properties), - function(prop) S4_slot_class(prop$class) - ) - +S4_transient_class <- function( + class, + env = parent.frame(), + slots = S4_slots_from_properties(class@properties) +) { + tmp <- new.env(parent = topenv(env)) args <- list( - Class = name, - contains = parent@className, + Class = paste0(".S7_transient_", class@name), slots = slots, - where = topenv(env) + where = tmp ) - if (!is.null(package)) { - args$package <- package + + contains <- S4_transient_contains(class@parent) + if (length(contains) > 0) { + args$contains <- contains + } + + if (!is.null(class@package)) { + args$package <- class@package } do.call(methods::setClass, args) - methods::getClass(name, where = topenv(env)) + methods::getClass(args$Class, where = tmp) +} + +S4_transient_contains <- function(parent) { + if (is_S4_class(parent)) { + parent@className + } else { + character() + } +} + +S4_slots_from_properties <- function(properties) { + properties <- Filter(Negate(prop_is_dynamic), properties) + vcapply(properties, function(prop) { + attr(prop, "S4_slot_class", exact = TRUE) %||% S4_slot_class(prop$class) + }) } is_S4_class <- function(x) inherits(x, "classRepresentation") @@ -106,11 +146,9 @@ S4_slot_properties <- function(class) { S4_slot_property <- function(class, name) { prop <- new_property( class = S4_slot_as_class(class), - getter = S4_slot_getter(name), - setter = S4_slot_setter(name), name = name ) - attr(prop, "S4_slot") <- TRUE + attr(prop, "S4_slot_class") <- class prop } @@ -118,34 +156,6 @@ S4_slot_as_class <- function(class) { S4_to_S7_class(methods::getClass(class)) } -S4_slot_getter <- function(name) { - force(name) - function(self) { - methods::slot(self, name) - } -} - -S4_slot_setter <- function(name) { - force(name) - function(self, value) { - methods::slot(self, name) <- value - self - } -} - -mark_S4_slot_properties <- function(properties) { - for (name in names(properties)) { - if (!prop_is_dynamic(properties[[name]])) { - attr(properties[[name]], "S4_slot") <- TRUE - } - } - properties -} - -prop_is_s4_slot <- function(prop) { - isTRUE(attr(prop, "S4_slot", exact = TRUE)) -} - S4_slot_class <- function(class) { switch(class_type(class), NULL = "NULL", @@ -155,7 +165,7 @@ S4_slot_class <- function(class) { S7_base = class_register(class), S7_S3 = class_register(class), S7 = "ANY", - S7_union = "ANY" + S7_union = if (identical(class, class_numeric)) "numeric" else "ANY" ) } diff --git a/R/class-spec.R b/R/class-spec.R index 536b8ccb6..44ccbe7b2 100644 --- a/R/class-spec.R +++ b/R/class-spec.R @@ -200,7 +200,9 @@ class_constructor <- function(.x) { class_validate <- function(class, object) { if (is_S4_class(class)) { - methods::validObject(object) + if (isS4(object) || methods::isClass(class(object)[[1]])) { + methods::validObject(object) + } return(NULL) } diff --git a/R/class.R b/R/class.R index 6ee1f5aa8..40d559469 100644 --- a/R/class.R +++ b/R/class.R @@ -134,15 +134,6 @@ new_class <- function( new_props <- as_properties(properties) check_prop_names(new_props) - s4_class <- NULL - if (is_S4_class(parent)) { - new_props <- mark_S4_slot_properties(new_props) - s4_class <- S4_register_subclass(name, parent, new_props, - package = package, - env = parent.frame() - ) - } - # Combine properties from parent, overriding as needed parent_props <- class_properties(parent) check_prop_overrides(new_props, parent_props, name, parent) @@ -154,9 +145,7 @@ new_class <- function( parent, constructor_props, envir = parent.frame(), - package = package, - name = name, - s4_class = s4_class + package = package ) } diff --git a/R/constructor.R b/R/constructor.R index 685df8276..14439e07b 100644 --- a/R/constructor.R +++ b/R/constructor.R @@ -2,13 +2,15 @@ new_constructor <- function( parent, properties, envir = asNamespace("S7"), - package = NULL, - name = NULL, - s4_class = NULL + package = NULL ) { properties <- as_properties(properties) - if (identical(parent, S7_object) || (is_class(parent) && parent@abstract)) { + if ( + identical(parent, S7_object) || + is_S4_class(parent) || + (is_class(parent) && parent@abstract) + ) { # There's no parent constructor to delegate to, so the constructor must # handle all properties: inherited and newly declared (which win). all_props <- modify_list( @@ -39,35 +41,6 @@ new_constructor <- function( )) } - if (is_S4_class(parent)) { - if (is.null(s4_class)) { - s4_class <- parent - } - - arg_info <- constructor_args(parent, properties, envir, package) - self_args <- as_names(names(arg_info$self)) - - parent_name <- ".S4_parent" - parent_fun <- class_constructor(s4_class) - args <- arg_info$self - - s4_args <- self_args[vlapply(properties[names(self_args)], prop_is_s4_slot)] - parent_call <- new_call(parent_name, s4_args) - body <- new_call( - if (has_S7_symbols(envir, "new_object")) { - "new_object" - } else { - c("S7", "new_object") - }, - c(list(parent_call), self_args) - ) - - env <- new.env(parent = envir) - env[[parent_name]] <- parent_fun - - return(new_function(args, body, env)) - } - # We need a name so we get a compact constructor, and the actual function # which we'll embed in the constructor's environment if (is_class(parent)) { diff --git a/tests/testthat/test-S4.R b/tests/testthat/test-S4.R index a14832035..9be86eb37 100644 --- a/tests/testthat/test-S4.R +++ b/tests/testthat/test-S4.R @@ -74,9 +74,7 @@ test_that("S7 classes can extend S4 classes", { ) child <- Child(x = 1, y = "a") - expect_true(isS4(child)) - expect_true(methods::is(child, "Parent")) - expect_true(methods::validObject(child)) + expect_false(isS4(child)) expect_true(S7_inherits(child, Child)) expect_equal(prop_names(child), c("x", "y")) expect_equal(prop(child, "x"), 1) @@ -86,12 +84,30 @@ test_that("S7 classes can extend S4 classes", { prop(child, "y") <- "b" expect_equal(prop(child, "x"), 2) expect_equal(prop(child, "y"), "b") + + S4_register(Child) + expect_true(methods::is(child, "Parent")) + expect_true(methods::validObject(child)) + expect_equal(methods::slotNames("Child"), c("x", "y", ".S3Class")) expect_equal(methods::slot(child, "x"), 2) expect_equal(methods::slot(child, "y"), "b") expect_error(Child(x = "x", y = "a")) }) +test_that("S4_register uses S7 properties as known S4 attributes", { + on.exit(S4_remove_classes("Foo")) + Foo <- new_class("Foo", properties = list(x = class_numeric), package = NULL) + foo <- Foo(x = 1) + + S4_register(Foo) + expect_true(methods::validObject(foo)) + expect_equal(methods::slot(foo, "x"), 1) + + attr(foo, "x") <- "x" + expect_error(methods::validObject(foo), "invalid object") +}) + test_that("S4_class_dispatch returns name of base class", { Foo1 := local_S4_class(slots = list("x" = "numeric")) From a57ebf256c91b87fcd0e81ea0cd9db610f03919a Mon Sep 17 00:00:00 2001 From: Michael Lawrence Date: Tue, 26 May 2026 12:23:11 -0700 Subject: [PATCH 007/132] add a .lintr.R to allow for our symbol naming convention --- .Rbuildignore | 1 + .lintr.R | 1 + 2 files changed, 2 insertions(+) create mode 100644 .lintr.R diff --git a/.Rbuildignore b/.Rbuildignore index 7ee683ae9..e1944324a 100644 --- a/.Rbuildignore +++ b/.Rbuildignore @@ -23,3 +23,4 @@ ^\.claude$ ^\.git-blame-ignore-revs$ ^AGENTS\.md$ +^\.lintr\.R$ diff --git a/.lintr.R b/.lintr.R new file mode 100644 index 000000000..eac429f6e --- /dev/null +++ b/.lintr.R @@ -0,0 +1 @@ +linters <- lintr::linters_with_defaults() From 7c738c466d4f6e3e6fdfa716ec485df9be05cba4 Mon Sep 17 00:00:00 2001 From: Michael Lawrence Date: Tue, 26 May 2026 14:35:44 -0700 Subject: [PATCH 008/132] S4-derived classes gain an initialize() method that mimics the default initialize() except uses the S7 property setting path. --- R/S4.R | 56 +++++++++++++++++++++++++++++++++ tests/testthat/test-S4.R | 67 ++++++++++++++++++++++++++++++++++++++++ 2 files changed, 123 insertions(+) diff --git a/R/S4.R b/R/S4.R index 3d28e5a79..2fd123274 100644 --- a/R/S4.R +++ b/R/S4.R @@ -54,9 +54,65 @@ S4_register <- function(class, env = parent.frame()) { } else { methods::setOldClass(classes, where = where) } + methods::setMethod("initialize", classes[1], S4_initialize, where = where) invisible() } +S4_initialize <- function(.Object, ...) { + args <- list(...) + if (length(args) == 0) { + return(.Object) + } + + nms <- names2(args) + prop_nms <- prop_names(.Object) + vals <- list() + data_part <- NULL + for (arg in args[nms == ""]) { + arg_vals <- S4_initialize_values(arg) + if (".Data" %in% names(arg_vals)) { + data_part <- arg + } + arg_vals <- arg_vals[names(arg_vals) %in% prop_nms] + vals <- modify_list(vals, arg_vals) + } + named_args <- args[nms != ""] + vals <- modify_list(vals, named_args) + if (".Data" %in% names(named_args)) { + data_part <- vals$.Data + } + + if (!is.null(data_part)) { + .Object <- S4_initialize_data_part(data_part, .Object) + } + + props(.Object) <- vals + .Object +} + +S4_initialize_values <- function(object) { + if (S7_inherits(object)) { + props(object) + } else if (isS4(object)) { + slots <- methods::slotNames(object) + stats::setNames(lapply(slots, methods::slot, object = object), slots) + } else { + attrs <- attributes(object) %||% list() + attrs$class <- NULL + if (is.object(object)) { + attrs$.S3Class <- class(object) + } + c(list(.Data = unclass(object)), attrs) + } +} + +S4_initialize_data_part <- function(value, object) { + incoming <- attributes(value) %||% list() + incoming$class <- NULL + attributes(value) <- modify_list(attributes(object), incoming) + value +} + S4_transient_class <- function( class, env = parent.frame(), diff --git a/tests/testthat/test-S4.R b/tests/testthat/test-S4.R index 9be86eb37..ec9604ea1 100644 --- a/tests/testthat/test-S4.R +++ b/tests/testthat/test-S4.R @@ -92,9 +92,53 @@ test_that("S7 classes can extend S4 classes", { expect_equal(methods::slot(child, "x"), 2) expect_equal(methods::slot(child, "y"), "b") + child <- methods::initialize(child, x = 3, y = "c") + expect_equal(prop(child, "x"), 3) + expect_equal(prop(child, "y"), "c") + expect_true(methods::validObject(child)) + + child <- methods::initialize(child, Child(x = 4, y = "d"), y = "e") + expect_equal(prop(child, "x"), 4) + expect_equal(prop(child, "y"), "e") + + parent <- methods::new("Parent", x = 5) + child <- methods::initialize(child, parent, y = "f") + expect_equal(prop(child, "x"), 5) + expect_equal(prop(child, "y"), "f") + + child <- methods::initialize(child, x = 6, x = 7) + expect_equal(prop(child, "x"), 7) + + expect_error(methods::initialize(child, x = "x"), "invalid") + expect_error(methods::initialize(child, z = 1), "Can't find property") + expect_error(Child(x = "x", y = "a")) }) +test_that("S4 initialize supports S3 data parts", { + on.exit(S4_remove_classes(c("ParentNum", "ChildNum"))) + setClass("ParentNum", contains = "numeric", slots = list(y = "character")) + + ChildNum <- new_class( + "ChildNum", + parent = getClass("ParentNum"), + properties = list(z = class_integer), + package = NULL + ) + child <- ChildNum(y = "a", z = 1L) + S4_register(ChildNum) + + child <- methods::initialize(child, 2.5, y = "b") + expect_equal(as.vector(child), 2.5) + expect_equal(prop(child, ".Data"), 2.5) + expect_equal(prop(child, "y"), "b") + expect_true(methods::validObject(child)) + + child <- methods::initialize(child, .Data = 3.5) + expect_equal(as.vector(child), 3.5) + expect_true(methods::validObject(child)) +}) + test_that("S4_register uses S7 properties as known S4 attributes", { on.exit(S4_remove_classes("Foo")) Foo <- new_class("Foo", properties = list(x = class_numeric), package = NULL) @@ -108,6 +152,29 @@ test_that("S4_register uses S7 properties as known S4 attributes", { expect_error(methods::validObject(foo), "invalid object") }) +test_that("S4 initialize uses S7 property setters", { + on.exit(S4_remove_classes(c("Parent2", "Child2"))) + setClass("Parent2", slots = list(x = "numeric")) + + Child2 <- new_class( + "Child2", + parent = getClass("Parent2"), + properties = list( + y = new_property(class_character, setter = function(self, value) { + attr(self, "setter_called") <- TRUE + attr(self, "y") <- value + self + }) + ), + package = NULL + ) + S4_register(Child2) + + child <- methods::initialize(Child2(x = 1, y = "a"), y = "b") + expect_equal(prop(child, "y"), "b") + expect_true(attr(child, "setter_called")) +}) + test_that("S4_class_dispatch returns name of base class", { Foo1 := local_S4_class(slots = list("x" = "numeric")) From ecc7ed1a6ea6d0cc7eb7c0bba0406792733255b9 Mon Sep 17 00:00:00 2001 From: Michael Lawrence Date: Tue, 26 May 2026 15:43:18 -0700 Subject: [PATCH 009/132] call S4_register() automatically on S7 derivatives of S4 classes; fix parent object construction in constructor. --- R/class.R | 7 +++++++ R/constructor.R | 34 +++++++++++++++++++++++++++++----- man/S4_register.Rd | 6 ++++-- tests/testthat/test-S4.R | 3 --- 4 files changed, 40 insertions(+), 10 deletions(-) diff --git a/R/class.R b/R/class.R index 40d559469..5d5fe52f0 100644 --- a/R/class.R +++ b/R/class.R @@ -55,6 +55,9 @@ #' belong to each instance of the class. Each element of the list can #' either be a type specification (processed by [as_class()]) or a #' full property specification created [new_property()]. +#' @section S4 compatibility: +#' ```{r child = "man/rmd/S4-compatibility.Rmd"} +#' ``` #' @return A object constructor, a function that can be used to create objects #' of the given class. #' @export @@ -160,6 +163,10 @@ new_class <- function( attr(object, "validator") <- validator class(object) <- c("S7_class", "S7_object") + if (is_S4_class(parent)) { + S4_register(object, env = parent.frame()) + } + global_variables(names(new_props)) object } diff --git a/R/constructor.R b/R/constructor.R index 14439e07b..645bc1923 100644 --- a/R/constructor.R +++ b/R/constructor.R @@ -21,12 +21,27 @@ new_constructor <- function( arg_info <- constructor_args(parent, all_props, envir, package) self_args <- as_names(names(arg_info$self)) - new_object_call <- - if (has_S7_symbols(envir, "new_object", "S7_object")) { - bquote(new_object(S7_object(), ..(self_args)), splice = TRUE) + if (is_S4_class(parent)) { + parent_expr <- quote(.S4_parent_object(.S4_parent)) + env <- new.env(parent = envir) + env$.S4_parent <- parent + env$.S4_parent_object <- S4_parent_object + } else { + parent_expr <- if (has_S7_symbols(envir, "S7_object")) { + quote(S7_object()) } else { - bquote(S7::new_object(S7::S7_object(), ..(self_args)), splice = TRUE) + quote(S7::S7_object()) } + env <- envir + } + new_object_call <- new_call( + if (has_S7_symbols(envir, "new_object")) { + "new_object" + } else { + c("S7", "new_object") + }, + c(list(parent_expr), self_args) + ) return(new_function( args = arg_info$self, @@ -37,7 +52,7 @@ new_constructor <- function( unname(self_args), new_object_call )), - env = envir + env = env )) } @@ -158,3 +173,12 @@ has_S7_symbols <- function(env, ...) { symbols <- c(...) %||% getNamespaceExports("S7") all(symbols %in% imports) } + +S4_parent_object <- function(parent) { + prototype <- parent@prototype + if (".Data" %in% names(parent@slots)) { + methods::slot(prototype, ".Data") + } else { + S7_object() + } +} diff --git a/man/S4_register.Rd b/man/S4_register.Rd index 14766a99d..6c4a2d28b 100644 --- a/man/S4_register.Rd +++ b/man/S4_register.Rd @@ -17,8 +17,10 @@ Nothing; the function is called for its side-effect. } \description{ If you want to use \link{method<-} to register a method for an S4 generic with -an S7 class or an S3 class (created by \code{\link[=new_S3_class]{new_S3_class()}}), you need to call -\code{S4_register()} once. +an S7 class that does not extend an S4 class, or an S3 class created by +\code{\link[=new_S3_class]{new_S3_class()}}, you need to call +\code{S4_register()} once. Classes created by \code{\link[=new_class]{new_class()}} with an S4 parent +are registered automatically. } \examples{ methods::setGeneric("S4_generic", function(x) { diff --git a/tests/testthat/test-S4.R b/tests/testthat/test-S4.R index ec9604ea1..164eb1bd5 100644 --- a/tests/testthat/test-S4.R +++ b/tests/testthat/test-S4.R @@ -85,7 +85,6 @@ test_that("S7 classes can extend S4 classes", { expect_equal(prop(child, "x"), 2) expect_equal(prop(child, "y"), "b") - S4_register(Child) expect_true(methods::is(child, "Parent")) expect_true(methods::validObject(child)) expect_equal(methods::slotNames("Child"), c("x", "y", ".S3Class")) @@ -126,7 +125,6 @@ test_that("S4 initialize supports S3 data parts", { package = NULL ) child <- ChildNum(y = "a", z = 1L) - S4_register(ChildNum) child <- methods::initialize(child, 2.5, y = "b") expect_equal(as.vector(child), 2.5) @@ -168,7 +166,6 @@ test_that("S4 initialize uses S7 property setters", { ), package = NULL ) - S4_register(Child2) child <- methods::initialize(Child2(x = 1, y = "a"), y = "b") expect_equal(prop(child, "y"), "b") From acc4990d297b5a6236b8c7203b9ab0aafd8bf619 Mon Sep 17 00:00:00 2001 From: Michael Lawrence Date: Tue, 26 May 2026 15:43:35 -0700 Subject: [PATCH 010/132] add some detailed notes on S4 compatibility to docs --- man/new_class.Rd | 55 ++++++++++++++++++++++++++++++++++++ man/rmd/S4-compatibility.Rmd | 50 ++++++++++++++++++++++++++++++++ 2 files changed, 105 insertions(+) create mode 100644 man/rmd/S4-compatibility.Rmd diff --git a/man/new_class.Rd b/man/new_class.Rd index b5a3251bc..86e12075b 100644 --- a/man/new_class.Rd +++ b/man/new_class.Rd @@ -92,6 +92,61 @@ when an object is passed to a generic. Learn more in \code{vignette("classes-objects")} } +\section{S4 compatibility}{ + +When an S7 class extends an S4 class, \code{new_class()} automatically registers the +new class with S4. After that, an S4 generic with a method for \code{Parent} will +dispatch on a \code{Child} instance: + +\if{html}{\out{
}}\preformatted{setMethod("g", "Parent", function(x) ...) +g(child) # uses Parent method if no more specific Child method exists +}\if{html}{\out{
}} + +But the method receives the original S7 object, not a formal S4 instance, so +this approach is a compatibility bridge, not full substitutability. + +Things that work reasonably: +\itemize{ +\item \code{methods::is(child, "Parent")} returns \code{TRUE}. +\item S4 dispatch inherits through \code{Parent}. +\item \code{methods::validObject(child)} can validate known S7/S4 attributes. +\item \code{methods::slotNames(child)} works. +\item \code{methods::slot(child, "x")} works for registered slots and properties, as +long as they are represented by stored attributes. +\item \code{child@x} works through S7 property access. With the current oldClass +representation, the object is not S4-bit so \code{@} can dispatch to S7's +\verb{@.S7_object} method. If S7 objects that extend S4 classes are represented +as S4-bit objects in the future, R's \code{@} primitive will need to dispatch +before taking the S4 slot-access path. +\item \code{as(child, "Parent")} can produce a real S4 \code{Parent} object containing the +parent slots. +} + +Likely brittle or incompatible with S4-method assumptions: +\itemize{ +\item \code{isS4(child)} is \code{FALSE} with the current oldClass representation. This +avoids advertising formal S4 object invariants that S7 objects do not +satisfy. S4 code is still exposed to S3-compatible, non-scalar \code{class()} +vectors through the oldClass bridge. +\item \code{class(child)} is length greater than 1, for example +\code{c("Child", "S4/Parent", "S7_object")}. This can break S4 code that treats +\code{class()} as a scalar class name. Code that needs a scalar primary class +name should use \code{class(x)[[1L]]}, or \code{methods::class1(x)} once that helper +has been made public. +\item Methods that access slots with \code{methods::slot()} and \verb{methods::slot<-()} +bypass the S7 property layer. This is mostly a problem when the S7 class +defines properties that override the slots from its parent. This is similar +to deriving from an S3 class whose methods use \code{attr()} and \verb{attr<-()} +directly. Overriding S4 slots is therefore discouraged. +} + +In summary, inherited S4 methods must be written against the "registered +oldClass with known attributes" contract, not the stricter "formal S4 +instance" contract. They should use a scalar primary-class helper where +appropriate and avoid \code{slot()} and \verb{slot<-()} when they need S7 property +management to apply. +} + \examples{ # Create an class that represents a range using a numeric start and end Range := new_class( diff --git a/man/rmd/S4-compatibility.Rmd b/man/rmd/S4-compatibility.Rmd new file mode 100644 index 000000000..ab833c0de --- /dev/null +++ b/man/rmd/S4-compatibility.Rmd @@ -0,0 +1,50 @@ +When an S7 class extends an S4 class, `new_class()` automatically registers the +new class with S4. After that, an S4 generic with a method for `Parent` will +dispatch on a `Child` instance: + +```r +setMethod("g", "Parent", function(x) ...) +g(child) # uses Parent method if no more specific Child method exists +``` + +But the method receives the original S7 object, not a formal S4 instance, so +this approach is a compatibility bridge, not full substitutability. + +Things that work reasonably: + +* `methods::is(child, "Parent")` returns `TRUE`. +* S4 dispatch inherits through `Parent`. +* `methods::validObject(child)` can validate known S7/S4 attributes. +* `methods::slotNames(child)` works. +* `methods::slot(child, "x")` works for registered slots and properties, as + long as they are represented by stored attributes. +* `child@x` works through S7 property access. With the current oldClass + representation, the object is not S4-bit so `@` can dispatch to S7's + `@.S7_object` method. If S7 objects that extend S4 classes are represented + as S4-bit objects in the future, R's `@` primitive will need to dispatch + before taking the S4 slot-access path. +* `as(child, "Parent")` can produce a real S4 `Parent` object containing the + parent slots. + +Likely brittle or incompatible with S4-method assumptions: + +* `isS4(child)` is `FALSE` with the current oldClass representation. This + avoids advertising formal S4 object invariants that S7 objects do not + satisfy. S4 code is still exposed to S3-compatible, non-scalar `class()` + vectors through the oldClass bridge. +* `class(child)` is length greater than 1, for example + `c("Child", "S4/Parent", "S7_object")`. This can break S4 code that treats + `class()` as a scalar class name. Code that needs a scalar primary class + name should use `class(x)[[1L]]`, or `methods::class1(x)` once that helper + has been made public. +* Methods that access slots with `methods::slot()` and `methods::slot<-()` + bypass the S7 property layer. This is mostly a problem when the S7 class + defines properties that override the slots from its parent. This is similar + to deriving from an S3 class whose methods use `attr()` and `attr<-()` + directly. Overriding S4 slots is therefore discouraged. + +In summary, inherited S4 methods must be written against the "registered +oldClass with known attributes" contract, not the stricter "formal S4 +instance" contract. They should use a scalar primary-class helper where +appropriate and avoid `slot()` and `slot<-()` when they need S7 property +management to apply. From a1c439d83caf2cbb6e1a7a5fc1ea85e9e052ca1d Mon Sep 17 00:00:00 2001 From: Michael Lawrence Date: Tue, 26 May 2026 16:27:33 -0700 Subject: [PATCH 011/132] fix S7 inheritance checks after rebase --- R/class-spec.R | 4 ++-- R/class.R | 7 +++++++ R/inherits.R | 2 ++ 3 files changed, 11 insertions(+), 2 deletions(-) diff --git a/R/class-spec.R b/R/class-spec.R index 44ccbe7b2..4c60302b2 100644 --- a/R/class-spec.R +++ b/R/class-spec.R @@ -315,8 +315,8 @@ class_inherits <- function(x, what) { "NULL" = is.null(x), missing = FALSE, any = TRUE, - S4 = isS4(x) && methods::is(x, what), - S7 = S7_inherits(x, what), + S4 = methods::is(x, what), + S7 = has_S7_class(x) && class_name_in_attr(x, S7_class_name(what)), S7_base = what$class == base_class(x), S7_union = any(vlapply(what$classes, class_inherits, x = x)), S7_S3 = !isS4(x) && class_dispatch_extends(what$class, class(x)), diff --git a/R/class.R b/R/class.R index 5d5fe52f0..8b6389966 100644 --- a/R/class.R +++ b/R/class.R @@ -306,6 +306,13 @@ check_parent <- function(parent, class, call = sys.call(-1L)) { return() } + # S4 parent compatibility is checked after new_object() installs the S7 + # class attributes, at which point methods::validObject() can see the + # registered oldClass structure. + if (is_S4_class(parent_class)) { + return() + } + if (class_inherits(parent, parent_class)) { return() } diff --git a/R/inherits.R b/R/inherits.R index 4b06cc022..87201f10f 100644 --- a/R/inherits.R +++ b/R/inherits.R @@ -47,8 +47,10 @@ S7_inherits <- function(x, class = NULL) { } has_S7_class <- function(x) { + classes <- attr(x, "class", exact = TRUE) class_name_in_attr(x, "S7_object") && ( + identical(classes, "S7_object") || class_name_in_attr(x, "S7_class") || !is.null(attr(x, "S7_class", exact = TRUE)) ) From 5f88cf6dab3a2dc722fd502f31ff671f4ae2e06c Mon Sep 17 00:00:00 2001 From: Michael Lawrence Date: Tue, 26 May 2026 17:05:44 -0700 Subject: [PATCH 012/132] drop the S7_object case from S4_register --- R/S4.R | 7 ------- 1 file changed, 7 deletions(-) diff --git a/R/S4.R b/R/S4.R index 2fd123274..91500a5cf 100644 --- a/R/S4.R +++ b/R/S4.R @@ -37,13 +37,6 @@ S4_register <- function(class, env = parent.frame()) { } classes <- class_dispatch(class) - if ( - "S7_object" %in% classes && - !methods::isClass("S7_object", where = where) - ) { - methods::setOldClass("S7_object", where = where) - } - s4_slots <- S4_slots_from_properties(class@properties) if (length(s4_slots) > 0 || is_S4_class(class@parent)) { methods::setOldClass( From bc8e0e12cd45b2cc256c00fb3eb00e2f56ec5393 Mon Sep 17 00:00:00 2001 From: Michael Lawrence Date: Tue, 26 May 2026 17:27:53 -0700 Subject: [PATCH 013/132] docs: recommend use of initialize() when working with S7 derivatives of S4 --- man/new_class.Rd | 12 ++++++++++++ man/rmd/S4-compatibility.Rmd | 13 +++++++++++++ 2 files changed, 25 insertions(+) diff --git a/man/new_class.Rd b/man/new_class.Rd index 86e12075b..81a048cb2 100644 --- a/man/new_class.Rd +++ b/man/new_class.Rd @@ -118,6 +118,11 @@ representation, the object is not S4-bit so \code{@} can dispatch to S7's \verb{@.S7_object} method. If S7 objects that extend S4 classes are represented as S4-bit objects in the future, R's \code{@} primitive will need to dispatch before taking the S4 slot-access path. +\item \code{methods::initialize(child, ...)} works for reinitializing an existing S7 +object through S4 code. This is preferable to constructing a fresh object +with \code{methods::new(class(child)[[1L]], ...)}, because S4 construction creates +a formal S4 object with the oldClass structure but without the S7 metadata +that S7 property management requires. \item \code{as(child, "Parent")} can produce a real S4 \code{Parent} object containing the parent slots. } @@ -138,6 +143,13 @@ bypass the S7 property layer. This is mostly a problem when the S7 class defines properties that override the slots from its parent. This is similar to deriving from an S3 class whose methods use \code{attr()} and \verb{attr<-()} directly. Overriding S4 slots is therefore discouraged. +\item Calls like \code{methods::new(class(x)[[1L]], ...)} or +\code{methods::new(class1(x), ...)} construct a new S4 object from S4's class +definition. For an S7 class registered with S4, the result can satisfy +\code{inherits(object, "S7_object")} through the S4 oldClass graph while still +lacking the \code{S7_class} attribute. Such objects are not S7 instances. Code +that is updating an existing object should prefer \code{methods::initialize(x, ...)}, which gives S7's S4 \code{initialize()} method a chance to preserve S7 +metadata and route values through properties. } In summary, inherited S4 methods must be written against the "registered diff --git a/man/rmd/S4-compatibility.Rmd b/man/rmd/S4-compatibility.Rmd index ab833c0de..edbbfc35b 100644 --- a/man/rmd/S4-compatibility.Rmd +++ b/man/rmd/S4-compatibility.Rmd @@ -23,6 +23,11 @@ Things that work reasonably: `@.S7_object` method. If S7 objects that extend S4 classes are represented as S4-bit objects in the future, R's `@` primitive will need to dispatch before taking the S4 slot-access path. +* `methods::initialize(child, ...)` works for reinitializing an existing S7 + object through S4 code. This is preferable to constructing a fresh object + with `methods::new(class(child)[[1L]], ...)`, because S4 construction creates + a formal S4 object with the oldClass structure but without the S7 metadata + that S7 property management requires. * `as(child, "Parent")` can produce a real S4 `Parent` object containing the parent slots. @@ -42,6 +47,14 @@ Likely brittle or incompatible with S4-method assumptions: defines properties that override the slots from its parent. This is similar to deriving from an S3 class whose methods use `attr()` and `attr<-()` directly. Overriding S4 slots is therefore discouraged. +* Calls like `methods::new(class(x)[[1L]], ...)` or + `methods::new(class1(x), ...)` construct a new S4 object from S4's class + definition. For an S7 class registered with S4, the result can satisfy + `inherits(object, "S7_object")` through the S4 oldClass graph while still + lacking the `S7_class` attribute. Such objects are not S7 instances. Code + that is updating an existing object should prefer `methods::initialize(x, + ...)`, which gives S7's S4 `initialize()` method a chance to preserve S7 + metadata and route values through properties. In summary, inherited S4 methods must be written against the "registered oldClass with known attributes" contract, not the stricter "formal S4 From e569bfe1cbcae33750fdc66cc054b6855f9dc901 Mon Sep 17 00:00:00 2001 From: Michael Lawrence Date: Tue, 26 May 2026 17:29:25 -0700 Subject: [PATCH 014/132] clean up inheritance logic changes --- R/class-spec.R | 2 +- R/inherits.R | 15 +++------------ 2 files changed, 4 insertions(+), 13 deletions(-) diff --git a/R/class-spec.R b/R/class-spec.R index 4c60302b2..f69a2eed7 100644 --- a/R/class-spec.R +++ b/R/class-spec.R @@ -316,7 +316,7 @@ class_inherits <- function(x, what) { missing = FALSE, any = TRUE, S4 = methods::is(x, what), - S7 = has_S7_class(x) && class_name_in_attr(x, S7_class_name(what)), + S7 = has_S7_class(x) && inherits(x, S7_class_name(what)), S7_base = what$class == base_class(x), S7_union = any(vlapply(what$classes, class_inherits, x = x)), S7_S3 = !isS4(x) && class_dispatch_extends(what$class, class(x)), diff --git a/R/inherits.R b/R/inherits.R index 87201f10f..9d5501d05 100644 --- a/R/inherits.R +++ b/R/inherits.R @@ -47,20 +47,11 @@ S7_inherits <- function(x, class = NULL) { } has_S7_class <- function(x) { - classes <- attr(x, "class", exact = TRUE) - class_name_in_attr(x, "S7_object") && - ( - identical(classes, "S7_object") || - class_name_in_attr(x, "S7_class") || - !is.null(attr(x, "S7_class", exact = TRUE)) - ) + identical(class(x), "S7_object") || + inherits(x, "S7_class") || + !is.null(attr(x, "S7_class", exact = TRUE)) } -class_name_in_attr <- function(x, name) { - any(identical(name, class(x)) || name %in% attr(x, "class", exact = TRUE)) -} - - #' @export #' @rdname S7_inherits # called from src/prop.c From ae224f075794bc85b073a553de83255244c235ad Mon Sep 17 00:00:00 2001 From: Michael Lawrence Date: Tue, 26 May 2026 23:23:27 -0700 Subject: [PATCH 015/132] just remove classes that exist instead of using try() --- R/S4.R | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) diff --git a/R/S4.R b/R/S4.R index 91500a5cf..393cf68a2 100644 --- a/R/S4.R +++ b/R/S4.R @@ -332,10 +332,11 @@ find_package_with_symbol <- function(name, env, exclude = NULL) { } S4_remove_classes <- function(classes, where = parent.frame()) { + where <- topenv(where) for (class in classes) { - suppressWarnings( - try(methods::removeClass(class, topenv(where)), silent = TRUE) - ) + if (methods::isClass(class, where = where)) { + methods::removeClass(class, where) + } } } From a7bf54ae08e2c1d401488a3e5a02bba8475f60b9 Mon Sep 17 00:00:00 2001 From: Michael Lawrence Date: Tue, 26 May 2026 23:42:13 -0700 Subject: [PATCH 016/132] update the global variables for our use of @, which still confuses codetools --- R/S4.R | 12 +++++++++++- 1 file changed, 11 insertions(+), 1 deletion(-) diff --git a/R/S4.R b/R/S4.R index 393cf68a2..432501e5d 100644 --- a/R/S4.R +++ b/R/S4.R @@ -340,4 +340,14 @@ S4_remove_classes <- function(classes, where = parent.frame()) { } } -globalVariables(c("slots", "superClass", "virtual")) +globalVariables(c( + ".Data", + "className", + "distance", + "package", + "prototype", + "slots", + "subClass", + "superClass", + "virtual" +)) From 319c8afc641ed613d9715ff104955255d3e0a850 Mon Sep 17 00:00:00 2001 From: Michael Lawrence Date: Wed, 27 May 2026 00:08:58 -0700 Subject: [PATCH 017/132] clean up constructor generation --- R/constructor.R | 40 +++++++++++++--------------------------- 1 file changed, 13 insertions(+), 27 deletions(-) diff --git a/R/constructor.R b/R/constructor.R index 645bc1923..86e8403c0 100644 --- a/R/constructor.R +++ b/R/constructor.R @@ -21,27 +21,22 @@ new_constructor <- function( arg_info <- constructor_args(parent, all_props, envir, package) self_args <- as_names(names(arg_info$self)) - if (is_S4_class(parent)) { - parent_expr <- quote(.S4_parent_object(.S4_parent)) - env <- new.env(parent = envir) - env$.S4_parent <- parent - env$.S4_parent_object <- S4_parent_object + s4_data_part <- is_S4_class(parent) && ".Data" %in% names(parent@slots) + parent_call <- if (s4_data_part) { + bquote( + methods::getClass(.(as.character(parent@className)))@prototype@.Data + ) + } else if (has_S7_symbols(envir, "S7_object")) { + quote(S7_object()) } else { - parent_expr <- if (has_S7_symbols(envir, "S7_object")) { - quote(S7_object()) - } else { - quote(S7::S7_object()) - } - env <- envir + quote(S7::S7_object()) } - new_object_call <- new_call( + new_object_call <- if (has_S7_symbols(envir, "new_object")) { - "new_object" + bquote(new_object(.(parent_call), ..(self_args)), splice = TRUE) } else { - c("S7", "new_object") - }, - c(list(parent_expr), self_args) - ) + bquote(S7::new_object(.(parent_call), ..(self_args)), splice = TRUE) + } return(new_function( args = arg_info$self, @@ -52,7 +47,7 @@ new_constructor <- function( unname(self_args), new_object_call )), - env = env + env = envir )) } @@ -173,12 +168,3 @@ has_S7_symbols <- function(env, ...) { symbols <- c(...) %||% getNamespaceExports("S7") all(symbols %in% imports) } - -S4_parent_object <- function(parent) { - prototype <- parent@prototype - if (".Data" %in% names(parent@slots)) { - methods::slot(prototype, ".Data") - } else { - S7_object() - } -} From 9b38c5a22d38a9f30cad88294b36f27c799db0d8 Mon Sep 17 00:00:00 2001 From: Michael Lawrence Date: Wed, 27 May 2026 11:59:52 -0700 Subject: [PATCH 018/132] fix test guarding against extension of S4 classes --- tests/testthat/_snaps/class.md | 15 +++++++++------ tests/testthat/test-class.R | 4 ++-- 2 files changed, 11 insertions(+), 8 deletions(-) diff --git a/tests/testthat/_snaps/class.md b/tests/testthat/_snaps/class.md index 941c207a1..6e6f25af2 100644 --- a/tests/testthat/_snaps/class.md +++ b/tests/testthat/_snaps/class.md @@ -107,13 +107,17 @@ Error in `new_class()`: ! `validator` must be function(self), not function(). -# S7 classes can't inherit from S4 or class unions +# S7 classes can inherit from S4 but not class unions Code - new_class("test", parent = parentS4) - Condition - Error in `new_class()`: - ! `parent` must be an S7 class, S3 class, or base type, not an S4 class. + new_class("test", parent = parentS4, package = NULL) + Output + class + @ parent : S4 + @ constructor: function(x) {...} + @ validator : + @ properties : + $ x: or Code new_class("test", parent = new_union("character")) Condition @@ -314,4 +318,3 @@ Condition Error: ! No S7 class for base type . - diff --git a/tests/testthat/test-class.R b/tests/testthat/test-class.R index 6789d2787..fb96b220a 100644 --- a/tests/testthat/test-class.R +++ b/tests/testthat/test-class.R @@ -60,10 +60,10 @@ test_that("S7 classes check inputs", { }) }) -test_that("S7 classes can't inherit from S4 or class unions", { +test_that("S7 classes can inherit from S4 but not class unions", { parentS4 := local_S4_class(slots = c(x = "numeric")) expect_snapshot(error = TRUE, { - new_class("test", parent = parentS4) + new_class("test", parent = parentS4, package = NULL) new_class("test", parent = new_union("character")) }) }) From af08d0e2bf61cfd1f060a06fdb880ad06c8c65d4 Mon Sep 17 00:00:00 2001 From: Michael Lawrence Date: Wed, 27 May 2026 13:33:42 -0700 Subject: [PATCH 019/132] allow abstract classes to inhert from virtual S4 classes --- R/class.R | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/R/class.R b/R/class.R index 8b6389966..07aa20b2e 100644 --- a/R/class.R +++ b/R/class.R @@ -128,7 +128,9 @@ new_class <- function( } if ( abstract && - (!is_class(parent) || !(parent@abstract || parent@name == "S7_object")) + !((is_class(parent) && + (parent@abstract || parent@name == "S7_object")) || + (is_S4_class(parent) && parent@virtual)) ) { stop2("Abstract classes must have abstract parents.") } From 2a6f1ba8dbec5024c1a7bc004ab03fde0b5426e5 Mon Sep 17 00:00:00 2001 From: Michael Lawrence Date: Wed, 27 May 2026 23:24:06 -0700 Subject: [PATCH 020/132] clean up S4 subclass setOldClass() registration; now supports more complex hierarchies --- R/S4.R | 145 ++++++++++++++++++------------------- R/class.R | 150 +++++++++++++++------------------------ tests/testthat/test-S4.R | 52 ++++++++++---- 3 files changed, 167 insertions(+), 180 deletions(-) diff --git a/R/S4.R b/R/S4.R index 432501e5d..655c3db30 100644 --- a/R/S4.R +++ b/R/S4.R @@ -15,20 +15,17 @@ #' standardGeneric("S4_generic") #' }) #' -#' Foo := new_class() +#' Foo <- new_class("Foo") #' S4_register(Foo) #' method(S4_generic, Foo) <- function(x) "Hello" #' #' S4_generic(Foo()) S4_register <- function(class, env = parent.frame()) { - where <- topenv(env) - - if (is_S3_class(class)) { - methods::setOldClass(class$class, where = where) - return(invisible()) - } - - if (!is_class(class)) { + if (is_class(class)) { + classes <- class_dispatch(class) + } else if (is_S3_class(class)) { + classes <- class$class + } else { msg <- sprintf( "`class` must be an S7 class or an S3 class, not a %s.", obj_desc(class) @@ -36,21 +33,54 @@ S4_register <- function(class, env = parent.frame()) { stop2(msg) } - classes <- class_dispatch(class) - s4_slots <- S4_slots_from_properties(class@properties) - if (length(s4_slots) > 0 || is_S4_class(class@parent)) { - methods::setOldClass( - classes, - S4Class = S4_transient_class(class, env, s4_slots), - where = where - ) - } else { - methods::setOldClass(classes, where = where) - } - methods::setMethod("initialize", classes[1], S4_initialize, where = where) + methods::setOldClass(classes, where = topenv(env)) invisible() } +S7_extends_S4 <- function(class) { + length(S4_subclasses(class)) > 0L +} + +S4_register_subclass <- function(class, env) { + where <- topenv(env) + methods::setOldClass( + S4_subclasses(class), + S4Class = S4_transient_prototype_class(class, where), + where = where + ) + methods::setValidity(class@name, S4_validate, where = where) + methods::setMethod("initialize", class@name, S4_initialize, where = where) +} + +S4_subclasses <- function(class) { + subclasses <- character() + while (is_class(class)) { + subclasses <- c(subclasses, attr(class, "name", exact = TRUE)) + class <- attr(class, "parent", exact = TRUE) + if (is_S4_class(class)) { + return(subclasses) + } + } + character() +} + +S4_validate <- function(object) { + if (!S7_inherits(object)) { + return(sprintf( + "object with S4 class %s is not an S7 object", + dQuote(class(object)[1L]) + )) + } + + tryCatch( + { + validate(object) + TRUE + }, + error = function(cnd) conditionMessage(cnd) + ) +} + S4_initialize <- function(.Object, ...) { args <- list(...) if (length(args) == 0) { @@ -106,44 +136,30 @@ S4_initialize_data_part <- function(value, object) { value } -S4_transient_class <- function( - class, - env = parent.frame(), - slots = S4_slots_from_properties(class@properties) -) { - tmp <- new.env(parent = topenv(env)) - args <- list( - Class = paste0(".S7_transient_", class@name), - slots = slots, - where = tmp - ) - - contains <- S4_transient_contains(class@parent) - if (length(contains) > 0) { - args$contains <- contains - } +S4_transient_prototype_class <- function(class, env = parent.frame()) { + where <- topenv(env) + classes <- class_dispatch(class) - if (!is.null(class@package)) { - args$package <- class@package + parent_class <- attr(class, "parent", exact = TRUE) + parent_name <- if (is_S4_class(parent_class)) { + parent_class@className + } else { + attr(parent_class, "name", exact = TRUE) } - do.call(methods::setClass, args) - methods::getClass(args$Class, where = tmp) -} + args <- list( + Class = classes[1L], + contains = parent_name, + where = where + ) -S4_transient_contains <- function(parent) { - if (is_S4_class(parent)) { - parent@className - } else { - character() + pkg <- attr(class, "package", exact = TRUE) + if (!is.null(pkg)) { + args$package <- pkg } -} -S4_slots_from_properties <- function(properties) { - properties <- Filter(Negate(prop_is_dynamic), properties) - vcapply(properties, function(prop) { - attr(prop, "S4_slot_class", exact = TRUE) %||% S4_slot_class(prop$class) - }) + do.call(methods::setClass, args) + methods::getClass(args$Class, where = where) } is_S4_class <- function(x) inherits(x, "classRepresentation") @@ -193,29 +209,10 @@ S4_slot_properties <- function(class) { } S4_slot_property <- function(class, name) { - prop <- new_property( - class = S4_slot_as_class(class), + new_property( + class = S4_to_S7_class(methods::getClass(class)), name = name ) - attr(prop, "S4_slot_class") <- class - prop -} - -S4_slot_as_class <- function(class) { - S4_to_S7_class(methods::getClass(class)) -} - -S4_slot_class <- function(class) { - switch(class_type(class), - NULL = "NULL", - missing = "ANY", - any = "ANY", - S4 = as.character(class@className), - S7_base = class_register(class), - S7_S3 = class_register(class), - S7 = "ANY", - S7_union = if (identical(class, class_numeric)) "numeric" else "ANY" - ) } S4_basic_classes <- function() { diff --git a/R/class.R b/R/class.R index 07aa20b2e..b47615876 100644 --- a/R/class.R +++ b/R/class.R @@ -11,9 +11,8 @@ #' CamelCase for S7 class names, but it is not required.) #' #' The result of calling `new_class()` should always be assigned to a variable -#' with this name, i.e. `Foo <- new_class("Foo", ...)` or -#' `Foo := new_class(...)`. This object both represents the class and is used -#' to construct new instances of the class. +#' with this name, i.e. `Foo <- new_class("Foo")`. This object both represents +#' the class and is used to construct new instances of the class. #' @param parent The parent class to inherit behavior from. #' There are three options: #' @@ -63,7 +62,7 @@ #' @export #' @examples #' # Create an class that represents a range using a numeric start and end -#' Range := new_class( +#' Range <- new_class("Range", #' properties = list( #' start = class_numeric, #' end = class_numeric @@ -81,7 +80,7 @@ #' #' # But we might also want to use a validator to ensure that start and end #' # are length 1, and that start is < end -#' Range := new_class( +#' Range <- new_class("Range", #' properties = list( #' start = class_numeric, #' end = class_numeric @@ -140,15 +139,13 @@ new_class <- function( check_prop_names(new_props) # Combine properties from parent, overriding as needed - parent_props <- class_properties(parent) - check_prop_overrides(new_props, parent_props, name, parent) - all_props <- modify_list(parent_props, new_props) - constructor_props <- if (is_S4_class(parent)) all_props else new_props + all_props <- class_properties(parent) + all_props[names(new_props)] <- new_props if (is.null(constructor)) { constructor <- new_constructor( parent, - constructor_props, + all_props, envir = parent.frame(), package = package ) @@ -165,11 +162,11 @@ new_class <- function( attr(object, "validator") <- validator class(object) <- c("S7_class", "S7_object") - if (is_S4_class(parent)) { - S4_register(object, env = parent.frame()) + if (S7_extends_S4(object)) { + S4_register_subclass(object, env = parent.frame()) } - global_variables(names(new_props)) + global_variables(names(all_props)) object } globalVariables(c( @@ -282,29 +279,17 @@ check_can_inherit <- function( is_class <- function(x) inherits(x, "S7_class") -# A class you can't supply an instance of: an abstract S7 class, or an S3 class -# registered without a constructor (e.g. a marker class like "gg" or "POSIXt"). -class_is_abstract <- function(class) { - if (is_class(class)) { - class@abstract - } else if (is_S3_class(class)) { - class$abstract %||% is_S3_stub_constructor(class$constructor) - } else { - FALSE - } -} - check_parent <- function(parent, class, call = sys.call(-1L)) { parent_class <- class@parent if (is.null(parent_class)) { stop2( - "`_parent` must not be supplied when class has no parent.", + "`.parent` must not be supplied when class has no parent.", call = call ) } # Ignore abstract classes since you can't supply an instance - if (class_is_abstract(parent_class)) { + if (is_class(parent_class) && parent_class@abstract) { return() } @@ -319,7 +304,7 @@ check_parent <- function(parent, class, call = sys.call(-1L)) { return() } msg <- sprintf( - "`_parent` must be an instance of %s, not %s.", + "`.parent` must be an instance of %s, not %s.", class_desc(parent_class), obj_desc(parent) ) @@ -328,15 +313,11 @@ check_parent <- function(parent, class, call = sys.call(-1L)) { # Object ------------------------------------------------------------------ -#' @param _parent,... Parent object and named properties used to construct the +#' @param .parent,... Parent object and named properties used to construct the #' object. -#' -#' As a convenience, if `...` is a single unnamed list, then the elements of -#' that list are used as the properties. This makes it easy to -#' programmatically construct an object from a list of property values. #' @rdname new_class #' @export -new_object <- function(`_parent`, ...) { +new_object <- function(.parent, ...) { class <- sys.function(-1) if (!inherits(class, "S7_class")) { stop2("`new_object()` must be called from within a constructor.") @@ -349,17 +330,18 @@ new_object <- function(`_parent`, ...) { stop2(msg) } - if (!missing(`_parent`)) { - check_parent(`_parent`, class) + if (!missing(.parent)) { + check_parent(.parent, class) } - args <- collect_dots(...) + args <- list(...) + if ("" %in% names2(args)) { + stop2("All arguments to `...` must be named.") + } has_setter <- vlapply(class@properties[names(args)], prop_has_setter) - self_attrs <- args[!has_setter] - names(self_attrs) <- prop_storage_rename(names(self_attrs)) - # We must awkwardly operate on `_parent` rather than binding to a local + # We must awkwardly operate on `.parent` rather than binding to a local # variable; since otherwise the extra binding causes ALTREP-wrapped values to # be materialised when byte-compiled (#607). attrs <- c( @@ -368,28 +350,26 @@ new_object <- function(`_parent`, ...) { attributes(`_parent`) ) attrs <- attrs[!duplicated(names(attrs))] - attributes(`_parent`) <- attrs + attributes(.parent) <- attrs # invoke custom property setters prop_setter_vals <- args[has_setter] for (name in names(prop_setter_vals)) { - prop(`_parent`, name, check = FALSE) <- prop_setter_vals[[name]] + prop(.parent, name, check = FALSE) <- prop_setter_vals[[name]] } - # Don't need to validate the parent class if it's already validated and none - # of its properties were reset by this call. + # Don't need to validate if parent class already validated, + # i.e. it's a non-abstract S7 class parent_validated <- inherits(class@parent, "S7_object") && !class@parent@abstract - parent_props_reset <- parent_validated && - any(names2(args) %in% names2(class@parent@properties)) validate_from( - `_parent`, - parent = if (parent_validated && !parent_props_reset) class@parent, + .parent, + parent = if (parent_validated) class@parent, # Attribute validation failures to the constructor call, not new_object() call = sys.call(-1L) ) - `_parent` + .parent } #' @export @@ -434,7 +414,7 @@ str.S7_object <- function(object, ..., nest.lev = 0) { #' @returns A class specification. #' @export #' @examples -#' Foo := new_class() +#' Foo <- new_class("Foo") #' S7_class(Foo()) #' #' # Also works on non-S7 objects @@ -455,50 +435,34 @@ S7_class <- function(object) { check_prop_names <- function(properties, call = sys.call(-1L)) { - nms <- names2(properties) - - # `...` can't be a property name because it's special syntax - if ("..." %in% nms) { - stop2("Properties can't be named \"...\".", call = call) + # these attributes have special C handlers in base R + forbidden <- c( + "names", + "dim", + "dimnames", + "class", + "tsp", + "comment", + "row.names", + "..." + ) + forbidden <- intersect(forbidden, names(properties)) + if (length(forbidden)) { + msg <- paste0( + "Property can't be named: ", + paste0(forbidden, collapse = ", "), + "." + ) + stop2(msg, call = call) } -} -check_prop_overrides <- function( - child_props, - parent_props, - name, - parent, - call = sys.call(-1L) -) { - overridden <- intersect(names(child_props), names(parent_props)) - - for (prop in overridden) { - child_prop <- child_props[[prop]] - - # Dynamic properties are computed, not stored, so they're never validated - # against the parent's type - if (prop_is_dynamic(child_prop)) { - next - } - - child_class <- child_prop$class - parent_class <- parent_props[[prop]]$class - - if (!class_extends(child_class, parent_class)) { - child_desc <- paste0("<", name, ">") - parent_desc <- class_desc(parent) - msg <- c( - sprintf( - "%s@%s must narrow %s@%s.", - child_desc, - prop, - parent_desc, - prop - ), - sprintf("- %s@%s is %s.", parent_desc, prop, class_desc(parent_class)), - sprintf("- %s@%s is %s.", child_desc, prop, class_desc(child_class)) - ) - stop2(msg, call = call) - } + reserved <- intersect("S7_class", names(properties)) + if (length(reserved)) { + msg <- paste0( + "Property can't use S7 reserved name: ", + paste0(reserved, collapse = ", "), + "." + ) + stop2(msg, call = call) } } diff --git a/tests/testthat/test-S4.R b/tests/testthat/test-S4.R index 164eb1bd5..b936a1f79 100644 --- a/tests/testthat/test-S4.R +++ b/tests/testthat/test-S4.R @@ -137,19 +137,6 @@ test_that("S4 initialize supports S3 data parts", { expect_true(methods::validObject(child)) }) -test_that("S4_register uses S7 properties as known S4 attributes", { - on.exit(S4_remove_classes("Foo")) - Foo <- new_class("Foo", properties = list(x = class_numeric), package = NULL) - foo <- Foo(x = 1) - - S4_register(Foo) - expect_true(methods::validObject(foo)) - expect_equal(methods::slot(foo, "x"), 1) - - attr(foo, "x") <- "x" - expect_error(methods::validObject(foo), "invalid object") -}) - test_that("S4 initialize uses S7 property setters", { on.exit(S4_remove_classes(c("Parent2", "Child2"))) setClass("Parent2", slots = list(x = "numeric")) @@ -265,6 +252,45 @@ test_that("S4_class_dispatch captures implicit package name", { expect_equal(S4_class_dispatch("Foo1"), "S4/mypkg::Foo1") }) +test_that("S7 class extending S4 class with multiple parents works", { + on.exit(S4_remove_classes(c( + "MultiParent1", + "MultiParent2", + "MultiChild", + "S7MultiChild", + "S7MultiChild2" + ))) + + setClass("MultiParent1", slots = list(x = "numeric")) + setClass("MultiParent2", slots = list(y = "numeric")) + setClass("MultiChild", contains = c("MultiParent1", "MultiParent2")) + + S7MultiChild <- new_class( + "S7MultiChild", + parent = getClass("MultiChild"), + properties = list(z = class_numeric), + package = NULL + ) + + S7MultiChild2 <- new_class( + "S7MultiChild2", + parent = S7MultiChild, + properties = list(w = class_numeric), + package = NULL + ) + + obj <- S7MultiChild2(x = 1, y = 2, z = 3, w = 4) + expect_true(S7_inherits(obj, S7MultiChild2)) + expect_true(S7_inherits(obj, S7MultiChild)) + expect_equal(prop(obj, "x"), 1) + expect_equal(prop(obj, "y"), 2) + expect_equal(prop(obj, "z"), 3) + expect_equal(prop(obj, "w"), 4) + + expect_true(methods::is(obj, "MultiParent1")) + expect_true(methods::is(obj, "MultiParent2")) +}) + test_that("S4_package_name resolves S4 package name correctly in all cases", { stats_ns <- asNamespace("stats") From 608d1d175fb303fcc9ca041e8c9f36e3d3c13539 Mon Sep 17 00:00:00 2001 From: Michael Lawrence Date: Thu, 28 May 2026 02:23:31 -0700 Subject: [PATCH 021/132] more tweaks to subclass registration --- R/S4.R | 21 +++++++++++---------- 1 file changed, 11 insertions(+), 10 deletions(-) diff --git a/R/S4.R b/R/S4.R index 655c3db30..eb335bdf8 100644 --- a/R/S4.R +++ b/R/S4.R @@ -43,19 +43,24 @@ S7_extends_S4 <- function(class) { S4_register_subclass <- function(class, env) { where <- topenv(env) + subclasses <- S4_subclasses(class) + if (length(subclasses) > 1L) { + methods::setOldClass(subclasses, where = where) + return() + } methods::setOldClass( - S4_subclasses(class), + subclasses, S4Class = S4_transient_prototype_class(class, where), where = where ) - methods::setValidity(class@name, S4_validate, where = where) - methods::setMethod("initialize", class@name, S4_initialize, where = where) + methods::setValidity(subclasses[1L], S4_validate, where = where) + methods::setMethod("initialize", subclasses[1L], S4_initialize, where = where) } S4_subclasses <- function(class) { subclasses <- character() while (is_class(class)) { - subclasses <- c(subclasses, attr(class, "name", exact = TRUE)) + subclasses <- c(subclasses, S7_class_name(class)) class <- attr(class, "parent", exact = TRUE) if (is_S4_class(class)) { return(subclasses) @@ -141,15 +146,11 @@ S4_transient_prototype_class <- function(class, env = parent.frame()) { classes <- class_dispatch(class) parent_class <- attr(class, "parent", exact = TRUE) - parent_name <- if (is_S4_class(parent_class)) { - parent_class@className - } else { - attr(parent_class, "name", exact = TRUE) - } + stopifnot(is_S4_class(parent_class)) args <- list( Class = classes[1L], - contains = parent_name, + contains = parent_class@className, where = where ) From ecafb3d241c27341362914aa34bc868f0c4be6c9 Mon Sep 17 00:00:00 2001 From: Michael Lawrence Date: Thu, 28 May 2026 02:24:06 -0700 Subject: [PATCH 022/132] make S7_class_name robust to invocation at package build time --- R/class.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/R/class.R b/R/class.R index b47615876..fd5d6bbb7 100644 --- a/R/class.R +++ b/R/class.R @@ -181,7 +181,7 @@ globalVariables(c( #' @rawNamespace if (getRversion() >= "4.3.0") S3method(nameOfClass, S7_class, S7_class_name) S7_class_name <- function(x) { - paste(c(x@package, x@name), collapse = "::") + paste(c(attr(x, "package", exact = TRUE), attr(x, "name", exact = TRUE)), collapse = "::") } check_S7_constructor <- function(constructor, call = sys.call(-1L)) { From 92012ba05b497eacf7c2663197bed8aaabdd1bc3 Mon Sep 17 00:00:00 2001 From: Michael Lawrence Date: Thu, 28 May 2026 17:24:45 -0700 Subject: [PATCH 023/132] reformat --- R/class.R | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/R/class.R b/R/class.R index fd5d6bbb7..b9714e138 100644 --- a/R/class.R +++ b/R/class.R @@ -181,7 +181,10 @@ globalVariables(c( #' @rawNamespace if (getRversion() >= "4.3.0") S3method(nameOfClass, S7_class, S7_class_name) S7_class_name <- function(x) { - paste(c(attr(x, "package", exact = TRUE), attr(x, "name", exact = TRUE)), collapse = "::") + paste( + c(attr(x, "package", exact = TRUE), attr(x, "name", exact = TRUE)), + collapse = "::" + ) } check_S7_constructor <- function(constructor, call = sys.call(-1L)) { From 953f4cd4a4471fa08c04502764493ebfcec3f34d Mon Sep 17 00:00:00 2001 From: Michael Lawrence Date: Fri, 29 May 2026 00:01:38 -0700 Subject: [PATCH 024/132] convert() falls back to methods::as() --- R/convert.R | 2 ++ 1 file changed, 2 insertions(+) diff --git a/R/convert.R b/R/convert.R index 97d813247..dbac5d146 100644 --- a/R/convert.R +++ b/R/convert.R @@ -128,6 +128,8 @@ convert <- function(from, to, ...) { convert_down(from, to, dots) } else if (is_base_class(to)) { base_coerce(from, to, ...) + } else if (methods::canCoerce(from, class_register(to))) { + methods::as(from, class_register(to), ...) } else { msg <- paste_c( "Can't find method with dispatch classes:\n", From 077363befface8634b72f3c53f2a1b7ad554fb77 Mon Sep 17 00:00:00 2001 From: Michael Lawrence Date: Fri, 29 May 2026 00:25:46 -0700 Subject: [PATCH 025/132] correct S4 class name for 'to' --- R/convert.R | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/R/convert.R b/R/convert.R index dbac5d146..103dcaf20 100644 --- a/R/convert.R +++ b/R/convert.R @@ -128,9 +128,11 @@ convert <- function(from, to, ...) { convert_down(from, to, dots) } else if (is_base_class(to)) { base_coerce(from, to, ...) - } else if (methods::canCoerce(from, class_register(to))) { - methods::as(from, class_register(to), ...) } else { + s4_to_name <- if (is_S4_class(to)) to@className else class_register(to) + if (methods::canCoerce(from, s4_to_name)) { + return(methods::as(from, s4_to_name, ...)) + } msg <- paste_c( "Can't find method with dispatch classes:\n", c("- from: ", obj_desc(from), "\n"), From 2d5384a5f2b0473951e7fe5fd6fb8461fdc2c0df Mon Sep 17 00:00:00 2001 From: Michael Lawrence Date: Fri, 29 May 2026 00:38:24 -0700 Subject: [PATCH 026/132] add test --- tests/testthat/test-convert.R | 19 +++++++++++++++++++ 1 file changed, 19 insertions(+) diff --git a/tests/testthat/test-convert.R b/tests/testthat/test-convert.R index f6b476b3b..816f31f3d 100644 --- a/tests/testthat/test-convert.R +++ b/tests/testthat/test-convert.R @@ -136,6 +136,25 @@ test_that("fallback convert can convert to base type", { expect_equal(attr(obj, "x"), NULL) }) +test_that("fallback convert can convert to S4 class using methods::as", { + on.exit(S4_remove_classes(c("ParentS4", "ChildS7"))) + setClass("ParentS4", slots = list(x = "numeric")) + + ChildS7 <- new_class( + "ChildS7", + parent = getClass("ParentS4"), + properties = list(y = class_character), + package = NULL + ) + + child <- ChildS7(x = 10, y = "a") + parent <- convert(child, to = getClass("ParentS4")) + + expect_true(isS4(parent)) + expect_equal(class(parent)[1L], "ParentS4") + expect_equal(methods::slot(parent, "x"), 10) +}) + test_that("is_down_cast() is TRUE only when `to` descends from `from` (#509)", { Base := new_class(package = NULL) A := new_class( From 371969811edd9c66002347a3666c0f4ac1ba34ce Mon Sep 17 00:00:00 2001 From: Michael Lawrence Date: Fri, 29 May 2026 01:40:51 -0700 Subject: [PATCH 027/132] convert_up() can convert an S4-derived S7 object to an S4 object --- R/convert.R | 5 +++++ tests/testthat/test-convert.R | 2 +- 2 files changed, 6 insertions(+), 1 deletion(-) diff --git a/R/convert.R b/R/convert.R index 103dcaf20..5c562b060 100644 --- a/R/convert.R +++ b/R/convert.R @@ -192,6 +192,11 @@ convert_up <- function(from, to, call = sys.call(-1L)) { from <- zap_attr(from, c(setdiff(from_props, to_props), "S7_class")) attr(from, "_S7_class") <- to class(from) <- class_dispatch(to) + } else if (is_S4_class(to)) { + to_slots <- methods::slotNames(to) + from <- zap_attr(from, c(setdiff(from_props, to_slots), "S7_class")) + class(from) <- structure(to@className, package = to@package) + from <- asS4(from) } else { stop2("Unreachable.") } diff --git a/tests/testthat/test-convert.R b/tests/testthat/test-convert.R index 816f31f3d..86983e463 100644 --- a/tests/testthat/test-convert.R +++ b/tests/testthat/test-convert.R @@ -136,7 +136,7 @@ test_that("fallback convert can convert to base type", { expect_equal(attr(obj, "x"), NULL) }) -test_that("fallback convert can convert to S4 class using methods::as", { +test_that("fallback convert can convert_up() an S4-derived S7 object to an S4 object", { on.exit(S4_remove_classes(c("ParentS4", "ChildS7"))) setClass("ParentS4", slots = list(x = "numeric")) From 79b98e0d533129d832d7f64db92f87bded2a29ba Mon Sep 17 00:00:00 2001 From: Michael Lawrence Date: Fri, 29 May 2026 01:43:27 -0700 Subject: [PATCH 028/132] clean up and test restricted methods::as() fallback to convert() --- R/S4.R | 8 ++++++++ R/convert.R | 22 ++++++++++++++++++---- tests/testthat/test-convert.R | 24 ++++++++++++++++++++++++ 3 files changed, 50 insertions(+), 4 deletions(-) diff --git a/R/S4.R b/R/S4.R index eb335bdf8..036232f39 100644 --- a/R/S4.R +++ b/R/S4.R @@ -41,6 +41,14 @@ S7_extends_S4 <- function(class) { length(S4_subclasses(class)) > 0L } +inherits_S4 <- function(x) { + isS4(x) || + { + klass <- S7_class(x) + !is.null(klass) && S7_extends_S4(klass) + } +} + S4_register_subclass <- function(class, env) { where <- topenv(env) subclasses <- S4_subclasses(class) diff --git a/R/convert.R b/R/convert.R index 5c562b060..d40237441 100644 --- a/R/convert.R +++ b/R/convert.R @@ -128,11 +128,9 @@ convert <- function(from, to, ...) { convert_down(from, to, dots) } else if (is_base_class(to)) { base_coerce(from, to, ...) + } else if (is_S4_coerce(from, to)) { + convert_S4(from, to, ...) } else { - s4_to_name <- if (is_S4_class(to)) to@className else class_register(to) - if (methods::canCoerce(from, s4_to_name)) { - return(methods::as(from, s4_to_name, ...)) - } msg <- paste_c( "Can't find method with dispatch classes:\n", c("- from: ", obj_desc(from), "\n"), @@ -238,6 +236,22 @@ convert_down <- function(from, to, user_args = list()) { do.call(to, constructor_args) } +s4_to_name <- function(x) { + if (is_S4_class(x)) x@className else class_register(x) +} + +is_S4_coerce <- function(from, to) { + # can loosen this restriction once convert() has default base targets + if (!inherits_S4(from) && !is_S4_class(to)) { + return(FALSE) + } + methods::canCoerce(from, s4_to_name(to)) +} + +convert_S4 <- function(from, to, ...) { + methods::as(from, s4_to_name(to), ...) +} + # Converted to S7_generic onLoad in order to avoid dependency between files on_load_make_convert_generic <- function() { convert <<- S7_generic( diff --git a/tests/testthat/test-convert.R b/tests/testthat/test-convert.R index 86983e463..37298acdc 100644 --- a/tests/testthat/test-convert.R +++ b/tests/testthat/test-convert.R @@ -155,6 +155,30 @@ test_that("fallback convert can convert_up() an S4-derived S7 object to an S4 ob expect_equal(methods::slot(parent, "x"), 10) }) +test_that("fallback convert can use explicit S4 coercion via methods::as", { + on.exit(S4_remove_classes(c("ParentS4", "ChildS7", "UnrelatedS4"))) + setClass("ParentS4", slots = list(x = "numeric")) + setClass("UnrelatedS4", slots = list(z = "character")) + + ChildS7 <- new_class( + "ChildS7", + parent = getClass("ParentS4"), + properties = list(y = class_character), + package = NULL + ) + + setAs("ChildS7", "UnrelatedS4", function(from) { + new("UnrelatedS4", z = as.character(methods::slot(from, "x"))) + }) + + child <- ChildS7(x = 42, y = "a") + res <- convert(child, to = getClass("UnrelatedS4")) + + expect_true(isS4(res)) + expect_equal(class(res)[1L], "UnrelatedS4") + expect_equal(methods::slot(res, "z"), "42") +}) + test_that("is_down_cast() is TRUE only when `to` descends from `from` (#509)", { Base := new_class(package = NULL) A := new_class( From e12548ee2976d70c5a7e9ef876cae8fe34652135 Mon Sep 17 00:00:00 2001 From: Michael Lawrence Date: Sun, 31 May 2026 02:57:18 -0700 Subject: [PATCH 029/132] S4_register() returns the name of the class it registered, which can be convenient for passing to methods package functions --- R/S4.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/R/S4.R b/R/S4.R index 036232f39..7eb8f6abc 100644 --- a/R/S4.R +++ b/R/S4.R @@ -34,7 +34,7 @@ S4_register <- function(class, env = parent.frame()) { } methods::setOldClass(classes, where = topenv(env)) - invisible() + invisible(classes[1L]) } S7_extends_S4 <- function(class) { From e73e8650feda6353237abceda1fd94e2377645fb Mon Sep 17 00:00:00 2001 From: Michael Lawrence Date: Sun, 31 May 2026 03:05:51 -0700 Subject: [PATCH 030/132] rename S4_transient_prototype_class to S4_register_prototype_class and have it return the class name. --- R/S4.R | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/R/S4.R b/R/S4.R index 7eb8f6abc..3e7001719 100644 --- a/R/S4.R +++ b/R/S4.R @@ -58,7 +58,7 @@ S4_register_subclass <- function(class, env) { } methods::setOldClass( subclasses, - S4Class = S4_transient_prototype_class(class, where), + S4Class = S4_register_prototype_class(class, where), where = where ) methods::setValidity(subclasses[1L], S4_validate, where = where) @@ -149,7 +149,7 @@ S4_initialize_data_part <- function(value, object) { value } -S4_transient_prototype_class <- function(class, env = parent.frame()) { +S4_register_prototype_class <- function(class, env = parent.frame()) { where <- topenv(env) classes <- class_dispatch(class) @@ -168,7 +168,7 @@ S4_transient_prototype_class <- function(class, env = parent.frame()) { } do.call(methods::setClass, args) - methods::getClass(args$Class, where = where) + args$Class } is_S4_class <- function(x) inherits(x, "classRepresentation") From a661d5b08240486069dceba12adb386c98d4bd92 Mon Sep 17 00:00:00 2001 From: Michael Lawrence Date: Sun, 31 May 2026 03:19:33 -0700 Subject: [PATCH 031/132] support class unions in S4_register() --- R/S4.R | 14 +++++++++++++- 1 file changed, 13 insertions(+), 1 deletion(-) diff --git a/R/S4.R b/R/S4.R index 3e7001719..7b8a260b4 100644 --- a/R/S4.R +++ b/R/S4.R @@ -25,9 +25,11 @@ S4_register <- function(class, env = parent.frame()) { classes <- class_dispatch(class) } else if (is_S3_class(class)) { classes <- class$class + } else if (is_union(class)) { + return(invisible(S4_register_union(class, topenv(env)))) } else { msg <- sprintf( - "`class` must be an S7 class or an S3 class, not a %s.", + "`class` must be an S7 class, S3 class, or S7 union, not a %s.", obj_desc(class) ) stop2(msg) @@ -37,6 +39,16 @@ S4_register <- function(class, env = parent.frame()) { invisible(classes[1L]) } +S4_register_union <- function(class, env) { + name <- S4_union_name(class, env) + methods::setClassUnion( + name, + vcapply(class$classes, S4_class, S4_env = env), + where = env + ) + name +} + S7_extends_S4 <- function(class) { length(S4_subclasses(class)) > 0L } From f8d8ad837ded644c4810ad99159c8f6170311380 Mon Sep 17 00:00:00 2001 From: Michael Lawrence Date: Sun, 31 May 2026 03:20:58 -0700 Subject: [PATCH 032/132] make S4_class() return a methods-friendly class name and have it handle unions, particularly class_numeric --- R/S4.R | 77 ++++++++++++++++++++++++++++++++++++- R/method-register-S4.R | 56 --------------------------- R/method-register.R | 12 ++++++ tests/testthat/_snaps/S4.md | 5 +-- 4 files changed, 90 insertions(+), 60 deletions(-) delete mode 100644 R/method-register-S4.R diff --git a/R/S4.R b/R/S4.R index 7b8a260b4..370db8304 100644 --- a/R/S4.R +++ b/R/S4.R @@ -1,4 +1,4 @@ -#' Register an S7 or S3 class with S4 +#' Register an S7, S3, or union class with S4 #' #' If you want to use [method<-] to register a method for an S4 generic with #' an S7 class that does not extend an S4 class, or an S3 class created by @@ -49,6 +49,81 @@ S4_register_union <- function(class, env) { name } +S4_class <- function(x, S4_env, call = sys.call(-1L)) { + switch( + class_type(x), + `NULL` = "NULL", + missing = "missing", + any = "ANY", + S7_base = base_to_S4(x$class), + S4 = as.character(x@className), + S7 = as.character( + S4_registered_class(x, S4_env, call = call)@className + ), + S7_S3 = as.character( + S4_registered_class(x, S4_env, call = call)@className + ), + S7_union = S4_union_class(x, S4_env) + ) +} + +S4_union_class <- function(x, S4_env) { + if (identical(x, class_numeric)) { + return("numeric") + } + + name <- S4_union_name(x, S4_env) + if (methods::isClass(name, where = S4_env)) { + return(name) + } + + msg <- sprintf( + "Class union has not been registered with S4; please call S4_register(%s).", + class_deparse(x) + ) + stop(msg, call. = FALSE) +} + +S4_union_name <- function(x, S4_env) { + paste0(vcapply(x$classes, S4_class, S4_env = S4_env), collapse = "_OR_") +} + +# S4 dispatch uses `class()` to find a method, but `class(1.5)` is "numeric", +# not "double", so registering under "double" silently misses real doubles. +# Mapping to "numeric" catches doubles but also matches integers too. There's +# no clean S4 way to say "doubles only" and this seems likely to be what +# people want. +base_to_S4 <- function(class) { + switch(class, double = "numeric", class) +} + +S4_registered_class <- function( + x, + S4_env, + call = sys.call(-1L) +) { + class <- tryCatch( + methods::getClass(class_register(x), where = S4_env), + error = function(err) NULL + ) + if (is.null(class)) { + msg <- sprintf( + "Class has not been registered with S4; please call S4_register(%s).", + class_deparse(x) + ) + stop2(msg, call = call) + } + class +} + +S4_ancestor <- function(class) { + parent_class <- attr(class, "parent", exact = TRUE) + while (is_class(parent_class)) { + parent_class <- attr(parent_class, "parent", exact = TRUE) + } + if (is_S4_class(parent_class)) parent_class +} + S7_extends_S4 <- function(class) { length(S4_subclasses(class)) > 0L } diff --git a/R/method-register-S4.R b/R/method-register-S4.R deleted file mode 100644 index 1e083cb2b..000000000 --- a/R/method-register-S4.R +++ /dev/null @@ -1,56 +0,0 @@ -register_S4_method <- function( - generic, - signature, - method, - env = parent.frame(), - call = sys.call(-1L) -) { - S4_env <- topenv(env) - S4_signature <- lapply(signature, S4_class, S4_env = S4_env, call = call) - methods::setMethod(generic, S4_signature, method, where = S4_env) -} - -S4_class <- function(x, S4_env, call = sys.call(-1L)) { - switch( - class_type(x), - `NULL` = "NULL", - missing = "missing", - any = "ANY", - S7_base = base_to_S4(x$class), - S4 = x, - S7 = S4_registered_class(x, S4_env = S4_env, call = call), - S7_S3 = S4_registered_class(x, S4_env = S4_env, call = call), - S7_union = stop2( - "Internal error: union should be flattened upstream.", - call = NULL - ) - ) -} - -# S4 dispatch uses `class()` to find a method, but `class(1.5)` is "numeric", -# not "double", so registering under "double" silently misses real doubles. -# Mapping to "numeric" catches doubles but also matches integers too. There's -# no clean S4 way to say "doubles only" and this seems likely to be what -# people want. -base_to_S4 <- function(class) { - switch(class, double = "numeric", class) -} - -S4_registered_class <- function( - x, - S4_env, - call = sys.call(-1L) -) { - class <- tryCatch( - methods::getClass(class_register(x), where = S4_env), - error = function(err) NULL - ) - if (is.null(class)) { - msg <- sprintf( - "Class has not been registered with S4; please call S4_register(%s).", - class_deparse(x) - ) - stop2(msg, call = call) - } - class -} diff --git a/R/method-register.R b/R/method-register.R index 2afd6ea36..6c5ef9585 100644 --- a/R/method-register.R +++ b/R/method-register.R @@ -370,6 +370,18 @@ check_method <- function( invisible(TRUE) } +register_S4_method <- function( + generic, + signature, + method, + env = parent.frame(), + call = sys.call(-1L) +) { + S4_env <- topenv(env) + S4_signature <- lapply(signature, S4_class, S4_env = S4_env, call = call) + methods::setMethod(generic, S4_signature, method, where = S4_env) +} + #' @export print.S7_method <- function(x, ...) { signature <- method_signature(x@generic, x@signature) diff --git a/tests/testthat/_snaps/S4.md b/tests/testthat/_snaps/S4.md index e082b3386..4a4efe43f 100644 --- a/tests/testthat/_snaps/S4.md +++ b/tests/testthat/_snaps/S4.md @@ -4,12 +4,12 @@ S4_register(1) Condition Error in `S4_register()`: - ! `class` must be an S7 class or an S3 class, not a . + ! `class` must be an S7 class, S3 class, or S7 union, not a . Code S4_register("foo") Condition Error in `S4_register()`: - ! `class` must be an S7 class or an S3 class, not a . + ! `class` must be an S7 class, S3 class, or S7 union, not a . # errors on non-S4 classes @@ -26,4 +26,3 @@ Condition Error: ! Failed to find originating package for S4 generic 'nonexistent_generic' in imports. - From 0e467eeeb15d1d68d3fcbcd7ca7745bf1bb21805 Mon Sep 17 00:00:00 2001 From: Michael Lawrence Date: Sun, 31 May 2026 03:28:14 -0700 Subject: [PATCH 033/132] support S4 classes extending S7 classes --- NAMESPACE | 1 + R/S4.R | 64 +++++++++++++++- man/S4_register.Rd | 25 ++++-- tests/testthat/test-S4.R | 160 ++++++++++++++++++++++++++++++++++++++- 4 files changed, 238 insertions(+), 12 deletions(-) diff --git a/NAMESPACE b/NAMESPACE index 16148e7b8..975fa097e 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -42,6 +42,7 @@ export("method<-") export("prop<-") export("props<-") export(S4_register) +export(S4_register_contains) export(S7_class) export(S7_class_desc) export(S7_classes) diff --git a/R/S4.R b/R/S4.R index 370db8304..b7c1ea6fd 100644 --- a/R/S4.R +++ b/R/S4.R @@ -4,11 +4,17 @@ #' an S7 class that does not extend an S4 class, or an S3 class created by #' [new_S3_class()], you need to call `S4_register()` once. Classes created by #' [new_class()] with an S4 parent are registered automatically. +#' Use `S4_register_contains()` when you want an S4 class to extend an S7 class +#' with `contains=`. This registers the S7 class as an old class with known +#' attributes so that S7 properties are represented as S4 slots. #' -#' @param class An S7 class created with [new_class()], or an S3 class created -#' with [new_S3_class()]. +#' @param class An S7 class created with [new_class()], or, for +#' `S4_register()` only, an S3 class created with [new_S3_class()] or an S7 +#' union created with [new_union()]. #' @param env Expert use only. Environment where S4 class will be registered. -#' @returns Nothing; the function is called for its side-effect. +#' @returns +#' Both functions are called for their side effects and invisibly return the +#' registered S4 class name. #' @export #' @examples #' methods::setGeneric("S4_generic", function(x) { @@ -20,6 +26,10 @@ #' method(S4_generic, Foo) <- function(x) "Hello" #' #' S4_generic(Foo()) +#' +#' S4Foo <- new_class("S4Foo", properties = list(x = class_numeric), package = "S7") +#' S4Foo_S4 <- S4_register_contains(S4Foo) +#' methods::setClass("S4Child", contains = S4Foo_S4) S4_register <- function(class, env = parent.frame()) { if (is_class(class)) { classes <- class_dispatch(class) @@ -152,6 +162,54 @@ S4_register_subclass <- function(class, env) { methods::setMethod("initialize", subclasses[1L], S4_initialize, where = where) } +#' @rdname S4_register +#' @export +S4_register_contains <- function(class, env = parent.frame()) { + if (!is_class(class)) { + msg <- sprintf("`class` must be an S7 class, not a %s.", obj_desc(class)) + stop(msg, call. = FALSE) + } + + where <- topenv(env) + classes <- class_dispatch(class) + if (!methods::isClass(classes[1L], where = where)) { + S4_register(class, where) + } + class_name <- S4_register_with_props(class, where) + invisible(class_name) +} + +S4_register_with_props <- function(class, env) { + where <- topenv(env) + class_name <- S4_register_contains_name(class) + + args <- list( + Class = class_name, + slots = lapply(class@properties, S4_property_class, S4_env = where), + contains = S4_class(class, where), + where = where + ) + + do.call(methods::setClass, args) + class_name +} + +S4_register_contains_name <- function(class) { + paste0(S7_class_name(class), "::S4Slots") +} + +S4_property_class <- function(prop, S4_env) { + if (prop_is_dynamic(prop) || prop_has_setter(prop)) { + msg <- sprintf( + "Can't register property %s as an S4 slot because it has a custom %s.", + prop$name, + if (prop_is_dynamic(prop)) "getter" else "setter" + ) + stop(msg, call. = FALSE) + } + S4_class(prop$class, S4_env) +} + S4_subclasses <- function(class) { subclasses <- character() while (is_class(class)) { diff --git a/man/S4_register.Rd b/man/S4_register.Rd index 6c4a2d28b..7c12582b6 100644 --- a/man/S4_register.Rd +++ b/man/S4_register.Rd @@ -2,25 +2,32 @@ % Please edit documentation in R/S4.R \name{S4_register} \alias{S4_register} -\title{Register an S7 or S3 class with S4} +\alias{S4_register_contains} +\title{Register an S7, S3, or union class with S4} \usage{ S4_register(class, env = parent.frame()) + +S4_register_contains(class, env = parent.frame()) } \arguments{ -\item{class}{An S7 class created with \code{\link[=new_class]{new_class()}}, or an S3 class created -with \code{\link[=new_S3_class]{new_S3_class()}}.} +\item{class}{An S7 class created with \code{\link[=new_class]{new_class()}}, or, for +\code{S4_register()} only, an S3 class created with \code{\link[=new_S3_class]{new_S3_class()}} or an S7 +union created with \code{\link[=new_union]{new_union()}}.} \item{env}{Expert use only. Environment where S4 class will be registered.} } \value{ -Nothing; the function is called for its side-effect. +Both functions are called for their side effects and invisibly return the +registered S4 class name. } \description{ If you want to use \link{method<-} to register a method for an S4 generic with an S7 class that does not extend an S4 class, or an S3 class created by -\code{\link[=new_S3_class]{new_S3_class()}}, you need to call -\code{S4_register()} once. Classes created by \code{\link[=new_class]{new_class()}} with an S4 parent -are registered automatically. +\code{\link[=new_S3_class]{new_S3_class()}}, you need to call \code{S4_register()} once. Classes created by +\code{\link[=new_class]{new_class()}} with an S4 parent are registered automatically. +Use \code{S4_register_contains()} when you want an S4 class to extend an S7 class +with \verb{contains=}. This registers the S7 class as an old class with known +attributes so that S7 properties are represented as S4 slots. } \examples{ methods::setGeneric("S4_generic", function(x) { @@ -32,4 +39,8 @@ S4_register(Foo) method(S4_generic, Foo) <- function(x) "Hello" S4_generic(Foo()) + +S4Foo <- new_class("S4Foo", properties = list(x = class_numeric), package = "S7") +S4Foo_S4 <- S4_register_contains(S4Foo) +methods::setClass("S4Child", contains = S4Foo_S4) } diff --git a/tests/testthat/test-S4.R b/tests/testthat/test-S4.R index b936a1f79..d95482737 100644 --- a/tests/testthat/test-S4.R +++ b/tests/testthat/test-S4.R @@ -6,13 +6,15 @@ test_that("can work with classGenerators", { test_that("S4_register registers an S7 class so it can be used with S4 methods", { on.exit(S4_remove_classes("S4regS7")) S4regS7 := new_class(package = NULL) - S4_register(S4regS7) + S4regS7_S4 <- S4_register(S4regS7) + expect_equal(S4regS7_S4, "S4regS7") expect_contains(methods::extends("S4regS7"), c("S4regS7", "S7_object")) }) test_that("S4_register registers an S3 class so it can be used with S4 methods", { on.exit(S4_remove_classes(c("S4regS3a", "S4regS3b"))) - S4_register(new_S3_class(c("S4regS3a", "S4regS3b"))) + S4regS3_S4 <- S4_register(new_S3_class(c("S4regS3a", "S4regS3b"))) + expect_equal(S4regS3_S4, "S4regS3a") # Must not extend S7_object — that was a silent bug pre-fix expect_equal( methods::extends("S4regS3a"), @@ -20,6 +22,160 @@ test_that("S4_register registers an S3 class so it can be used with S4 methods", ) }) +test_that("S4_register registers an S7 union so it can be used with S4 methods", { + on.exit({ + if (methods::isGeneric("S4regUnionGeneric")) { + methods::removeGeneric("S4regUnionGeneric") + } + S4_remove_classes(c( + "S4regUnionFoo", + "S4regUnionFoo_OR_character" + )) + }) + + S4regUnionFoo <- new_class("S4regUnionFoo", package = NULL) + S4_register(S4regUnionFoo) + S4regUnion <- S4regUnionFoo | class_character + S4regUnion_S4 <- S4_register(S4regUnion) + expect_equal(S4regUnion_S4, "S4regUnionFoo_OR_character") + + methods::setGeneric( + "S4regUnionGeneric", + function(x) standardGeneric("S4regUnionGeneric") + ) + method(S4regUnionGeneric, S4regUnion) <- function(x) "union" + + expect_equal(S4regUnionGeneric(S4regUnionFoo()), "union") + expect_equal(S4regUnionGeneric("x"), "union") +}) + +test_that("S4_register_contains registers S7 properties as slots for S4 subclasses", { + on.exit({ + if (methods::isGeneric("S4regContainsGeneric")) { + methods::removeGeneric("S4regContainsGeneric") + } + S4_remove_classes(c( + "S4regContainsS4Child", + "S7::S4regContains", + "S7::S4regContainsChild", + "S7::S4regContainsChild::S4Slots" + )) + }) + + S4regContains <- new_class( + "S4regContains", + properties = list(x = class_numeric), + package = "S7" + ) + S4regContainsChild <- new_class( + "S4regContainsChild", + parent = S4regContains, + properties = list(y = class_character), + package = "S7" + ) + + S4regContainsChild_old <- S4_register(S4regContainsChild) + S4regContainsChild_S4 <- S4_register_contains(S4regContainsChild) + expect_equal(S4regContainsChild_S4, "S7::S4regContainsChild::S4Slots") + expect_equal( + methods::slotNames(S4regContainsChild_S4), + c("x", "y", ".S3Class") + ) + expect_contains( + methods::extends(S4regContainsChild_S4), + S4regContainsChild_old + ) + + methods::setClass( + "S4regContainsS4Child", + contains = S4regContainsChild_S4, + slots = list(z = "logical") + ) + object <- methods::new( + "S4regContainsS4Child", + x = 1, + y = "a", + z = TRUE + ) + + expect_equal(methods::slot(object, "x"), 1) + expect_equal(methods::slot(object, "y"), "a") + expect_equal(methods::slot(object, "z"), TRUE) + + methods::setGeneric( + "S4regContainsGeneric", + function(x) standardGeneric("S4regContainsGeneric") + ) + method(S4regContainsGeneric, S4regContainsChild) <- function(x) { + methods::slot(x, "x") + } + expect_equal(S4regContainsGeneric(object), 1) +}) + +test_that("S4_register_contains rejects properties that can not be represented as slots", { + on.exit(S4_remove_classes(c( + "S7::S4regContainsDynamic", + "S7::S4regContainsSetter", + "S7::S4regContainsDynamic::S4Slots", + "S7::S4regContainsSetter::S4Slots" + ))) + + S4regContainsDynamic <- new_class( + "S4regContainsDynamic", + properties = list( + x = new_property(class_numeric, getter = function(self) 1) + ), + package = "S7" + ) + expect_error( + S4_register_contains(S4regContainsDynamic), + "custom getter" + ) + + S4regContainsSetter <- new_class( + "S4regContainsSetter", + properties = list( + x = new_property( + class_numeric, + setter = function(self, value) { + attr(self, "x") <- value + self + } + ) + ), + package = "S7" + ) + expect_error( + S4_register_contains(S4regContainsSetter), + "custom setter" + ) +}) + +test_that("S4_register_contains uses registered S7 unions as S4 slots", { + on.exit(S4_remove_classes(c( + "S7::S4regContainsUnion", + "S7::S4regContainsUnion::S4Slots", + "integer_OR_numeric_OR_character" + ))) + + S4regContainsUnion <- new_class( + "S4regContainsUnion", + properties = list(x = class_numeric | class_character), + package = "S7" + ) + expect_error( + S4_register_contains(S4regContainsUnion), + "not been registered" + ) + + S4_register(class_numeric | class_character) + S4regContainsUnion_S4 <- S4_register_contains(S4regContainsUnion) + expect_equal( + as.character(methods::getClass(S4regContainsUnion_S4)@slots$x), + "integer_OR_numeric_OR_character" + ) +}) + test_that("S4_register errors on unsupported inputs", { expect_snapshot(error = TRUE, { S4_register(1) From a19101736830bef4010351c5a0f61d28ab861612 Mon Sep 17 00:00:00 2001 From: Michael Lawrence Date: Mon, 1 Jun 2026 02:42:34 -0700 Subject: [PATCH 034/132] move away from do.call(setClass, ...); package is not needed on the prototype class --- R/S4.R | 13 +++---------- 1 file changed, 3 insertions(+), 10 deletions(-) diff --git a/R/S4.R b/R/S4.R index b7c1ea6fd..427eda5fb 100644 --- a/R/S4.R +++ b/R/S4.R @@ -183,14 +183,13 @@ S4_register_with_props <- function(class, env) { where <- topenv(env) class_name <- S4_register_contains_name(class) - args <- list( + methods::setClass( Class = class_name, slots = lapply(class@properties, S4_property_class, S4_env = where), contains = S4_class(class, where), where = where ) - do.call(methods::setClass, args) class_name } @@ -301,19 +300,13 @@ S4_register_prototype_class <- function(class, env = parent.frame()) { parent_class <- attr(class, "parent", exact = TRUE) stopifnot(is_S4_class(parent_class)) - args <- list( + methods::setClass( Class = classes[1L], contains = parent_class@className, where = where ) - pkg <- attr(class, "package", exact = TRUE) - if (!is.null(pkg)) { - args$package <- pkg - } - - do.call(methods::setClass, args) - args$Class + classes[1L] } is_S4_class <- function(x) inherits(x, "classRepresentation") From 946d8a2a7ae7cc83784e6414bdd5b6d3152309f2 Mon Sep 17 00:00:00 2001 From: Michael Lawrence Date: Mon, 1 Jun 2026 11:23:22 -0700 Subject: [PATCH 035/132] revert unnecessary direct attr() access --- R/S4.R | 4 ++-- R/class.R | 5 +---- 2 files changed, 3 insertions(+), 6 deletions(-) diff --git a/R/S4.R b/R/S4.R index 427eda5fb..48e7370ef 100644 --- a/R/S4.R +++ b/R/S4.R @@ -213,7 +213,7 @@ S4_subclasses <- function(class) { subclasses <- character() while (is_class(class)) { subclasses <- c(subclasses, S7_class_name(class)) - class <- attr(class, "parent", exact = TRUE) + class <- class@parent if (is_S4_class(class)) { return(subclasses) } @@ -297,7 +297,7 @@ S4_register_prototype_class <- function(class, env = parent.frame()) { where <- topenv(env) classes <- class_dispatch(class) - parent_class <- attr(class, "parent", exact = TRUE) + parent_class <- class@parent stopifnot(is_S4_class(parent_class)) methods::setClass( diff --git a/R/class.R b/R/class.R index b9714e138..b47615876 100644 --- a/R/class.R +++ b/R/class.R @@ -181,10 +181,7 @@ globalVariables(c( #' @rawNamespace if (getRversion() >= "4.3.0") S3method(nameOfClass, S7_class, S7_class_name) S7_class_name <- function(x) { - paste( - c(attr(x, "package", exact = TRUE), attr(x, "name", exact = TRUE)), - collapse = "::" - ) + paste(c(x@package, x@name), collapse = "::") } check_S7_constructor <- function(constructor, call = sys.call(-1L)) { From 81e34597796ff32912d7026f07315879f58541df Mon Sep 17 00:00:00 2001 From: Michael Lawrence Date: Mon, 1 Jun 2026 11:23:45 -0700 Subject: [PATCH 036/132] move a couple more S4 helpers from methods-register.R to S4.R --- R/S4.R | 24 ++++++++++++++++++++++++ 1 file changed, 24 insertions(+) diff --git a/R/S4.R b/R/S4.R index 48e7370ef..2cdddced2 100644 --- a/R/S4.R +++ b/R/S4.R @@ -77,6 +77,30 @@ S4_class <- function(x, S4_env, call = sys.call(-1L)) { ) } +# S4 dispatch uses `class()` to find a method, but `class(1.5)` is "numeric", +# not "double", so registering under "double" silently misses real doubles. +# Mapping to "numeric" catches doubles but also matches integers too. There's +# no clean S4 way to say "doubles only" and this seems likely to be what +# people want. +base_to_S4 <- function(class) { + switch(class, double = "numeric", class) +} + +S4_registered_class <- function(x, S4_env, call = sys.call(-1L)) { + class <- tryCatch( + methods::getClass(class_register(x), where = S4_env), + error = function(err) NULL + ) + if (is.null(class)) { + msg <- sprintf( + "Class has not been registered with S4; please call S4_register(%s).", + class_deparse(x) + ) + stop2(msg, call = call) + } + class +} + S4_union_class <- function(x, S4_env) { if (identical(x, class_numeric)) { return("numeric") From df2f809864e1d991ec560703388e8fdaeb995df4 Mon Sep 17 00:00:00 2001 From: Michael Lawrence Date: Mon, 1 Jun 2026 11:47:11 -0700 Subject: [PATCH 037/132] S7 classes inherit S4 class unions from S4 parents directly, which simplifies the S4 -> S7 -> S4 inheritance case. --- R/S4.R | 11 +++++++---- tests/testthat/test-S4.R | 22 ++++++++++++++++++++++ 2 files changed, 29 insertions(+), 4 deletions(-) diff --git a/R/S4.R b/R/S4.R index 2cdddced2..890d89252 100644 --- a/R/S4.R +++ b/R/S4.R @@ -380,10 +380,13 @@ S4_slot_properties <- function(class) { } S4_slot_property <- function(class, name) { - new_property( - class = S4_to_S7_class(methods::getClass(class)), - name = name - ) + class <- methods::getClass(class) + prop <- new_property(class, name = name) + # simplifies case of S4 class extending S7 class that extends an S4 class + if (methods::is(class, "ClassUnionRepresentation")) { + prop$class <- class + } + prop } S4_basic_classes <- function() { diff --git a/tests/testthat/test-S4.R b/tests/testthat/test-S4.R index d95482737..3ab23b56d 100644 --- a/tests/testthat/test-S4.R +++ b/tests/testthat/test-S4.R @@ -206,6 +206,28 @@ test_that("converts S4 unions to S7 unions", { ) }) +test_that("S4 slot properties preserve S4 class unions", { + on.exit(S4_remove_classes(c( + "S4regUnionSlot", + "S4regUnionSlotParent" + ))) + + setClassUnion("S4regUnionSlot", c("character", "NULL")) + setClass("S4regUnionSlotParent", slots = list(u = "S4regUnionSlot")) + + S4regUnionSlotChild <- new_class( + "S4regUnionSlotChild", + parent = getClass("S4regUnionSlotParent"), + properties = list(y = class_character), + package = NULL + ) + + expect_equal( + S4regUnionSlotChild@properties$u$class, + getClass("S4regUnionSlot") + ) +}) + test_that("converts S4 representation of S3 classes to S7 representation", { expect_equal( S4_to_S7_class(getClass("Date")), From 3d8d6d892d3f29a5b99c66d6463e09b581032bfc Mon Sep 17 00:00:00 2001 From: Michael Lawrence Date: Mon, 1 Jun 2026 12:22:53 -0700 Subject: [PATCH 038/132] avoid inherited slot conflicts in the S4->S7->S4 inheritance pattern --- R/S4.R | 14 ++++++++++++-- 1 file changed, 12 insertions(+), 2 deletions(-) diff --git a/R/S4.R b/R/S4.R index 890d89252..f76d1a7f3 100644 --- a/R/S4.R +++ b/R/S4.R @@ -206,17 +206,27 @@ S4_register_contains <- function(class, env = parent.frame()) { S4_register_with_props <- function(class, env) { where <- topenv(env) class_name <- S4_register_contains_name(class) + contains <- S4_class(class, where) + properties <- class@properties + properties <- properties[setdiff( + names(properties), + S4_slot_names(contains, where) + )] methods::setClass( Class = class_name, - slots = lapply(class@properties, S4_property_class, S4_env = where), - contains = S4_class(class, where), + slots = lapply(properties, S4_property_class, S4_env = where), + contains = contains, where = where ) class_name } +S4_slot_names <- function(class, S4_env) { + names(methods::getClass(class, where = S4_env)@slots) +} + S4_register_contains_name <- function(class) { paste0(S7_class_name(class), "::S4Slots") } From 4ecda1e8784edc58b351ee6ca43796a5bc2974d2 Mon Sep 17 00:00:00 2001 From: Michael Lawrence Date: Mon, 1 Jun 2026 12:49:44 -0700 Subject: [PATCH 039/132] instead of forwarding S4 class unions into S7 classes, we enable S4_union_class() to find existing S4 unions. --- R/S4.R | 70 +++++++++++++++++++++---------------- tests/testthat/test-S4.R | 74 ++++++++++++++++++++++++++++++++++------ 2 files changed, 104 insertions(+), 40 deletions(-) diff --git a/R/S4.R b/R/S4.R index f76d1a7f3..e6d3b76ba 100644 --- a/R/S4.R +++ b/R/S4.R @@ -111,6 +111,11 @@ S4_union_class <- function(x, S4_env) { return(name) } + name <- S4_find_union(x, S4_env) + if (!is.null(name)) { + return(name) + } + msg <- sprintf( "Class union has not been registered with S4; please call S4_register(%s).", class_deparse(x) @@ -122,32 +127,40 @@ S4_union_name <- function(x, S4_env) { paste0(vcapply(x$classes, S4_class, S4_env = S4_env), collapse = "_OR_") } -# S4 dispatch uses `class()` to find a method, but `class(1.5)` is "numeric", -# not "double", so registering under "double" silently misses real doubles. -# Mapping to "numeric" catches doubles but also matches integers too. There's -# no clean S4 way to say "doubles only" and this seems likely to be what -# people want. -base_to_S4 <- function(class) { - switch(class, double = "numeric", class) +S4_find_union <- function(x, S4_env) { + members <- vcapply(x$classes, S4_class, S4_env = S4_env) + supers <- lapply(members, S4_direct_superclasses, S4_env = S4_env) + candidates <- base::Reduce(base::intersect, supers) + matches <- base::Filter( + function(candidate) S4_union_matches(candidate, members, S4_env), + candidates + ) + if (length(matches) == 0) { + return(NULL) + } + + matches[1L] } -S4_registered_class <- function( - x, - S4_env, - call = sys.call(-1L) -) { - class <- tryCatch( - methods::getClass(class_register(x), where = S4_env), - error = function(err) NULL - ) - if (is.null(class)) { - msg <- sprintf( - "Class has not been registered with S4; please call S4_register(%s).", - class_deparse(x) - ) - stop2(msg, call = call) +S4_direct_superclasses <- function(class, S4_env) { + class <- methods::getClass(class, where = S4_env) + contains <- class@contains + contains <- base::Filter(function(x) x@distance == 1, contains) + names(contains) +} + +S4_union_matches <- function(class, members, S4_env) { + class <- methods::getClass(class, where = S4_env) + if (!methods::isClassUnion(class)) { + return(FALSE) } - class + + setequal(S4_union_members(class), members) +} + +S4_union_members <- function(class) { + subclasses <- base::Filter(function(x) x@distance == 1, class@subclasses) + vcapply(subclasses, function(x) as.character(x@subClass)) } S4_ancestor <- function(class) { @@ -390,13 +403,10 @@ S4_slot_properties <- function(class) { } S4_slot_property <- function(class, name) { - class <- methods::getClass(class) - prop <- new_property(class, name = name) - # simplifies case of S4 class extending S7 class that extends an S4 class - if (methods::is(class, "ClassUnionRepresentation")) { - prop$class <- class - } - prop + new_property( + class = S4_to_S7_class(methods::getClass(class)), + name = name + ) } S4_basic_classes <- function() { diff --git a/tests/testthat/test-S4.R b/tests/testthat/test-S4.R index 3ab23b56d..737e78619 100644 --- a/tests/testthat/test-S4.R +++ b/tests/testthat/test-S4.R @@ -176,6 +176,51 @@ test_that("S4_register_contains uses registered S7 unions as S4 slots", { ) }) +test_that("S4_register_contains uses matching S4 unions as S4 slots", { + env <- topenv(environment()) + on.exit(S4_remove_classes( + c( + "S4regContainsExistingUnion::S4Slots", + "S4regContainsExistingUnion", + "S4regExistingUnion", + "S4regUnionMember2", + "S4regUnionMember1" + ), + env + )) + + setClass("S4regUnionMember1", where = env) + setClass("S4regUnionMember2", where = env) + setClassUnion( + "S4regExistingUnion", + c("S4regUnionMember1", "S4regUnionMember2"), + where = env + ) + + S4regContainsExistingUnion <- new_class( + "S4regContainsExistingUnion", + properties = list( + x = getClass("S4regUnionMember1", where = env) | + getClass("S4regUnionMember2", where = env) + ), + package = NULL + ) + + S4regContainsExistingUnion_S4 <- S4_register_contains( + S4regContainsExistingUnion, + env + ) + expect_equal( + as.character( + methods::getClass( + S4regContainsExistingUnion_S4, + where = env + )@slots$x + ), + "S4regExistingUnion" + ) +}) + test_that("S4_register errors on unsupported inputs", { expect_snapshot(error = TRUE, { S4_register(1) @@ -206,25 +251,34 @@ test_that("converts S4 unions to S7 unions", { ) }) -test_that("S4 slot properties preserve S4 class unions", { - on.exit(S4_remove_classes(c( - "S4regUnionSlot", - "S4regUnionSlotParent" - ))) - - setClassUnion("S4regUnionSlot", c("character", "NULL")) - setClass("S4regUnionSlotParent", slots = list(u = "S4regUnionSlot")) +test_that("S4 slot properties convert S4 class unions to S7 unions", { + env <- topenv(environment()) + on.exit(S4_remove_classes( + c( + "S4regUnionSlotChild", + "S4regUnionSlotParent", + "S4regUnionSlot" + ), + env + )) + + setClassUnion("S4regUnionSlot", c("character", "NULL"), where = env) + setClass( + "S4regUnionSlotParent", + slots = list(u = "S4regUnionSlot"), + where = env + ) S4regUnionSlotChild <- new_class( "S4regUnionSlotChild", - parent = getClass("S4regUnionSlotParent"), + parent = getClass("S4regUnionSlotParent", where = env), properties = list(y = class_character), package = NULL ) expect_equal( S4regUnionSlotChild@properties$u$class, - getClass("S4regUnionSlot") + new_union(NULL, class_character) ) }) From 267b8d0a40969a403d5a2830434d94e4eaff957d Mon Sep 17 00:00:00 2001 From: Michael Lawrence Date: Mon, 1 Jun 2026 13:41:46 -0700 Subject: [PATCH 040/132] update test snapshot after rebase --- tests/testthat/_snaps/class.md | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/tests/testthat/_snaps/class.md b/tests/testthat/_snaps/class.md index 6e6f25af2..7cd950118 100644 --- a/tests/testthat/_snaps/class.md +++ b/tests/testthat/_snaps/class.md @@ -117,7 +117,7 @@ @ constructor: function(x) {...} @ validator : @ properties : - $ x: or + $ x: or = integer(0) Code new_class("test", parent = new_union("character")) Condition From 585dd5775b5bf7f8f66763ac690c72f000bdbf09 Mon Sep 17 00:00:00 2001 From: Michael Lawrence Date: Mon, 1 Jun 2026 19:16:50 -0700 Subject: [PATCH 041/132] represent inheritance from S7_object at the S4 level --- R/S4.R | 8 +++++--- R/zzz.R | 8 ++++++++ tests/testthat/test-S4.R | 23 ++++++++++++++++++++++- 3 files changed, 35 insertions(+), 4 deletions(-) diff --git a/R/S4.R b/R/S4.R index e6d3b76ba..515034956 100644 --- a/R/S4.R +++ b/R/S4.R @@ -186,12 +186,13 @@ inherits_S4 <- function(x) { S4_register_subclass <- function(class, env) { where <- topenv(env) subclasses <- S4_subclasses(class) + old_classes <- c(subclasses, "S7_object") if (length(subclasses) > 1L) { - methods::setOldClass(subclasses, where = where) + methods::setOldClass(old_classes, where = where) return() } methods::setOldClass( - subclasses, + old_classes, S4Class = S4_register_prototype_class(class, where), where = where ) @@ -229,7 +230,8 @@ S4_register_with_props <- function(class, env) { methods::setClass( Class = class_name, slots = lapply(properties, S4_property_class, S4_env = where), - contains = contains, + contains = c(contains, "S7_object::S4Slots"), + prototype = methods::prototype(S7_class = class), where = where ) diff --git a/R/zzz.R b/R/zzz.R index 5b9bc2fef..4dcf224b4 100644 --- a/R/zzz.R +++ b/R/zzz.R @@ -22,6 +22,14 @@ S7_object <- new_class( } ) methods::setOldClass("S7_object") +methods::setOldClass(c("S7_class", "S7_object")) +methods::setClass( + "S7_object::S4Slots", + slots = list(S7_class = "S7_class"), + contains = "S7_object", + prototype = methods::prototype(S7_class = S7_object), + where = topenv() +) .S7_type <- NULL # Defined onLoad because it depends on R version diff --git a/tests/testthat/test-S4.R b/tests/testthat/test-S4.R index 737e78619..b00f6b96f 100644 --- a/tests/testthat/test-S4.R +++ b/tests/testthat/test-S4.R @@ -11,6 +11,23 @@ test_that("S4_register registers an S7 class so it can be used with S4 methods", expect_contains(methods::extends("S4regS7"), c("S4regS7", "S7_object")) }) +test_that("S4_register registers S4 constructed instances as S7_object old-class descendants", { + on.exit(S4_remove_classes(c("S4regParent", "S4regS7New"))) + setClass("S4regParent", slots = list(x = "numeric")) + S4regS7New <- new_class( + "S4regS7New", + parent = getClass("S4regParent"), + properties = list(x = class_numeric), + package = NULL + ) + + object <- methods::new("S4regS7New") + + expect_true(isS4(object)) + expect_true(methods::is(object, "S7_object")) + expect_false("S7_class" %in% methods::slotNames(object)) +}) + test_that("S4_register registers an S3 class so it can be used with S4 methods", { on.exit(S4_remove_classes(c("S4regS3a", "S4regS3b"))) S4regS3_S4 <- S4_register(new_S3_class(c("S4regS3a", "S4regS3b"))) @@ -79,7 +96,7 @@ test_that("S4_register_contains registers S7 properties as slots for S4 subclass expect_equal(S4regContainsChild_S4, "S7::S4regContainsChild::S4Slots") expect_equal( methods::slotNames(S4regContainsChild_S4), - c("x", "y", ".S3Class") + c("x", "y", ".S3Class", "S7_class") ) expect_contains( methods::extends(S4regContainsChild_S4), @@ -101,6 +118,10 @@ test_that("S4_register_contains registers S7 properties as slots for S4 subclass expect_equal(methods::slot(object, "x"), 1) expect_equal(methods::slot(object, "y"), "a") expect_equal(methods::slot(object, "z"), TRUE) + expect_equal(methods::slot(object, "S7_class"), S4regContainsChild) + expect_equal(prop_names(object), c("x", "y")) + expect_equal(prop(object, "x"), 1) + expect_equal(prop(object, "y"), "a") methods::setGeneric( "S4regContainsGeneric", From 79bcb078f27473c32796627cf108671a2fb3140b Mon Sep 17 00:00:00 2001 From: Michael Lawrence Date: Mon, 1 Jun 2026 19:25:02 -0700 Subject: [PATCH 042/132] since @<- will dispatch to S7 setting even on S4 objects (derived from S7), we need to use R_do_slot_assign so that a NULL value does not delete the S4 slot. --- src/prop.c | 17 ++++++++++++++++- 1 file changed, 16 insertions(+), 1 deletion(-) diff --git a/src/prop.c b/src/prop.c index 0cd4751f5..3a6926dbf 100644 --- a/src/prop.c +++ b/src/prop.c @@ -196,6 +196,20 @@ void check_is_S7(SEXP object) { signal_is_not_S7(object); } +static inline +Rboolean has_s4_slot(SEXP object, SEXP name_sym) { + return Rf_isS4(object) && R_has_slot(object, name_sym); +} + +static inline +SEXP prop_set_storage(SEXP object, SEXP name_sym, SEXP value) { + if (has_s4_slot(object, name_sym)) + return R_do_slot_assign(object, name_sym, value); + + Rf_setAttrib(object, name_sym, value); + return object; +} + static inline Rboolean pairlist_contains(SEXP list, SEXP elem) { @@ -573,7 +587,8 @@ SEXP prop_set_(SEXP object, SEXP name, SEXP check_sexp, SEXP value) { // don't use setter() if (should_validate_prop) prop_validate(property, value, object, name); - Rf_setAttrib(object, prop_storage_sym(name_sym), value); + object = PROTECT(prop_set_storage(object, prop_storage_sym(name_sym), value)); + n_protected++; } if (should_validate_obj) From 2c38b8f8f919f9f72ddda4699217ae7e9d2768ee Mon Sep 17 00:00:00 2001 From: Michael Lawrence Date: Tue, 2 Jun 2026 02:56:20 -0700 Subject: [PATCH 043/132] inherits2() in prop.c handles S4 object case where class attribute is stored in the .S3Class slot. --- src/prop.c | 17 ++++++++++++++++- 1 file changed, 16 insertions(+), 1 deletion(-) diff --git a/src/prop.c b/src/prop.c index 3a6926dbf..ea85a50e9 100644 --- a/src/prop.c +++ b/src/prop.c @@ -165,11 +165,26 @@ SEXP prop_storage_rename_(SEXP names) { } +static inline +SEXP object_class(SEXP object) { + if (Rf_isS4(object)) { + static SEXP sym_dot_S3Class = NULL; + if (sym_dot_S3Class == NULL) + sym_dot_S3Class = Rf_install(".S3Class"); + + return R_has_slot(object, sym_dot_S3Class) ? + R_do_slot(object, sym_dot_S3Class) : + R_NilValue; + } + + return Rf_getAttrib(object, R_ClassSymbol); +} + static inline Rboolean inherits2(SEXP object, const char* name) { // like inherits in R, but iterates over the class STRSXP vector // in reverse, since S7_* is typically at the tail. - SEXP klass = Rf_getAttrib(object, R_ClassSymbol); + SEXP klass = object_class(object); if (TYPEOF(klass) == STRSXP) { for (int i = Rf_length(klass)-1; i >= 0; i--) { if (strcmp(CHAR(STRING_ELT(klass, i)), name) == 0) From 23f2697ed6e121d35349fa8f5090db7531a52b17 Mon Sep 17 00:00:00 2001 From: Michael Lawrence Date: Tue, 2 Jun 2026 05:31:53 -0700 Subject: [PATCH 044/132] tweaks to validObject hooks to support additional inheritance patterns --- R/S4.R | 21 +++++++++-- tests/testthat/test-S4.R | 78 +++++++++++++++++++++++++++++++++++++++- 2 files changed, 95 insertions(+), 4 deletions(-) diff --git a/R/S4.R b/R/S4.R index 515034956..e95e94041 100644 --- a/R/S4.R +++ b/R/S4.R @@ -196,7 +196,7 @@ S4_register_subclass <- function(class, env) { S4Class = S4_register_prototype_class(class, where), where = where ) - methods::setValidity(subclasses[1L], S4_validate, where = where) + methods::setValidity(subclasses[1L], S4_validate_old_class, where = where) methods::setMethod("initialize", subclasses[1L], S4_initialize, where = where) } @@ -234,6 +234,7 @@ S4_register_with_props <- function(class, env) { prototype = methods::prototype(S7_class = class), where = where ) + methods::setValidity(class_name, S4_validate_shim, where = where) class_name } @@ -270,7 +271,21 @@ S4_subclasses <- function(class) { character() } -S4_validate <- function(object) { +S4_validate_old_class <- function(object) { + if (isS4(object)) { + # covered by S4_validate_shim() + return(TRUE) + } + + S4_validate_from(object) +} + +S4_validate_shim <- function(object) { + parent <- S4_ancestor(S7_class(object)) %||% S7_object + S4_validate_from(object, parent = parent) +} + +S4_validate_from <- function(object, parent = NULL) { if (!S7_inherits(object)) { return(sprintf( "object with S4 class %s is not an S7 object", @@ -280,7 +295,7 @@ S4_validate <- function(object) { tryCatch( { - validate(object) + validate_from(object, parent = parent) TRUE }, error = function(cnd) conditionMessage(cnd) diff --git a/tests/testthat/test-S4.R b/tests/testthat/test-S4.R index b00f6b96f..f3b8eed68 100644 --- a/tests/testthat/test-S4.R +++ b/tests/testthat/test-S4.R @@ -88,6 +88,9 @@ test_that("S4_register_contains registers S7 properties as slots for S4 subclass "S4regContainsChild", parent = S4regContains, properties = list(y = class_character), + validator = function(self) { + if (identical(self@y, "bad")) "bad y" + }, package = "S7" ) @@ -122,6 +125,11 @@ test_that("S4_register_contains registers S7 properties as slots for S4 subclass expect_equal(prop_names(object), c("x", "y")) expect_equal(prop(object, "x"), 1) expect_equal(prop(object, "y"), "a") + expect_true(methods::validObject(object)) + + invalid <- object + methods::slot(invalid, "y") <- "bad" + expect_error(methods::validObject(invalid), "bad y") methods::setGeneric( "S4regContainsGeneric", @@ -133,6 +141,74 @@ test_that("S4_register_contains registers S7 properties as slots for S4 subclass expect_equal(S4regContainsGeneric(object), 1) }) +test_that("S4_register_contains constructs S4 subclasses of S7 classes that extend S4 classes", { + on.exit(S4_remove_classes(c( + "S4regNewParent", + "S4regNewMiddle", + "S4regNewChild", + "S4regNewChild::S4Slots", + "S4regNewGrandChild" + ))) + setClass( + "S4regNewParent", + slots = list(assays = "list", rowData = "character") + ) + + S4regNewMiddle <- new_class( + "S4regNewMiddle", + parent = getClass("S4regNewParent"), + properties = list(metadata = class_character), + validator = function(self) { + if (identical(self@metadata, "bad")) "bad metadata" + }, + package = NULL + ) + S4regNewChild <- new_class( + "S4regNewChild", + parent = S4regNewMiddle, + properties = list(status = class_character), + validator = function(self) { + if (identical(self@status, "bad")) "bad status" + }, + package = NULL + ) + S4regNewChild_S4 <- S4_register_contains(S4regNewChild) + setClass( + "S4regNewGrandChild", + contains = S4regNewChild_S4 + ) + + object <- methods::new("S4regNewGrandChild") + + expect_true(isS4(object)) + expect_true(methods::is(object, "S7_object")) + expect_true(methods::is(object, "S4regNewParent")) + expect_true(methods::is(object, S4regNewChild_S4)) + expect_true(S7_inherits(object, S4regNewChild)) + expect_equal(methods::slot(object, "S7_class"), S4regNewChild) + expect_equal(methods::slot(object, "assays"), list()) + expect_equal(methods::slot(object, "rowData"), character()) + expect_equal(methods::slot(object, "metadata"), character()) + expect_equal(methods::slot(object, "status"), character()) + expect_equal( + prop_names(object), + c("assays", "rowData", "metadata", "status") + ) + expect_equal(prop(object, "assays"), list()) + expect_equal(prop(object, "rowData"), character()) + expect_equal(prop(object, "metadata"), character()) + expect_equal(prop(object, "status"), character()) + expect_true(methods::validObject(object)) + + invalid <- object + methods::slot(invalid, "metadata") <- "bad" + expect_error(methods::validObject(invalid), "bad metadata") + + invalid <- object + methods::slot(invalid, "status") <- "bad" + expect_error(methods::validObject(invalid), "bad status") +}) + test_that("S4_register_contains rejects properties that can not be represented as slots", { on.exit(S4_remove_classes(c( "S7::S4regContainsDynamic", @@ -362,7 +438,7 @@ test_that("S7 classes can extend S4 classes", { expect_equal(prop(child, "x"), 7) expect_error(methods::initialize(child, x = "x"), "invalid") - expect_error(methods::initialize(child, z = 1), "Can't find property") + expect_error(methods::initialize(child, z = 1), "Property not found") expect_error(Child(x = "x", y = "a")) }) From 29e586b0bc6b92414a6ce3a88482fcbc2323398c Mon Sep 17 00:00:00 2001 From: Michael Lawrence Date: Tue, 2 Jun 2026 16:34:46 -0700 Subject: [PATCH 045/132] 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. --- R/class-spec.R | 4 ++-- R/class.R | 6 +++++- tests/testthat/test-S4.R | 26 ++++++++++++++++++++++++++ 3 files changed, 33 insertions(+), 3 deletions(-) diff --git a/R/class-spec.R b/R/class-spec.R index f69a2eed7..847a69794 100644 --- a/R/class-spec.R +++ b/R/class-spec.R @@ -359,10 +359,10 @@ class_extends <- function(child, parent) { 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 { diff --git a/R/class.R b/R/class.R index b47615876..ce17d4ac4 100644 --- a/R/class.R +++ b/R/class.R @@ -427,7 +427,11 @@ S7_class <- function(object) { obj_type(object), missing = class_missing, S7 = .Call(S7_class_, object), - S4 = methods::getClass(class(object)), + S4 = if (has_S7_class(object)) { + .Call(S7_class_, object) + } else { + methods::getClass(class(object)) + }, S3 = new_S3_class(class(object)), base = base_S7_class(object) ) diff --git a/tests/testthat/test-S4.R b/tests/testthat/test-S4.R index f3b8eed68..5b3f543c8 100644 --- a/tests/testthat/test-S4.R +++ b/tests/testthat/test-S4.R @@ -126,6 +126,32 @@ test_that("S4_register_contains registers S7 properties as slots for S4 subclass 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" From bac114849fd6d47e016875fafdc7ce2b0d00f574 Mon Sep 17 00:00:00 2001 From: Michael Lawrence Date: Tue, 2 Jun 2026 16:58:36 -0700 Subject: [PATCH 046/132] restore method-register-S4.R; got lost in the rebase shuffle --- R/method-register-S4.R | 11 +++++++++++ R/method-register.R | 12 ------------ 2 files changed, 11 insertions(+), 12 deletions(-) create mode 100644 R/method-register-S4.R diff --git a/R/method-register-S4.R b/R/method-register-S4.R new file mode 100644 index 000000000..28f95e942 --- /dev/null +++ b/R/method-register-S4.R @@ -0,0 +1,11 @@ +register_S4_method <- function( + generic, + signature, + method, + env = parent.frame(), + call = sys.call(-1L) +) { + S4_env <- topenv(env) + S4_signature <- lapply(signature, S4_class, S4_env = S4_env, call = call) + methods::setMethod(generic, S4_signature, method, where = S4_env) +} diff --git a/R/method-register.R b/R/method-register.R index 6c5ef9585..2afd6ea36 100644 --- a/R/method-register.R +++ b/R/method-register.R @@ -370,18 +370,6 @@ check_method <- function( invisible(TRUE) } -register_S4_method <- function( - generic, - signature, - method, - env = parent.frame(), - call = sys.call(-1L) -) { - S4_env <- topenv(env) - S4_signature <- lapply(signature, S4_class, S4_env = S4_env, call = call) - methods::setMethod(generic, S4_signature, method, where = S4_env) -} - #' @export print.S7_method <- function(x, ...) { signature <- method_signature(x@generic, x@signature) From b3937b5448eba9a6ab1fef6326077850a365a7f1 Mon Sep 17 00:00:00 2001 From: Michael Lawrence Date: Wed, 3 Jun 2026 03:59:23 -0700 Subject: [PATCH 047/132] prop storage now uses the S4 sentinel for NULL for low-level compatibility with S4; arguably a generally better approach since it avoids adding and deleting attributes based on whether the value is NULL or not. --- src/prop.c | 20 ++++++++++++++------ tests/testthat/test-S4.R | 37 +++++++++++++++++++++++++++++++++++++ 2 files changed, 51 insertions(+), 6 deletions(-) diff --git a/src/prop.c b/src/prop.c index ea85a50e9..91045f323 100644 --- a/src/prop.c +++ b/src/prop.c @@ -212,15 +212,23 @@ void check_is_S7(SEXP object) { } static inline -Rboolean has_s4_slot(SEXP object, SEXP name_sym) { - return Rf_isS4(object) && R_has_slot(object, name_sym); +SEXP pseudo_null(void) { + static SEXP pseudo_NULL = NULL; + if (pseudo_NULL == NULL) + pseudo_NULL = Rf_install("\001NULL\001"); + return pseudo_NULL; } static inline -SEXP prop_set_storage(SEXP object, SEXP name_sym, SEXP value) { - if (has_s4_slot(object, name_sym)) - return R_do_slot_assign(object, name_sym, value); +SEXP prop_get_storage(SEXP object, SEXP name_sym) { + SEXP value = Rf_getAttrib(object, name_sym); + return value == pseudo_null() ? R_NilValue : value; +} +static inline +SEXP prop_set_storage(SEXP object, SEXP name_sym, SEXP value) { + if (value == R_NilValue) + value = pseudo_null(); Rf_setAttrib(object, name_sym, value); return object; } @@ -517,7 +525,7 @@ SEXP prop_(SEXP object, SEXP name) { } // try to resolve property from the object attributes - SEXP value = Rf_getAttrib(object, prop_storage_sym(name_sym)); + SEXP value = prop_get_storage(object, prop_storage_sym(name_sym)); // This is commented out because we currently have no way to distinguish between // a prop with a value of NULL, and a prop value that is unset/missing. diff --git a/tests/testthat/test-S4.R b/tests/testthat/test-S4.R index 5b3f543c8..f7436c8fe 100644 --- a/tests/testthat/test-S4.R +++ b/tests/testthat/test-S4.R @@ -235,6 +235,43 @@ test_that("S4_register_contains constructs S4 subclasses of S7 classes that exte expect_error(methods::validObject(invalid), "bad status") }) +test_that("S4_register_contains treats S4 NULL slot sentinels as NULL-valued S7 properties", { + on.exit(S4_remove_classes(c( + "S4regNullable", + "S4regNullable::S4Slots", + "S4regNullableChild", + "NULL_OR_character" + ))) + + S4_register(NULL | class_character) + S4regNullable <- new_class( + "S4regNullable", + properties = list( + x = new_property(NULL | class_character, default = NULL) + ), + package = NULL + ) + S4regNullable_S4 <- S4_register_contains(S4regNullable) + methods::setClass("S4regNullableChild", contains = S4regNullable_S4) + + object <- methods::new("S4regNullableChild") + + expect_equal(methods::slot(object, "x"), NULL) + expect_equal(prop(object, "x"), NULL) + expect_true(methods::validObject(object)) + expect_no_error(methods::new("S4regNullableChild", x = NULL)) + + object_with_value <- methods::new("S4regNullableChild", x = "a") + prop(object_with_value, "x", check = FALSE) <- NULL + expect_equal(methods::slot(object_with_value, "x"), NULL) + expect_equal(prop(object_with_value, "x"), NULL) + + plain <- S4regNullable(x = "a") + prop(plain, "x") <- NULL + expect_equal(prop(plain, "x"), NULL) + expect_identical(attr(plain, "x", exact = TRUE), as.name("\001NULL\001")) +}) + test_that("S4_register_contains rejects properties that can not be represented as slots", { on.exit(S4_remove_classes(c( "S7::S4regContainsDynamic", From 2967e93bb1413187ca4e52bbaa534eda3c245b3f Mon Sep 17 00:00:00 2001 From: Michael Lawrence Date: Wed, 3 Jun 2026 04:01:53 -0700 Subject: [PATCH 048/132] push S4 validation guard down into validate() so that it works for validate() as well as validObject() --- R/S4.R | 9 ++++----- R/valid.R | 14 +++++++++++++- tests/testthat/test-S4.R | 2 +- 3 files changed, 18 insertions(+), 7 deletions(-) diff --git a/R/S4.R b/R/S4.R index e95e94041..b906f4469 100644 --- a/R/S4.R +++ b/R/S4.R @@ -277,15 +277,14 @@ S4_validate_old_class <- function(object) { return(TRUE) } - S4_validate_from(object) + S4_validate(object) } S4_validate_shim <- function(object) { - parent <- S4_ancestor(S7_class(object)) %||% S7_object - S4_validate_from(object, parent = parent) + S4_validate(object) } -S4_validate_from <- function(object, parent = NULL) { +S4_validate <- function(object) { if (!S7_inherits(object)) { return(sprintf( "object with S4 class %s is not an S7 object", @@ -295,7 +294,7 @@ S4_validate_from <- function(object, parent = NULL) { tryCatch( { - validate_from(object, parent = parent) + validate(object) TRUE }, error = function(cnd) conditionMessage(cnd) diff --git a/R/valid.R b/R/valid.R index 86dbf7efb..71d62ba43 100644 --- a/R/valid.R +++ b/R/valid.R @@ -66,7 +66,7 @@ validate <- function(object, recursive = TRUE, properties = TRUE) { check_is_S7(object) - parent <- if (!recursive) S7_class(object)@parent + parent <- validate_parent(object, recursive) validate_from( object, parent = parent, @@ -75,6 +75,18 @@ validate <- function(object, recursive = TRUE, properties = TRUE) { ) } +validate_parent <- function(object, recursive) { + if (!recursive) { + return(S7_class(object)@parent) + } + + if (isS4(object) && has_S7_class(object)) { + return(S4_ancestor(S7_class(object)) %||% S7_object) + } + + NULL +} + # validates `object` assuming `parent` (if supplied) has been validated validate_from <- function( object, diff --git a/tests/testthat/test-S4.R b/tests/testthat/test-S4.R index f7436c8fe..849b7eae7 100644 --- a/tests/testthat/test-S4.R +++ b/tests/testthat/test-S4.R @@ -262,7 +262,7 @@ test_that("S4_register_contains treats S4 NULL slot sentinels as NULL-valued S7 expect_no_error(methods::new("S4regNullableChild", x = NULL)) object_with_value <- methods::new("S4regNullableChild", x = "a") - prop(object_with_value, "x", check = FALSE) <- NULL + prop(object_with_value, "x") <- NULL expect_equal(methods::slot(object_with_value, "x"), NULL) expect_equal(prop(object_with_value, "x"), NULL) From 453893ecff5b29c843945200ce1c9f094abdb9cf Mon Sep 17 00:00:00 2001 From: Michael Lawrence Date: Wed, 3 Jun 2026 14:34:48 -0700 Subject: [PATCH 049/132] Define S4 prototype on the ::S4Slots old class based on property defaults. We evaluate these if they are language objects, so S7 classes extending or being extended by S4 classes need to ensure that evaluation can happen at build time. Also mark it VIRTUAL because it should never be constructed directly. --- R/S4.R | 41 ++++++++++++++++++++++++++++++++++++++-- tests/testthat/test-S4.R | 32 +++++++++++++++++++++++++++++++ 2 files changed, 71 insertions(+), 2 deletions(-) diff --git a/R/S4.R b/R/S4.R index b906f4469..0cfedcd37 100644 --- a/R/S4.R +++ b/R/S4.R @@ -230,8 +230,8 @@ S4_register_with_props <- function(class, env) { methods::setClass( Class = class_name, slots = lapply(properties, S4_property_class, S4_env = where), - contains = c(contains, "S7_object::S4Slots"), - prototype = methods::prototype(S7_class = class), + contains = c(contains, "S7_object::S4Slots", "VIRTUAL"), + prototype = S4_properties_prototype(properties, class, where, TRUE), where = where ) methods::setValidity(class_name, S4_validate_shim, where = where) @@ -259,6 +259,43 @@ S4_property_class <- function(prop, S4_env) { S4_class(prop$class, S4_env) } +S4_properties_prototype <- function( + properties, + class, + env, + include_S7_class = FALSE +) { + args <- list() + for (name in names(properties)) { + value <- S4_property_prototype(properties[[name]], env, class@package) + if (length(value) != 0L) { + args[[name]] <- value[[1L]] + } + } + if (include_S7_class) { + args$S7_class <- class + } + do.call(methods::prototype, args) +} + +S4_property_prototype <- function(prop, env, package) { + tryCatch( + { + value <- prop_default(prop, env, package) + if (is.call(value) || is.symbol(value)) { + value <- eval(value, env) + } + list(value) + }, + error = function(cnd) { + if (!is.null(prop$default)) { + stop(cnd) + } + list() + } + ) +} + S4_subclasses <- function(class) { subclasses <- character() while (is_class(class)) { diff --git a/tests/testthat/test-S4.R b/tests/testthat/test-S4.R index 849b7eae7..df2b714d5 100644 --- a/tests/testthat/test-S4.R +++ b/tests/testthat/test-S4.R @@ -235,6 +235,38 @@ test_that("S4_register_contains constructs S4 subclasses of S7 classes that exte expect_error(methods::validObject(invalid), "bad status") }) +test_that("S4_register_contains uses S7 property defaults as S4 shim prototypes", { + on.exit(S4_remove_classes(c( + "S4regPrototype", + "S4regPrototype::S4Slots", + "S4regPrototypeChild", + "NULL_OR_character" + ))) + + S4_register(NULL | class_character) + S4regPrototype <- new_class( + "S4regPrototype", + properties = list( + x = new_property(class_numeric, default = quote(1)), + y = new_property(class_character, default = quote("a")), + z = new_property(NULL | class_character, default = NULL) + ), + package = NULL + ) + S4regPrototype_S4 <- S4_register_contains(S4regPrototype) + methods::setClass("S4regPrototypeChild", contains = S4regPrototype_S4) + + object <- methods::new("S4regPrototypeChild") + + expect_equal(methods::slot(object, "x"), 1) + expect_equal(methods::slot(object, "y"), "a") + expect_equal(methods::slot(object, "z"), NULL) + expect_equal(prop(object, "x"), 1) + expect_equal(prop(object, "y"), "a") + expect_equal(prop(object, "z"), NULL) + expect_true(methods::validObject(object)) +}) + test_that("S4_register_contains treats S4 NULL slot sentinels as NULL-valued S7 properties", { on.exit(S4_remove_classes(c( "S4regNullable", From 5d069a50ff8e8666d996e2d81e943e9f12275cd7 Mon Sep 17 00:00:00 2001 From: Michael Lawrence Date: Wed, 3 Jun 2026 17:05:26 -0700 Subject: [PATCH 050/132] mark the subclass old class as virtual, because there should never be an S4 instance of that class (old classes are virtual normally but not in this case since we pass an S4Class prototype) --- R/S4.R | 2 +- tests/testthat/test-S4.R | 13 +++++++------ 2 files changed, 8 insertions(+), 7 deletions(-) diff --git a/R/S4.R b/R/S4.R index 0cfedcd37..085bc75a5 100644 --- a/R/S4.R +++ b/R/S4.R @@ -402,7 +402,7 @@ S4_register_prototype_class <- function(class, env = parent.frame()) { methods::setClass( Class = classes[1L], - contains = parent_class@className, + contains = c(parent_class@className, "VIRTUAL"), where = where ) diff --git a/tests/testthat/test-S4.R b/tests/testthat/test-S4.R index df2b714d5..2dc5aa546 100644 --- a/tests/testthat/test-S4.R +++ b/tests/testthat/test-S4.R @@ -11,7 +11,7 @@ test_that("S4_register registers an S7 class so it can be used with S4 methods", expect_contains(methods::extends("S4regS7"), c("S4regS7", "S7_object")) }) -test_that("S4_register registers S4 constructed instances as S7_object old-class descendants", { +test_that("S4_register registers S4 old classes as virtual S7_object descendants", { on.exit(S4_remove_classes(c("S4regParent", "S4regS7New"))) setClass("S4regParent", slots = list(x = "numeric")) S4regS7New <- new_class( @@ -21,11 +21,12 @@ test_that("S4_register registers S4 constructed instances as S7_object old-class package = NULL ) - object <- methods::new("S4regS7New") - - expect_true(isS4(object)) - expect_true(methods::is(object, "S7_object")) - expect_false("S7_class" %in% methods::slotNames(object)) + expect_error( + methods::new("S4regS7New"), + "trying to generate an object from a virtual class" + ) + expect_true(methods::extends("S4regS7New", "S7_object")) + expect_false("S7_class" %in% methods::slotNames("S4regS7New")) }) test_that("S4_register registers an S3 class so it can be used with S4 methods", { From 92368d0ba7d8c4e255496da1c6813290b2aeae96 Mon Sep 17 00:00:00 2001 From: Michael Lawrence Date: Wed, 3 Jun 2026 17:09:05 -0700 Subject: [PATCH 051/132] give convert_up() a general as()-based fallback like convert() --- R/convert.R | 7 ++----- 1 file changed, 2 insertions(+), 5 deletions(-) diff --git a/R/convert.R b/R/convert.R index d40237441..e2abf2c45 100644 --- a/R/convert.R +++ b/R/convert.R @@ -190,11 +190,8 @@ convert_up <- function(from, to, call = sys.call(-1L)) { from <- zap_attr(from, c(setdiff(from_props, to_props), "S7_class")) attr(from, "_S7_class") <- to class(from) <- class_dispatch(to) - } else if (is_S4_class(to)) { - to_slots <- methods::slotNames(to) - from <- zap_attr(from, c(setdiff(from_props, to_slots), "S7_class")) - class(from) <- structure(to@className, package = to@package) - from <- asS4(from) + } else if (is_S4_coerce(from, to)) { + from <- convert_S4(from, to) } else { stop2("Unreachable.") } From 3a979ef3f99f45c13d6199fa753a5e22f204b7a9 Mon Sep 17 00:00:00 2001 From: Michael Lawrence Date: Wed, 3 Jun 2026 18:53:23 -0700 Subject: [PATCH 052/132] make the ::S4Slots class non-virtual to enable more convenient construction --- R/S4.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/R/S4.R b/R/S4.R index 085bc75a5..c8553dadc 100644 --- a/R/S4.R +++ b/R/S4.R @@ -230,7 +230,7 @@ S4_register_with_props <- function(class, env) { methods::setClass( Class = class_name, slots = lapply(properties, S4_property_class, S4_env = where), - contains = c(contains, "S7_object::S4Slots", "VIRTUAL"), + contains = c(contains, "S7_object::S4Slots"), prototype = S4_properties_prototype(properties, class, where, TRUE), where = where ) From 22e70c23439e87264eccb38a451ae0014a1d4190 Mon Sep 17 00:00:00 2001 From: Michael Lawrence Date: Wed, 3 Jun 2026 23:36:02 -0700 Subject: [PATCH 053/132] drop the up cast coercions (dead end) and instead ensure full slot representation along the old class chain --- R/S4.R | 42 +++++++++++++++++++++++++-------- tests/testthat/test-S4.R | 50 +++++++++++++++++++++++++++------------- 2 files changed, 67 insertions(+), 25 deletions(-) diff --git a/R/S4.R b/R/S4.R index c8553dadc..930c1666d 100644 --- a/R/S4.R +++ b/R/S4.R @@ -187,17 +187,24 @@ S4_register_subclass <- function(class, env) { where <- topenv(env) subclasses <- S4_subclasses(class) old_classes <- c(subclasses, "S7_object") - if (length(subclasses) > 1L) { - methods::setOldClass(old_classes, where = where) - return() - } methods::setOldClass( old_classes, S4Class = S4_register_prototype_class(class, where), where = where ) - methods::setValidity(subclasses[1L], S4_validate_old_class, where = where) - methods::setMethod("initialize", subclasses[1L], S4_initialize, where = where) + S4_set_S3_class_prototype(subclasses[1L], old_classes, where) + + if (length(subclasses) == 1L) { + methods::setValidity(subclasses[1L], S4_validate_old_class, where = where) + methods::setMethod( + "initialize", + subclasses[1L], + S4_initialize, + where = where + ) + } + + invisible() } #' @rdname S4_register @@ -226,7 +233,6 @@ S4_register_with_props <- function(class, env) { names(properties), S4_slot_names(contains, where) )] - methods::setClass( Class = class_name, slots = lapply(properties, S4_property_class, S4_env = where), @@ -234,11 +240,23 @@ S4_register_with_props <- function(class, env) { prototype = S4_properties_prototype(properties, class, where, TRUE), where = where ) + S4_set_S3_class_prototype( + class_name, + c(S4_subclasses(class), "S7_object"), + where + ) methods::setValidity(class_name, S4_validate_shim, where = where) class_name } +S4_set_S3_class_prototype <- function(class, S3_class, env) { + class_def <- methods::getClass(class, where = env) + attr(class_def@prototype, ".S3Class") <- S3_class + methods:::assignClassDef(class, class_def, env) + invisible(class) +} + S4_slot_names <- function(class, S4_env) { names(methods::getClass(class, where = S4_env)@slots) } @@ -398,11 +416,17 @@ S4_register_prototype_class <- function(class, env = parent.frame()) { classes <- class_dispatch(class) parent_class <- class@parent - stopifnot(is_S4_class(parent_class)) + parent_class_name <- S4_class(parent_class, where) + properties <- class@properties + properties <- properties[setdiff( + names(properties), + S4_slot_names(parent_class_name, where) + )] methods::setClass( Class = classes[1L], - contains = c(parent_class@className, "VIRTUAL"), + slots = lapply(properties, S4_property_class, S4_env = where), + contains = c(parent_class_name, "VIRTUAL"), where = where ) diff --git a/tests/testthat/test-S4.R b/tests/testthat/test-S4.R index 2dc5aa546..2dbf2e581 100644 --- a/tests/testthat/test-S4.R +++ b/tests/testthat/test-S4.R @@ -180,6 +180,13 @@ test_that("S4_register_contains constructs S4 subclasses of S7 classes that exte "S4regNewParent", slots = list(assays = "list", rowData = "character") ) + methods::setValidity("S4regNewParent", function(object) { + if (!identical(methods::slot(object, "assays"), list())) { + "assays slot was stripped during parent coercion" + } else { + TRUE + } + }) S4regNewMiddle <- new_class( "S4regNewMiddle", @@ -200,6 +207,14 @@ test_that("S4_register_contains constructs S4 subclasses of S7 classes that exte package = NULL ) S4regNewChild_S4 <- S4_register_contains(S4regNewChild) + expect_equal( + methods::slotNames("S4regNewChild"), + c("status", "metadata", "assays", "rowData", ".S3Class") + ) + expect_contains( + methods::slotNames(S4regNewChild_S4), + c("status", "metadata", "S7_class") + ) setClass( "S4regNewGrandChild", contains = S4regNewChild_S4 @@ -234,6 +249,10 @@ test_that("S4_register_contains constructs S4 subclasses of S7 classes that exte invalid <- object methods::slot(invalid, "status") <- "bad" expect_error(methods::validObject(invalid), "bad status") + + object_old <- methods::as(object, "S4regNewChild") + expect_equal(methods::slot(object_old, "metadata"), character()) + expect_equal(methods::slot(object_old, "status"), character()) }) test_that("S4_register_contains uses S7 property defaults as S4 shim prototypes", { @@ -512,7 +531,7 @@ test_that("S7 classes can extend S4 classes", { expect_true(methods::is(child, "Parent")) expect_true(methods::validObject(child)) - expect_equal(methods::slotNames("Child"), c("x", "y", ".S3Class")) + expect_equal(methods::slotNames("Child"), c("y", "x", ".S3Class")) expect_equal(methods::slot(child, "x"), 2) expect_equal(methods::slot(child, "y"), "b") @@ -562,26 +581,25 @@ test_that("S4 initialize supports S3 data parts", { expect_true(methods::validObject(child)) }) -test_that("S4 initialize uses S7 property setters", { +test_that("S4 classes can not extend S7-over-S4 classes with property setters", { on.exit(S4_remove_classes(c("Parent2", "Child2"))) setClass("Parent2", slots = list(x = "numeric")) - Child2 <- new_class( - "Child2", - parent = getClass("Parent2"), - properties = list( - y = new_property(class_character, setter = function(self, value) { - attr(self, "setter_called") <- TRUE - attr(self, "y") <- value - self - }) + expect_error( + new_class( + "Child2", + parent = getClass("Parent2"), + properties = list( + y = new_property(class_character, setter = function(self, value) { + attr(self, "setter_called") <- TRUE + attr(self, "y") <- value + self + }) + ), + package = NULL ), - package = NULL + "custom setter" ) - - child <- methods::initialize(Child2(x = 1, y = "a"), y = "b") - expect_equal(prop(child, "y"), "b") - expect_true(attr(child, "setter_called")) }) From 0c57f8e108c639c4f6d03030e37511a3b296dd10 Mon Sep 17 00:00:00 2001 From: Michael Lawrence Date: Thu, 4 Jun 2026 04:01:01 -0700 Subject: [PATCH 054/132] S3 method registration will also register an S4 method when the generic is internal and an element of the signature has an S4 ancestor. This is needed because internal generics will favor S4 methods on S4 objects, so there is potential for inheriting overrides. --- R/method-register-S3.R | 4 +++ R/method-register-S4.R | 17 +++++++++++++ tests/testthat/test-method-register-S3.R | 32 ++++++++++++++++++++++++ 3 files changed, 53 insertions(+) diff --git a/R/method-register-S3.R b/R/method-register-S3.R index 42e7e614c..69e88f81f 100644 --- a/R/method-register-S3.R +++ b/R/method-register-S3.R @@ -29,6 +29,10 @@ register_S3_method <- function( envir <- environment(generic$generic) %||% envir registerS3method(generic$name, class, method, envir) } + + if (should_register_S4_method_for_internal_generic(generic, signature)) { + register_S4_method(generic$name, signature, method, envir, call = call) + } } # `registerS3method()` registers into the S3 methods table of diff --git a/R/method-register-S4.R b/R/method-register-S4.R index 28f95e942..343c8204c 100644 --- a/R/method-register-S4.R +++ b/R/method-register-S4.R @@ -9,3 +9,20 @@ register_S4_method <- function( S4_signature <- lapply(signature, S4_class, S4_env = S4_env, call = call) methods::setMethod(generic, S4_signature, method, where = S4_env) } + +should_register_S4_method_for_internal_generic <- function(generic, signature) { + is_internal_generic(generic$name) && signature_has_S4_ancestor(signature) +} + +signature_has_S4_ancestor <- function(signature) { + any(vlapply(signature, class_has_S4_ancestor)) +} + +class_has_S4_ancestor <- function(class) { + switch( + class_type(class), + S4 = TRUE, + S7 = S7_extends_S4(class), + FALSE + ) +} diff --git a/tests/testthat/test-method-register-S3.R b/tests/testthat/test-method-register-S3.R index 9357398fe..24ec49b3d 100644 --- a/tests/testthat/test-method-register-S3.R +++ b/tests/testthat/test-method-register-S3.R @@ -55,6 +55,38 @@ test_that("can register S7 method for S3 generic with S3 class signature", { expect_equal(s3_gen(factor("a")), "factor") }) +test_that("internal generics register S4 methods for S4-backed S7 classes", { + on.exit({ + try(methods::removeMethod("dim", "S4regDimParent"), silent = TRUE) + try(methods::removeMethod("dim", "S4regDimChild"), silent = TRUE) + S4_remove_classes(c( + "S4regDimParent", + "S4regDimChild", + "S4regDimChild::S4Slots", + "S4regDimShim" + )) + }) + + setClass("S4regDimParent", contains = "VIRTUAL") + setMethod("dim", "S4regDimParent", function(x) { + stop("parent S4 method should not be called", call. = FALSE) + }) + S4regDimChild <- new_class( + "S4regDimChild", + parent = getClass("S4regDimParent"), + properties = list(x = class_integer), + package = NULL + ) + method(dim, S4regDimChild) <- function(x) c(x@x, 2L) + S4regDimChild_S4 <- S4_register_contains(S4regDimChild) + setClass("S4regDimShim", contains = S4regDimChild_S4) + + object <- methods::new("S4regDimShim", x = 1L) + + expect_true(isS4(object)) + expect_equal(dim(object), c(1L, 2L)) +}) + test_that("S3 registration for a multi-class S3 class uses only the first class", { local_s3_generic("s3_gen") method(s3_gen, new_S3_class(c("ordered", "factor"))) <- function(x) "ord" From 2120e3ae233706e643b84912aa18e9e496ae3fe4 Mon Sep 17 00:00:00 2001 From: Michael Lawrence Date: Thu, 4 Jun 2026 04:32:50 -0700 Subject: [PATCH 055/132] abstract S7 classes deriving from S4 classes are represented as ordinary S4 classes instead of old classes, because an old class implies an S3 instance of the object can exist, ie, there can be an S3Part(). --- R/S4.R | 52 +++++++++++++++++++++++++++++++++++++--- tests/testthat/test-S4.R | 50 ++++++++++++++++++++++++++++++++++++++ 2 files changed, 99 insertions(+), 3 deletions(-) diff --git a/R/S4.R b/R/S4.R index 930c1666d..2103b6f2f 100644 --- a/R/S4.R +++ b/R/S4.R @@ -32,6 +32,9 @@ #' methods::setClass("S4Child", contains = S4Foo_S4) S4_register <- function(class, env = parent.frame()) { if (is_class(class)) { + if (class@abstract) { + return(invisible(S4_register_abstract_class(class, topenv(env)))) + } classes <- class_dispatch(class) } else if (is_S3_class(class)) { classes <- class$class @@ -185,7 +188,12 @@ inherits_S4 <- function(x) { S4_register_subclass <- function(class, env) { where <- topenv(env) - subclasses <- S4_subclasses(class) + if (class@abstract) { + S4_register_abstract_class(class, where) + return(invisible()) + } + + subclasses <- S4_old_classes(class) old_classes <- c(subclasses, "S7_object") methods::setOldClass( old_classes, @@ -242,7 +250,7 @@ S4_register_with_props <- function(class, env) { ) S4_set_S3_class_prototype( class_name, - c(S4_subclasses(class), "S7_object"), + c(S4_old_classes(class), "S7_object"), where ) methods::setValidity(class_name, S4_validate_shim, where = where) @@ -314,9 +322,12 @@ S4_property_prototype <- function(prop, env, package) { ) } -S4_subclasses <- function(class) { +S4_old_classes <- function(class) { subclasses <- character() while (is_class(class)) { + if (class@abstract) { + return(subclasses) + } subclasses <- c(subclasses, S7_class_name(class)) class <- class@parent if (is_S4_class(class)) { @@ -326,6 +337,41 @@ S4_subclasses <- function(class) { character() } +S4_register_abstract_class <- function(class, env = parent.frame()) { + where <- topenv(env) + class_name <- S7_class_name(class) + parent_class_name <- S4_abstract_parent_class(class, where) + properties <- class@properties + if (!is.null(parent_class_name)) { + properties <- properties[setdiff( + names(properties), + S4_slot_names(parent_class_name, where) + )] + } + + methods::setClass( + Class = class_name, + slots = lapply(properties, S4_property_class, S4_env = where), + contains = c(parent_class_name, "VIRTUAL"), + where = where + ) + + class_name +} + +S4_abstract_parent_class <- function(class, env) { + parent_class <- class@parent + if (is_class(parent_class)) { + if (parent_class@abstract) { + return(S4_class(parent_class, env)) + } + } else if (is_S4_class(parent_class)) { + return(S4_class(parent_class, env)) + } + + NULL +} + S4_validate_old_class <- function(object) { if (isS4(object)) { # covered by S4_validate_shim() diff --git a/tests/testthat/test-S4.R b/tests/testthat/test-S4.R index 2dbf2e581..9531e3394 100644 --- a/tests/testthat/test-S4.R +++ b/tests/testthat/test-S4.R @@ -255,6 +255,56 @@ test_that("S4_register_contains constructs S4 subclasses of S7 classes that exte expect_equal(methods::slot(object_old, "status"), character()) }) +test_that("S4_register registers abstract S7 classes as virtual S4 classes", { + on.exit({ + try(methods::removeMethod("dim", "S4regAbstractConcrete"), silent = TRUE) + S4_remove_classes(c( + "S4regAbstractParent", + "S4regAbstract", + "S4regAbstractConcrete", + "S4regAbstractConcrete::S4Slots", + "S4regAbstractShim" + )) + }) + + setClass("S4regAbstractParent", contains = "VIRTUAL") + methods::setValidity("S4regAbstractParent", function(object) { + if (!identical(dim(object), c(1L, 2L))) { + "dim() did not dispatch to the concrete S7 class" + } else { + TRUE + } + }) + + S4regAbstract <- new_class( + "S4regAbstract", + parent = getClass("S4regAbstractParent"), + abstract = TRUE, + package = NULL + ) + S4regAbstractConcrete <- new_class( + "S4regAbstractConcrete", + parent = S4regAbstract, + properties = list(x = class_integer), + package = NULL + ) + method(dim, S4regAbstractConcrete) <- function(x) { + c(methods::slot(x, "x"), 2L) + } + S4regAbstractConcrete_S4 <- S4_register_contains(S4regAbstractConcrete) + setClass("S4regAbstractShim", contains = S4regAbstractConcrete_S4) + + object <- methods::new("S4regAbstractShim", x = 1L) + concrete_prototype <- methods::getClass("S4regAbstractConcrete")@prototype + + expect_true(methods::isVirtualClass("S4regAbstract")) + expect_false(methods::extends("S4regAbstract", "oldClass")) + expect_false(methods::extends("S4regAbstract", "S7_object")) + expect_false("S4regAbstract" %in% attr(concrete_prototype, ".S3Class")) + expect_equal(dim(object), c(1L, 2L)) + expect_true(methods::validObject(object)) +}) + test_that("S4_register_contains uses S7 property defaults as S4 shim prototypes", { on.exit(S4_remove_classes(c( "S4regPrototype", From 8099cda70a3a159d3ba53273e09d3964e1d5f80a Mon Sep 17 00:00:00 2001 From: Michael Lawrence Date: Thu, 4 Jun 2026 04:40:28 -0700 Subject: [PATCH 056/132] old classes were missing S7_class as a declared slot, which can cause it to get stripped during S4 upcasting, breaking the S7 object --- R/S4.R | 10 ++++++++-- tests/testthat/test-S4.R | 29 +++++++++++++++++++++-------- 2 files changed, 29 insertions(+), 10 deletions(-) diff --git a/R/S4.R b/R/S4.R index 2103b6f2f..036ceed32 100644 --- a/R/S4.R +++ b/R/S4.R @@ -463,16 +463,22 @@ S4_register_prototype_class <- function(class, env = parent.frame()) { parent_class <- class@parent parent_class_name <- S4_class(parent_class, where) + parent_slot_names <- S4_slot_names(parent_class_name, where) properties <- class@properties properties <- properties[setdiff( names(properties), - S4_slot_names(parent_class_name, where) + parent_slot_names )] + slots <- lapply(properties, S4_property_class, S4_env = where) + if (!"S7_class" %in% parent_slot_names) { + slots$S7_class <- "S7_class" + } methods::setClass( Class = classes[1L], - slots = lapply(properties, S4_property_class, S4_env = where), + slots = slots, contains = c(parent_class_name, "VIRTUAL"), + prototype = S4_properties_prototype(properties, class, where, TRUE), where = where ) diff --git a/tests/testthat/test-S4.R b/tests/testthat/test-S4.R index 9531e3394..0dd091517 100644 --- a/tests/testthat/test-S4.R +++ b/tests/testthat/test-S4.R @@ -26,7 +26,7 @@ test_that("S4_register registers S4 old classes as virtual S7_object descendants "trying to generate an object from a virtual class" ) expect_true(methods::extends("S4regS7New", "S7_object")) - expect_false("S7_class" %in% methods::slotNames("S4regS7New")) + expect_true("S7_class" %in% methods::slotNames("S4regS7New")) }) test_that("S4_register registers an S3 class so it can be used with S4 methods", { @@ -209,11 +209,11 @@ test_that("S4_register_contains constructs S4 subclasses of S7 classes that exte S4regNewChild_S4 <- S4_register_contains(S4regNewChild) expect_equal( methods::slotNames("S4regNewChild"), - c("status", "metadata", "assays", "rowData", ".S3Class") + c("status", "metadata", "S7_class", "assays", "rowData", ".S3Class") ) expect_contains( methods::slotNames(S4regNewChild_S4), - c("status", "metadata", "S7_class") + c("assays", "rowData", "metadata", "status", "S7_class") ) setClass( "S4regNewGrandChild", @@ -232,6 +232,13 @@ test_that("S4_register_contains constructs S4 subclasses of S7 classes that exte expect_equal(methods::slot(object, "rowData"), character()) expect_equal(methods::slot(object, "metadata"), character()) expect_equal(methods::slot(object, "status"), character()) + object_shim <- methods::as(object, S4regNewChild_S4) + object_old <- methods::as(object_shim, "S4regNewChild") + expect_equal(methods::slot(object_old, "metadata"), character()) + expect_equal(methods::slot(object_old, "status"), character()) + object_old <- methods::as(object, "S4regNewChild") + expect_equal(methods::slot(object_old, "metadata"), character()) + expect_equal(methods::slot(object_old, "status"), character()) expect_equal( prop_names(object), c("assays", "rowData", "metadata", "status") @@ -242,6 +249,15 @@ test_that("S4_register_contains constructs S4 subclasses of S7 classes that exte expect_equal(prop(object, "status"), character()) expect_true(methods::validObject(object)) + object <- methods::new( + "S4regNewGrandChild", + metadata = "m", + status = "s" + ) + expect_equal(methods::slot(object, "metadata"), "m") + expect_equal(methods::slot(object, "status"), "s") + expect_true(methods::validObject(object)) + invalid <- object methods::slot(invalid, "metadata") <- "bad" expect_error(methods::validObject(invalid), "bad metadata") @@ -249,10 +265,6 @@ test_that("S4_register_contains constructs S4 subclasses of S7 classes that exte invalid <- object methods::slot(invalid, "status") <- "bad" expect_error(methods::validObject(invalid), "bad status") - - object_old <- methods::as(object, "S4regNewChild") - expect_equal(methods::slot(object_old, "metadata"), character()) - expect_equal(methods::slot(object_old, "status"), character()) }) test_that("S4_register registers abstract S7 classes as virtual S4 classes", { @@ -581,7 +593,8 @@ test_that("S7 classes can extend S4 classes", { expect_true(methods::is(child, "Parent")) expect_true(methods::validObject(child)) - expect_equal(methods::slotNames("Child"), c("y", "x", ".S3Class")) + expect_equal(as.character(methods::getClass("Child")@className), "Child") + expect_equal(methods::slotNames("Child"), c("y", "S7_class", "x", ".S3Class")) expect_equal(methods::slot(child, "x"), 2) expect_equal(methods::slot(child, "y"), "b") From 8cffa5272f202167b59edd9597ee9d5009e27278 Mon Sep 17 00:00:00 2001 From: Michael Lawrence Date: Fri, 5 Jun 2026 00:53:01 -0700 Subject: [PATCH 057/132] shorten the S4 registration helper name --- R/method-register-S3.R | 2 +- R/method-register-S4.R | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/R/method-register-S3.R b/R/method-register-S3.R index 69e88f81f..2c9f0a5c3 100644 --- a/R/method-register-S3.R +++ b/R/method-register-S3.R @@ -30,7 +30,7 @@ register_S3_method <- function( registerS3method(generic$name, class, method, envir) } - if (should_register_S4_method_for_internal_generic(generic, signature)) { + if (should_register_S4_method(generic, signature)) { register_S4_method(generic$name, signature, method, envir, call = call) } } diff --git a/R/method-register-S4.R b/R/method-register-S4.R index 343c8204c..717dcebb4 100644 --- a/R/method-register-S4.R +++ b/R/method-register-S4.R @@ -10,7 +10,7 @@ register_S4_method <- function( methods::setMethod(generic, S4_signature, method, where = S4_env) } -should_register_S4_method_for_internal_generic <- function(generic, signature) { +should_register_S4_method <- function(generic, signature) { is_internal_generic(generic$name) && signature_has_S4_ancestor(signature) } From bdb309d9fddbb8ed570426fef07fd2d2d87487a1 Mon Sep 17 00:00:00 2001 From: Michael Lawrence Date: Fri, 5 Jun 2026 05:17:15 -0700 Subject: [PATCH 058/132] allow multi-argument signature on internal generics via S4 generic definition --- R/method-register-S4.R | 13 +++++++ R/method-register.R | 14 +++++++- tests/testthat/test-method-register-S3.R | 43 ++++++++++++++++++++++++ 3 files changed, 69 insertions(+), 1 deletion(-) diff --git a/R/method-register-S4.R b/R/method-register-S4.R index 717dcebb4..89dd0f033 100644 --- a/R/method-register-S4.R +++ b/R/method-register-S4.R @@ -26,3 +26,16 @@ class_has_S4_ancestor <- function(class) { FALSE ) } + +S3_generic_S4_signature <- function(generic) { + if (!is_S3_generic(generic) || !is_internal_generic(generic$name)) { + return(NULL) + } + + generic <- methods::getGeneric(generic$name) + if (is.null(generic) || !is_S4_generic(generic)) { + return(NULL) + } + + generic@signature +} diff --git a/R/method-register.R b/R/method-register.R index 2afd6ea36..328c7ac83 100644 --- a/R/method-register.R +++ b/R/method-register.R @@ -231,10 +231,18 @@ as_signature <- function(signature, generic, call = sys.call(-1L)) { } n <- generic_n_dispatch(generic) + + if (is_multi_arg_signature(signature)) { + S4_signature <- S3_generic_S4_signature(generic) + if (length(signature) == length(S4_signature)) { + n <- length(S4_signature) + } + } + if (n == 1) { # Accept a bare list of length 1 too, for symmetry with multi-dispatch # generics where a list is required (#555). - if (is.list(signature) && !is.object(signature) && length(signature) == 1) { + if (is_multi_arg_signature(signature) && length(signature) == 1) { signature <- signature[[1]] } new_signature(list(as_class(signature, arg = "signature"))) @@ -250,6 +258,10 @@ as_signature <- function(signature, generic, call = sys.call(-1L)) { } } +is_multi_arg_signature <- function(signature) { + is.list(signature) && !is.object(signature) +} + check_signature_list <- function( x, n, diff --git a/tests/testthat/test-method-register-S3.R b/tests/testthat/test-method-register-S3.R index 24ec49b3d..61672c0b1 100644 --- a/tests/testthat/test-method-register-S3.R +++ b/tests/testthat/test-method-register-S3.R @@ -87,6 +87,49 @@ test_that("internal generics register S4 methods for S4-backed S7 classes", { expect_equal(dim(object), c(1L, 2L)) }) +test_that("internal replacement generics can register full S4 signatures", { + on.exit({ + try( + methods::removeMethod( + "dimnames<-", + c("S4regDimnamesChild", "list") + ), + silent = TRUE + ) + S4_remove_classes(c( + "S4regDimnamesParent", + "S4regDimnamesChild", + "S4regDimnamesChild::S4Slots", + "S4regDimnamesShim" + )) + }) + + setClass("S4regDimnamesParent", contains = "VIRTUAL") + S4regDimnamesChild <- new_class( + "S4regDimnamesChild", + parent = getClass("S4regDimnamesParent"), + properties = list(x = class_list), + package = NULL + ) + method(`dimnames<-`, list(S4regDimnamesChild, class_list)) <- + function(x, value) { + x@x <- value + x + } + S4regDimnamesChild_S4 <- S4_register_contains(S4regDimnamesChild) + setClass("S4regDimnamesShim", contains = S4regDimnamesChild_S4) + + object <- methods::new("S4regDimnamesShim", x = list(NULL, NULL)) + value <- list("r", "c") + dimnames(object) <- value + + expect_equal(methods::slot(object, "x"), value) + expect_true(methods::hasMethod( + "dimnames<-", + c("S4regDimnamesChild", "list") + )) +}) + test_that("S3 registration for a multi-class S3 class uses only the first class", { local_s3_generic("s3_gen") method(s3_gen, new_S3_class(c("ordered", "factor"))) <- function(x) "ord" From aa7c92fe8db8ac69894087a20555bb6c322b050f Mon Sep 17 00:00:00 2001 From: Michael Lawrence Date: Fri, 5 Jun 2026 11:56:16 -0700 Subject: [PATCH 059/132] S4_initialize sets slots that aren't properties using slot<-, not prop<- --- R/S4.R | 9 +++++++++ tests/testthat/test-S4.R | 32 ++++++++++++++++++++++++++++++++ 2 files changed, 41 insertions(+) diff --git a/R/S4.R b/R/S4.R index 036ceed32..24168ffb9 100644 --- a/R/S4.R +++ b/R/S4.R @@ -421,6 +421,12 @@ S4_initialize <- function(.Object, ...) { vals <- modify_list(vals, arg_vals) } named_args <- args[nms != ""] + s4_vals <- list() + if (isS4(.Object)) { + s4_slot_nms <- setdiff(methods::slotNames(.Object), prop_nms) + s4_vals <- named_args[names(named_args) %in% s4_slot_nms] + named_args <- named_args[!names(named_args) %in% s4_slot_nms] + } vals <- modify_list(vals, named_args) if (".Data" %in% names(named_args)) { data_part <- vals$.Data @@ -431,6 +437,9 @@ S4_initialize <- function(.Object, ...) { } props(.Object) <- vals + for (name in names(s4_vals)) { + methods::slot(.Object, name) <- s4_vals[[name]] + } .Object } diff --git a/tests/testthat/test-S4.R b/tests/testthat/test-S4.R index 0dd091517..89fc83736 100644 --- a/tests/testthat/test-S4.R +++ b/tests/testthat/test-S4.R @@ -621,6 +621,38 @@ test_that("S7 classes can extend S4 classes", { expect_error(Child(x = "x", y = "a")) }) +test_that("S4 initialization sets S4 slots on subclasses of S7 classes", { + on.exit(S4_remove_classes(c("ParentForSlots", "ChildForSlots", "S4ChildForSlots"))) + setClass("ParentForSlots", slots = list(x = "numeric")) + + ChildForSlots <- new_class( + "ChildForSlots", + parent = getClass("ParentForSlots"), + properties = list(y = class_character), + package = NULL + ) + + setClass( + "S4ChildForSlots", + slots = list(z = "character"), + contains = "ChildForSlots" + ) + + parent <- ChildForSlots(x = 1, y = "a") + child <- methods::new("S4ChildForSlots", parent, z = "b") + + expect_true(isS4(child)) + expect_true(S7_inherits(child, ChildForSlots)) + expect_equal(prop(child, "x"), 1) + expect_equal(prop(child, "y"), "a") + expect_equal(methods::slot(child, "z"), "b") + + child@z <- "c" + child@y <- "d" + expect_equal(methods::slot(child, "z"), "c") + expect_equal(prop(child, "y"), "d") +}) + test_that("S4 initialize supports S3 data parts", { on.exit(S4_remove_classes(c("ParentNum", "ChildNum"))) setClass("ParentNum", contains = "numeric", slots = list(y = "character")) From 2d08506470a7bdc82a9a6815cb1213677f75ad83 Mon Sep 17 00:00:00 2001 From: Michael Lawrence Date: Fri, 5 Jun 2026 14:17:00 -0700 Subject: [PATCH 060/132] @<- supports setting slots on S4 objects --- R/property.R | 10 +++++++++- tests/testthat/test-S4.R | 25 +++++++++++++++++++++++++ 2 files changed, 34 insertions(+), 1 deletion(-) diff --git a/R/property.R b/R/property.R index dc3d62baf..181ea69ec 100644 --- a/R/property.R +++ b/R/property.R @@ -364,7 +364,15 @@ prop_call <- function(object, name) { `@.S7_object` <- prop #' @rawNamespace S3method("@<-",S7_object) -`@<-.S7_object` <- `prop<-` +`@<-.S7_object` <- function(object, name, value) { + if (isS4(object) && !name %in% names(slot(object, "S7_class")@properties)) { + methods::slot(object, name) <- value + return(object) + } + + prop(object, name) <- value + object +} #' Property introspection diff --git a/tests/testthat/test-S4.R b/tests/testthat/test-S4.R index 89fc83736..c96272a7a 100644 --- a/tests/testthat/test-S4.R +++ b/tests/testthat/test-S4.R @@ -653,6 +653,31 @@ test_that("S4 initialization sets S4 slots on subclasses of S7 classes", { expect_equal(prop(child, "y"), "d") }) +test_that("@<- sets S4-only slots on subclasses of S7 classes", { + on.exit(S4_remove_classes(c("ParentForAt", "ChildForAt", "S4ChildForAt"))) + setClass("ParentForAt", slots = list(x = "numeric")) + + ChildForAt <- new_class( + "ChildForAt", + parent = getClass("ParentForAt"), + properties = list(y = class_character), + package = NULL + ) + + setClass( + "S4ChildForAt", + slots = list(z = "character"), + contains = "ChildForAt" + ) + + child <- methods::new("S4ChildForAt", ChildForAt(x = 1, y = "a"), z = "b") + child@z <- "c" + child@y <- "d" + + expect_equal(methods::slot(child, "z"), "c") + expect_equal(prop(child, "y"), "d") +}) + test_that("S4 initialize supports S3 data parts", { on.exit(S4_remove_classes(c("ParentNum", "ChildNum"))) setClass("ParentNum", contains = "numeric", slots = list(y = "character")) From 333cdf5ac240b4b8252a5fad6839f7ba0fd7bcad Mon Sep 17 00:00:00 2001 From: Michael Lawrence Date: Sat, 6 Jun 2026 23:31:58 -0700 Subject: [PATCH 061/132] S4_validate_shim() does not try to validate objects from a "cousin" S7 class --- R/S4.R | 19 ++++++++++++++++- tests/testthat/test-S4.R | 44 ++++++++++++++++++++++++++++++++++++++++ 2 files changed, 62 insertions(+), 1 deletion(-) diff --git a/R/S4.R b/R/S4.R index 24168ffb9..e7d4ceef8 100644 --- a/R/S4.R +++ b/R/S4.R @@ -382,7 +382,24 @@ S4_validate_old_class <- function(object) { } S4_validate_shim <- function(object) { - S4_validate(object) + shim_class <- sub("::S4Slots$", "", class(object)[1L]) + class <- S7_class(object) + + if (identical(S7_class_name(class), shim_class)) { + return(S4_validate(object)) + } + while (is_class(class@parent)) { + class <- class@parent + if (identical(S7_class_name(class), shim_class)) { + return(TRUE) + } + } + + sprintf( + "object with S7 class %s does not match S4 shim class %s", + dQuote(S7_class_name(S7_class(object))), + dQuote(paste0(shim_class, "::S4Slots")) + ) } S4_validate <- function(object) { diff --git a/tests/testthat/test-S4.R b/tests/testthat/test-S4.R index c96272a7a..250dbac98 100644 --- a/tests/testthat/test-S4.R +++ b/tests/testthat/test-S4.R @@ -267,6 +267,50 @@ test_that("S4_register_contains constructs S4 subclasses of S7 classes that exte expect_error(methods::validObject(invalid), "bad status") }) +test_that("S4_validate_shim validates only matching S7 classes for S4 shim upcasts", { + on.exit(S4_remove_classes(c( + "S4regShimRoot", + "S4regShimParent", + "S4regShimChild", + "S4regShimGrandChild", + "S7::S4regShimParent", + "S7::S4regShimChild", + "S7::S4regShimParent::S4Slots", + "S7::S4regShimChild::S4Slots" + ))) + + setClass("S4regShimRoot", slots = list(root = "numeric")) + S4regShimParent <- new_class( + "S4regShimParent", + parent = getClass("S4regShimRoot"), + properties = list(x = class_numeric), + package = "S7" + ) + S4regShimChild <- new_class( + "S4regShimChild", + parent = S4regShimParent, + properties = list(y = class_character), + package = "S7" + ) + + S4regShimParent_S4 <- S4_register_contains(S4regShimParent) + S4regShimChild_S4 <- S4_register_contains(S4regShimChild) + setClass("S4regShimParent", contains = S4regShimParent_S4) + setClass("S4regShimChild", contains = S4regShimChild_S4) + setIs("S4regShimChild", "S4regShimParent") + expect_warning( + setClass("S4regShimGrandChild", contains = "S4regShimChild"), + "inconsistent superclass structure" + ) + + object <- methods::new("S4regShimGrandChild", root = 1, x = 2, y = "a") + parent_shim <- methods::as(object, S4regShimParent_S4) + + expect_false("y" %in% methods::slotNames(parent_shim)) + expect_equal(S7_class(parent_shim), S4regShimChild) + expect_true(methods::validObject(object)) +}) + test_that("S4_register registers abstract S7 classes as virtual S4 classes", { on.exit({ try(methods::removeMethod("dim", "S4regAbstractConcrete"), silent = TRUE) From 89f896107cfd88dac77ec6334ba740485fb34b0c Mon Sep 17 00:00:00 2001 From: Michael Lawrence Date: Sun, 7 Jun 2026 02:11:32 -0700 Subject: [PATCH 062/132] adapt validObject() call to S7 validate contract --- R/class-spec.R | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/R/class-spec.R b/R/class-spec.R index 847a69794..fcadf9ce4 100644 --- a/R/class-spec.R +++ b/R/class-spec.R @@ -201,7 +201,8 @@ class_constructor <- function(.x) { class_validate <- function(class, object) { if (is_S4_class(class)) { if (isS4(object) || methods::isClass(class(object)[[1]])) { - methods::validObject(object) + check <- methods::validObject(object, test = TRUE) + return(if (isTRUE(check)) NULL else check) } return(NULL) } From ea28c48e118d1c67ceb8dfcd1502d54b861058e7 Mon Sep 17 00:00:00 2001 From: Michael Lawrence Date: Sun, 7 Jun 2026 03:48:32 -0700 Subject: [PATCH 063/132] eliminate S7_object::S4Slots from hierarchy to simplify inheritance; in principle, there should only be one ::S4Slots shim for each S4 derivative of an S7 class --- R/S4.R | 9 ++++++--- R/zzz.R | 7 ------- tests/testthat/test-S4.R | 11 +++++------ 3 files changed, 11 insertions(+), 16 deletions(-) diff --git a/R/S4.R b/R/S4.R index e7d4ceef8..c4b5b1b40 100644 --- a/R/S4.R +++ b/R/S4.R @@ -175,7 +175,7 @@ S4_ancestor <- function(class) { } S7_extends_S4 <- function(class) { - length(S4_subclasses(class)) > 0L + !is.null(S4_ancestor(class)) } inherits_S4 <- function(x) { @@ -243,8 +243,11 @@ S4_register_with_props <- function(class, env) { )] methods::setClass( Class = class_name, - slots = lapply(properties, S4_property_class, S4_env = where), - contains = c(contains, "S7_object::S4Slots"), + slots = c( + lapply(properties, S4_property_class, S4_env = where), + S7_class = "S7_class" + ), + contains = c(contains), prototype = S4_properties_prototype(properties, class, where, TRUE), where = where ) diff --git a/R/zzz.R b/R/zzz.R index 4dcf224b4..a97948093 100644 --- a/R/zzz.R +++ b/R/zzz.R @@ -23,13 +23,6 @@ S7_object <- new_class( ) methods::setOldClass("S7_object") methods::setOldClass(c("S7_class", "S7_object")) -methods::setClass( - "S7_object::S4Slots", - slots = list(S7_class = "S7_class"), - contains = "S7_object", - prototype = methods::prototype(S7_class = S7_object), - where = topenv() -) .S7_type <- NULL # Defined onLoad because it depends on R version diff --git a/tests/testthat/test-S4.R b/tests/testthat/test-S4.R index 250dbac98..fd165d00f 100644 --- a/tests/testthat/test-S4.R +++ b/tests/testthat/test-S4.R @@ -100,7 +100,7 @@ test_that("S4_register_contains registers S7 properties as slots for S4 subclass expect_equal(S4regContainsChild_S4, "S7::S4regContainsChild::S4Slots") expect_equal( methods::slotNames(S4regContainsChild_S4), - c("x", "y", ".S3Class", "S7_class") + c("x", "y", "S7_class", ".S3Class") ) expect_contains( methods::extends(S4regContainsChild_S4), @@ -296,12 +296,11 @@ test_that("S4_validate_shim validates only matching S7 classes for S4 shim upcas S4regShimParent_S4 <- S4_register_contains(S4regShimParent) S4regShimChild_S4 <- S4_register_contains(S4regShimChild) setClass("S4regShimParent", contains = S4regShimParent_S4) - setClass("S4regShimChild", contains = S4regShimChild_S4) - setIs("S4regShimChild", "S4regShimParent") - expect_warning( - setClass("S4regShimGrandChild", contains = "S4regShimChild"), - "inconsistent superclass structure" + setClass( + "S4regShimChild", + contains = c(S4regShimChild_S4, "S4regShimParent") ) + setClass("S4regShimGrandChild", contains = "S4regShimChild") object <- methods::new("S4regShimGrandChild", root = 1, x = 2, y = "a") parent_shim <- methods::as(object, S4regShimParent_S4) From 553e3685278baa7bbf7c242908184ed78ce6b15e Mon Sep 17 00:00:00 2001 From: Michael Lawrence Date: Sun, 7 Jun 2026 14:39:36 -0700 Subject: [PATCH 064/132] doc updates --- R/S4.R | 7 +- R/class.R | 3 +- man/S4_register.Rd | 49 +++++++++++++- man/new_class.Rd | 127 +++++++++++++++++------------------ man/rmd/S4-compatibility.Rmd | 112 +++++++++++++++--------------- man/rmd/S4-registration.Rmd | 42 ++++++++++++ 6 files changed, 212 insertions(+), 128 deletions(-) create mode 100644 man/rmd/S4-registration.Rmd diff --git a/R/S4.R b/R/S4.R index c4b5b1b40..d522d2061 100644 --- a/R/S4.R +++ b/R/S4.R @@ -4,9 +4,10 @@ #' an S7 class that does not extend an S4 class, or an S3 class created by #' [new_S3_class()], you need to call `S4_register()` once. Classes created by #' [new_class()] with an S4 parent are registered automatically. -#' Use `S4_register_contains()` when you want an S4 class to extend an S7 class -#' with `contains=`. This registers the S7 class as an old class with known -#' attributes so that S7 properties are represented as S4 slots. +#' +#' @section Details: +#' ```{r child = "man/rmd/S4-registration.Rmd"} +#' ``` #' #' @param class An S7 class created with [new_class()], or, for #' `S4_register()` only, an S3 class created with [new_S3_class()] or an S7 diff --git a/R/class.R b/R/class.R index ce17d4ac4..20a518ddb 100644 --- a/R/class.R +++ b/R/class.R @@ -14,9 +14,10 @@ #' with this name, i.e. `Foo <- new_class("Foo")`. This object both represents #' the class and is used to construct new instances of the class. #' @param parent The parent class to inherit behavior from. -#' There are three options: +#' There are four options: #' #' * An S7 class, like [S7_object]. +#' * An S4 class, like the result of [methods::getClass()]. #' * An S3 class wrapped by [new_S3_class()]. #' * A base type, like [class_logical], [class_integer], etc. #' @param package Package name. This is automatically resolved if the class is diff --git a/man/S4_register.Rd b/man/S4_register.Rd index 7c12582b6..8ed7b3197 100644 --- a/man/S4_register.Rd +++ b/man/S4_register.Rd @@ -25,10 +25,53 @@ If you want to use \link{method<-} to register a method for an S4 generic with an S7 class that does not extend an S4 class, or an S3 class created by \code{\link[=new_S3_class]{new_S3_class()}}, you need to call \code{S4_register()} once. Classes created by \code{\link[=new_class]{new_class()}} with an S4 parent are registered automatically. -Use \code{S4_register_contains()} when you want an S4 class to extend an S7 class -with \verb{contains=}. This registers the S7 class as an old class with known -attributes so that S7 properties are represented as S4 slots. } +\section{Details}{ + +\code{S4_register()} registers an S7 class, S3 class, or S7 union with S4 so it can +be used in S4 method signatures. It is called automatically for concrete S7 +classes that extend S4 classes. For other S7 classes, call it when S4 code +needs to dispatch on the class or use it in a slot. + +\code{S4_register()} invisibly returns the registered S4 class name. For an S7 class +this is the S4 old-class name used for dispatch. For an S7 union this is the +S4 class union name. + +\code{S4_register_contains()} is for the opposite direction: use it when an S4 class +needs to extend an S7 class with \code{methods::setClass(contains = )}. It registers +the S7 class if needed, then creates and returns an S4 shim class whose name +ends in \verb{::S4Slots}. The shim: +\itemize{ +\item contains the S7 old class, so inherited S7 and S4 dispatch can still find the +S7 class; +\item exposes stored S7 properties as formal S4 slots (as does the old class); +\item includes an \code{S7_class} slot so S7 can recover the class object from real S4 +instances; and +\item installs S4 validity methods that recursively call S7 validation. +} + +Do not instantiate the \verb{::S4Slots} shim directly. It exists so another S4 class +can contain it: + +\if{html}{\out{
}}\preformatted{Foo <- new_class("Foo", properties = list(x = class_numeric)) +Foo_S4 <- S4_register_contains(Foo) +methods::setClass("S4Foo", contains = Foo_S4) +}\if{html}{\out{
}} + +S4 subclasses created this way are real S4 objects. Their S7 properties are +also S4 slots, so S4 initialization and S4 slot access can set them. This is +necessary for S4 compatibility, but it means S4 code can bypass custom S7 +property behavior. Because of that, \code{S4_register_contains()} rejects properties +with custom getters or setters. + +Property defaults become the S4 prototype values for the shim. + +S7 unions can be registered with \code{S4_register()}. S7's \code{class_union} maps to +S4's \code{"numeric"} class. For other unions, S7 uses an existing matching S4 class +union if one is already registered; otherwise the union must be explicitly +registered before it can be used as an S4 slot or method signature. +} + \examples{ methods::setGeneric("S4_generic", function(x) { standardGeneric("S4_generic") diff --git a/man/new_class.Rd b/man/new_class.Rd index 81a048cb2..48fda15f5 100644 --- a/man/new_class.Rd +++ b/man/new_class.Rd @@ -15,21 +15,21 @@ new_class( validator = NULL ) -new_object(`_parent`, ...) +new_object(.parent, ...) } \arguments{ \item{name}{The name of the class, as a string. (We recommend using CamelCase for S7 class names, but it is not required.) The result of calling \code{new_class()} should always be assigned to a variable -with this name, i.e. \code{Foo <- new_class("Foo", ...)} or -\code{Foo := new_class(...)}. This object both represents the class and is used -to construct new instances of the class.} +with this name, i.e. \code{Foo <- new_class("Foo")}. This object both represents +the class and is used to construct new instances of the class.} \item{parent}{The parent class to inherit behavior from. -There are three options: +There are four options: \itemize{ \item An S7 class, like \link{S7_object}. +\item An S4 class, like the result of \code{\link[methods:getClass]{methods::getClass()}}. \item An S3 class wrapped by \code{\link[=new_S3_class]{new_S3_class()}}. \item A base type, like \link{class_logical}, \link{class_integer}, etc. }} @@ -74,12 +74,8 @@ problem, using \verb{@prop_name} to describe where the problem lies. See \code{validate()} for more details, examples, and how to temporarily suppress validation when needed.} -\item{_parent, ...}{Parent object and named properties used to construct the -object. - -As a convenience, if \code{...} is a single unnamed list, then the elements of -that list are used as the properties. This makes it easy to -programmatically construct an object from a list of property values.} +\item{.parent, ...}{Parent object and named properties used to construct the +object.} } \value{ A object constructor, a function that can be used to create objects @@ -94,74 +90,75 @@ Learn more in \code{vignette("classes-objects")} } \section{S4 compatibility}{ -When an S7 class extends an S4 class, \code{new_class()} automatically registers the -new class with S4. After that, an S4 generic with a method for \code{Parent} will -dispatch on a \code{Child} instance: +\code{new_class()} can use an S4 class as its parent. The S4 class can be supplied +as a class definition, such as \code{methods::getClass("Parent")}, or as a class +generator returned by \code{methods::setClass()}. The S4 parent slots become S7 +properties on the new S7 class. -\if{html}{\out{
}}\preformatted{setMethod("g", "Parent", function(x) ...) -g(child) # uses Parent method if no more specific Child method exists -}\if{html}{\out{
}} +When an S7 class extends an S4 class, \code{new_class()} automatically registers an +S4 old class for the S7 class. This lets S4 generics dispatch through the S4 +parent: -But the method receives the original S7 object, not a formal S4 instance, so -this approach is a compatibility bridge, not full substitutability. +\if{html}{\out{
}}\preformatted{methods::setClass("Parent", slots = list(x = "numeric")) +Child <- new_class("Child", methods::getClass("Parent"), + properties = list(y = class_character) +) + +methods::is(Child(x = 1, y = "a"), "Parent") +}\if{html}{\out{
}} Things that work reasonably: \itemize{ +\item S4 dispatch inherits through the S4 parent. An S4 generic with a method for +\code{Parent} can dispatch on a \code{Child} object. \item \code{methods::is(child, "Parent")} returns \code{TRUE}. -\item S4 dispatch inherits through \code{Parent}. -\item \code{methods::validObject(child)} can validate known S7/S4 attributes. -\item \code{methods::slotNames(child)} works. -\item \code{methods::slot(child, "x")} works for registered slots and properties, as -long as they are represented by stored attributes. -\item \code{child@x} works through S7 property access. With the current oldClass -representation, the object is not S4-bit so \code{@} can dispatch to S7's -\verb{@.S7_object} method. If S7 objects that extend S4 classes are represented -as S4-bit objects in the future, R's \code{@} primitive will need to dispatch -before taking the S4 slot-access path. -\item \code{methods::initialize(child, ...)} works for reinitializing an existing S7 -object through S4 code. This is preferable to constructing a fresh object -with \code{methods::new(class(child)[[1L]], ...)}, because S4 construction creates -a formal S4 object with the oldClass structure but without the S7 metadata -that S7 property management requires. -\item \code{as(child, "Parent")} can produce a real S4 \code{Parent} object containing the -parent slots. +\item S4 parent slots are available as S7 properties, so \code{prop(child, "x")} and +\code{child@x} use the S7 property path. +\item \code{methods::slot(child, "x")} can read stored S4 parent slots and stored S7 +properties. Direct slot access bypasses custom S7 property behavior, so S4 +code should use it only for slots it owns. +\item \code{methods::validObject(child)} checks S4 slot types and recursively runs S7 +property validation and S7 class validators. +\item \code{methods::initialize(child, ...)} can reinitialize S7 objects from S4 code. +Unnamed S7, S4, and S3-data-part arguments contribute their known +properties or slots; later arguments override earlier arguments, and named +arguments override unnamed ones. +\item \code{methods::as(child, "Parent")} and \code{convert(child, to = Parent)} can produce +a real S4 object for the S4 parent class. } -Likely brittle or incompatible with S4-method assumptions: +Caveats: \itemize{ -\item \code{isS4(child)} is \code{FALSE} with the current oldClass representation. This -avoids advertising formal S4 object invariants that S7 objects do not -satisfy. S4 code is still exposed to S3-compatible, non-scalar \code{class()} -vectors through the oldClass bridge. -\item \code{class(child)} is length greater than 1, for example -\code{c("Child", "S4/Parent", "S7_object")}. This can break S4 code that treats -\code{class()} as a scalar class name. Code that needs a scalar primary class -name should use \code{class(x)[[1L]]}, or \code{methods::class1(x)} once that helper -has been made public. -\item Methods that access slots with \code{methods::slot()} and \verb{methods::slot<-()} -bypass the S7 property layer. This is mostly a problem when the S7 class -defines properties that override the slots from its parent. This is similar -to deriving from an S3 class whose methods use \code{attr()} and \verb{attr<-()} -directly. Overriding S4 slots is therefore discouraged. -\item Calls like \code{methods::new(class(x)[[1L]], ...)} or -\code{methods::new(class1(x), ...)} construct a new S4 object from S4's class -definition. For an S7 class registered with S4, the result can satisfy -\code{inherits(object, "S7_object")} through the S4 oldClass graph while still -lacking the \code{S7_class} attribute. Such objects are not S7 instances. Code -that is updating an existing object should prefer \code{methods::initialize(x, ...)}, which gives S7's S4 \code{initialize()} method a chance to preserve S7 -metadata and route values through properties. +\item An S7 object that directly extends S4 is currently represented as an S3 +old-class object, not as an S4-bit object, so \code{isS4(child)} is \code{FALSE}. +This avoids advertising full S4 object invariants that the object does not +satisfy. +\item The S3 class vector is not scalar. S4 code that needs one primary class name +should use \code{class(x)[1L]}, or \code{methods::class1(x)} if available. +\item \code{methods::new(class(x)[1L], ...)} creates a fresh S4 object from the S4 class +definition. For an S7 class registered with S4, that object can inherit from +\code{S7_object} through the old-class graph while lacking the \code{S7_class} slot or +attribute that makes it an S7 object. Code that updates an existing object +should prefer \code{methods::initialize(x, ...)}. +\item S4 methods that call \verb{methods::slot<-()} can bypass S7 property setters and +ordinary S7 validation. Call \code{methods::validObject()} after such updates when +the object should satisfy the S7 class contract. +\item Properties with custom getters or setters cannot be exposed as S4 slots. An +S7 class that extends S4, or that is intended to be extended by S4, must use +stored properties for the properties that need to cross the S4 boundary. +\item \code{NULL} properties are stored internally using the same sentinel that S4 uses +for \code{NULL} slots. \code{prop()}, \code{@}, and \code{methods::slot()} translate this back to +\code{NULL}; code that reads raw attributes should treat the representation as an +implementation detail. } -In summary, inherited S4 methods must be written against the "registered -oldClass with known attributes" contract, not the stricter "formal S4 -instance" contract. They should use a scalar primary-class helper where -appropriate and avoid \code{slot()} and \verb{slot<-()} when they need S7 property -management to apply. +S4 classes can also extend S7 classes with \code{S4_register_contains()}. See +\code{S4_register()} for details. } \examples{ # Create an class that represents a range using a numeric start and end -Range := new_class( +Range <- new_class("Range", properties = list( start = class_numeric, end = class_numeric @@ -179,7 +176,7 @@ try(Range(start = "hello", end = 20)) # But we might also want to use a validator to ensure that start and end # are length 1, and that start is < end -Range := new_class( +Range <- new_class("Range", properties = list( start = class_numeric, end = class_numeric diff --git a/man/rmd/S4-compatibility.Rmd b/man/rmd/S4-compatibility.Rmd index edbbfc35b..5eb84ae0e 100644 --- a/man/rmd/S4-compatibility.Rmd +++ b/man/rmd/S4-compatibility.Rmd @@ -1,63 +1,63 @@ -When an S7 class extends an S4 class, `new_class()` automatically registers the -new class with S4. After that, an S4 generic with a method for `Parent` will -dispatch on a `Child` instance: +`new_class()` can use an S4 class as its parent. The S4 class can be supplied +as a class definition, such as `methods::getClass("Parent")`, or as a class +generator returned by `methods::setClass()`. The S4 parent slots become S7 +properties on the new S7 class. + +When an S7 class extends an S4 class, `new_class()` automatically registers an +S4 old class for the S7 class. This lets S4 generics dispatch through the S4 +parent: ```r -setMethod("g", "Parent", function(x) ...) -g(child) # uses Parent method if no more specific Child method exists -``` +methods::setClass("Parent", slots = list(x = "numeric")) +Child <- new_class("Child", methods::getClass("Parent"), + properties = list(y = class_character) +) -But the method receives the original S7 object, not a formal S4 instance, so -this approach is a compatibility bridge, not full substitutability. +methods::is(Child(x = 1, y = "a"), "Parent") +``` Things that work reasonably: +* S4 dispatch inherits through the S4 parent. An S4 generic with a method for + `Parent` can dispatch on a `Child` object. * `methods::is(child, "Parent")` returns `TRUE`. -* S4 dispatch inherits through `Parent`. -* `methods::validObject(child)` can validate known S7/S4 attributes. -* `methods::slotNames(child)` works. -* `methods::slot(child, "x")` works for registered slots and properties, as - long as they are represented by stored attributes. -* `child@x` works through S7 property access. With the current oldClass - representation, the object is not S4-bit so `@` can dispatch to S7's - `@.S7_object` method. If S7 objects that extend S4 classes are represented - as S4-bit objects in the future, R's `@` primitive will need to dispatch - before taking the S4 slot-access path. -* `methods::initialize(child, ...)` works for reinitializing an existing S7 - object through S4 code. This is preferable to constructing a fresh object - with `methods::new(class(child)[[1L]], ...)`, because S4 construction creates - a formal S4 object with the oldClass structure but without the S7 metadata - that S7 property management requires. -* `as(child, "Parent")` can produce a real S4 `Parent` object containing the - parent slots. - -Likely brittle or incompatible with S4-method assumptions: - -* `isS4(child)` is `FALSE` with the current oldClass representation. This - avoids advertising formal S4 object invariants that S7 objects do not - satisfy. S4 code is still exposed to S3-compatible, non-scalar `class()` - vectors through the oldClass bridge. -* `class(child)` is length greater than 1, for example - `c("Child", "S4/Parent", "S7_object")`. This can break S4 code that treats - `class()` as a scalar class name. Code that needs a scalar primary class - name should use `class(x)[[1L]]`, or `methods::class1(x)` once that helper - has been made public. -* Methods that access slots with `methods::slot()` and `methods::slot<-()` - bypass the S7 property layer. This is mostly a problem when the S7 class - defines properties that override the slots from its parent. This is similar - to deriving from an S3 class whose methods use `attr()` and `attr<-()` - directly. Overriding S4 slots is therefore discouraged. -* Calls like `methods::new(class(x)[[1L]], ...)` or - `methods::new(class1(x), ...)` construct a new S4 object from S4's class - definition. For an S7 class registered with S4, the result can satisfy - `inherits(object, "S7_object")` through the S4 oldClass graph while still - lacking the `S7_class` attribute. Such objects are not S7 instances. Code - that is updating an existing object should prefer `methods::initialize(x, - ...)`, which gives S7's S4 `initialize()` method a chance to preserve S7 - metadata and route values through properties. - -In summary, inherited S4 methods must be written against the "registered -oldClass with known attributes" contract, not the stricter "formal S4 -instance" contract. They should use a scalar primary-class helper where -appropriate and avoid `slot()` and `slot<-()` when they need S7 property -management to apply. +* S4 parent slots are available as S7 properties, so `prop(child, "x")` and + `child@x` use the S7 property path. +* `methods::slot(child, "x")` can read stored S4 parent slots and stored S7 + properties. Direct slot access bypasses custom S7 property behavior, so S4 + code should use it only for slots it owns. +* `methods::validObject(child)` checks S4 slot types and recursively runs S7 + property validation and S7 class validators. +* `methods::initialize(child, ...)` can reinitialize S7 objects from S4 code. + Unnamed S7, S4, and S3-data-part arguments contribute their known + properties or slots; later arguments override earlier arguments, and named + arguments override unnamed ones. +* `methods::as(child, "Parent")` and `convert(child, to = Parent)` can produce + a real S4 object for the S4 parent class. + +Caveats: + +* An S7 object that directly extends S4 is currently represented as an S3 + old-class object, not as an S4-bit object, so `isS4(child)` is `FALSE`. + This avoids advertising full S4 object invariants that the object does not + satisfy. +* The S3 class vector is not scalar. S4 code that needs one primary class name + should use `class(x)[1L]`, or `methods::class1(x)` if available. +* `methods::new(class(x)[1L], ...)` creates a fresh S4 object from the S4 class + definition. For an S7 class registered with S4, that object can inherit from + `S7_object` through the old-class graph while lacking the `S7_class` slot or + attribute that makes it an S7 object. Code that updates an existing object + should prefer `methods::initialize(x, ...)`. +* S4 methods that call `methods::slot<-()` can bypass S7 property setters and + ordinary S7 validation. Call `methods::validObject()` after such updates when + the object should satisfy the S7 class contract. +* Properties with custom getters or setters cannot be exposed as S4 slots. An + S7 class that extends S4, or that is intended to be extended by S4, must use + stored properties for the properties that need to cross the S4 boundary. +* `NULL` properties are stored internally using the same sentinel that S4 uses + for `NULL` slots. `prop()`, `@`, and `methods::slot()` translate this back to + `NULL`; code that reads raw attributes should treat the representation as an + implementation detail. + +S4 classes can also extend S7 classes with `S4_register_contains()`. See +`S4_register()` for details. diff --git a/man/rmd/S4-registration.Rmd b/man/rmd/S4-registration.Rmd new file mode 100644 index 000000000..0160c1a1d --- /dev/null +++ b/man/rmd/S4-registration.Rmd @@ -0,0 +1,42 @@ +`S4_register()` registers an S7 class, S3 class, or S7 union with S4 so it can +be used in S4 method signatures. It is called automatically for concrete S7 +classes that extend S4 classes. For other S7 classes, call it when S4 code +needs to dispatch on the class or use it in a slot. + +`S4_register()` invisibly returns the registered S4 class name. For an S7 class +this is the S4 old-class name used for dispatch. For an S7 union this is the +S4 class union name. + +`S4_register_contains()` is for the opposite direction: use it when an S4 class +needs to extend an S7 class with `methods::setClass(contains = )`. It registers +the S7 class if needed, then creates and returns an S4 shim class whose name +ends in `::S4Slots`. The shim: + +* contains the S7 old class, so inherited S7 and S4 dispatch can still find the + S7 class; +* exposes stored S7 properties as formal S4 slots (as does the old class); +* includes an `S7_class` slot so S7 can recover the class object from real S4 + instances; and +* installs S4 validity methods that recursively call S7 validation. + +Do not instantiate the `::S4Slots` shim directly. It exists so another S4 class +can contain it: + +```r +Foo <- new_class("Foo", properties = list(x = class_numeric)) +Foo_S4 <- S4_register_contains(Foo) +methods::setClass("S4Foo", contains = Foo_S4) +``` + +S4 subclasses created this way are real S4 objects. Their S7 properties are +also S4 slots, so S4 initialization and S4 slot access can set them. This is +necessary for S4 compatibility, but it means S4 code can bypass custom S7 +property behavior. Because of that, `S4_register_contains()` rejects properties +with custom getters or setters. + +Property defaults become the S4 prototype values for the shim. + +S7 unions can be registered with `S4_register()`. S7's `class_union` maps to +S4's `"numeric"` class. For other unions, S7 uses an existing matching S4 class +union if one is already registered; otherwise the union must be explicitly +registered before it can be used as an S4 slot or method signature. From c53b00630b61e50af4d4b5c827ad15bc9914c588 Mon Sep 17 00:00:00 2001 From: Michael Lawrence Date: Fri, 19 Jun 2026 09:07:43 -0700 Subject: [PATCH 065/132] wording tweak Co-authored-by: Hadley Wickham --- man/rmd/S4-compatibility.Rmd | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/man/rmd/S4-compatibility.Rmd b/man/rmd/S4-compatibility.Rmd index 5eb84ae0e..40711cb41 100644 --- a/man/rmd/S4-compatibility.Rmd +++ b/man/rmd/S4-compatibility.Rmd @@ -16,7 +16,7 @@ Child <- new_class("Child", methods::getClass("Parent"), methods::is(Child(x = 1, y = "a"), "Parent") ``` -Things that work reasonably: +Things that work reasonably well: * S4 dispatch inherits through the S4 parent. An S4 generic with a method for `Parent` can dispatch on a `Child` object. From 4a58b0bae41d6d3af35fd47544cbbe8ca070ccff Mon Sep 17 00:00:00 2001 From: Michael Lawrence Date: Fri, 19 Jun 2026 09:12:45 -0700 Subject: [PATCH 066/132] Another wording tweak Co-authored-by: Hadley Wickham --- man/rmd/S4-registration.Rmd | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/man/rmd/S4-registration.Rmd b/man/rmd/S4-registration.Rmd index 0160c1a1d..0446b0cd9 100644 --- a/man/rmd/S4-registration.Rmd +++ b/man/rmd/S4-registration.Rmd @@ -7,8 +7,8 @@ needs to dispatch on the class or use it in a slot. this is the S4 old-class name used for dispatch. For an S7 union this is the S4 class union name. -`S4_register_contains()` is for the opposite direction: use it when an S4 class -needs to extend an S7 class with `methods::setClass(contains = )`. It registers +`S4_register_contains()` is for inheritance: use it when an S4 class +should be allowed to extend an S7 class with `methods::setClass(contains = )`. It registers the S7 class if needed, then creates and returns an S4 shim class whose name ends in `::S4Slots`. The shim: From 5aba67d093ac686937f039d8ee05ba7eaf08dc38 Mon Sep 17 00:00:00 2001 From: Michael Lawrence Date: Fri, 19 Jun 2026 09:20:43 -0700 Subject: [PATCH 067/132] rename is_multi_arg_signature to is_plain_list to clarify its (more general) purpose --- R/method-register.R | 8 ++------ R/utils.R | 3 +++ 2 files changed, 5 insertions(+), 6 deletions(-) diff --git a/R/method-register.R b/R/method-register.R index 328c7ac83..b0ebc5cc5 100644 --- a/R/method-register.R +++ b/R/method-register.R @@ -232,7 +232,7 @@ as_signature <- function(signature, generic, call = sys.call(-1L)) { n <- generic_n_dispatch(generic) - if (is_multi_arg_signature(signature)) { + if (is_plain_list(signature)) { S4_signature <- S3_generic_S4_signature(generic) if (length(signature) == length(S4_signature)) { n <- length(S4_signature) @@ -242,7 +242,7 @@ as_signature <- function(signature, generic, call = sys.call(-1L)) { if (n == 1) { # Accept a bare list of length 1 too, for symmetry with multi-dispatch # generics where a list is required (#555). - if (is_multi_arg_signature(signature) && length(signature) == 1) { + if (is_plain_list(signature) && length(signature) == 1) { signature <- signature[[1]] } new_signature(list(as_class(signature, arg = "signature"))) @@ -258,10 +258,6 @@ as_signature <- function(signature, generic, call = sys.call(-1L)) { } } -is_multi_arg_signature <- function(signature) { - is.list(signature) && !is.object(signature) -} - check_signature_list <- function( x, n, diff --git a/R/utils.R b/R/utils.R index 59f7e6488..5dbd0717c 100644 --- a/R/utils.R +++ b/R/utils.R @@ -227,6 +227,9 @@ deparse_trunc <- function(x, width, collapse = "\n") { x } +is_plain_list <- function(x) { + is.list(x) && !is.object(x) +} # For older versions of R ---------------------------------------------------- deparse1 <- function(expr, collapse = " ", width.cutoff = 500L, ...) { From 03ecd49afa7275d40e3df98d9f049422d01c3846 Mon Sep 17 00:00:00 2001 From: Michael Lawrence Date: Fri, 19 Jun 2026 09:25:35 -0700 Subject: [PATCH 068/132] clarify S4_register() by moving early returns earlier --- R/S4.R | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/R/S4.R b/R/S4.R index d522d2061..54f6a35ab 100644 --- a/R/S4.R +++ b/R/S4.R @@ -32,15 +32,15 @@ #' S4Foo_S4 <- S4_register_contains(S4Foo) #' methods::setClass("S4Child", contains = S4Foo_S4) S4_register <- function(class, env = parent.frame()) { - if (is_class(class)) { + if (is_union(class)) { + return(invisible(S4_register_union(class, topenv(env)))) + } else if (is_class(class)) { if (class@abstract) { return(invisible(S4_register_abstract_class(class, topenv(env)))) } classes <- class_dispatch(class) } else if (is_S3_class(class)) { classes <- class$class - } else if (is_union(class)) { - return(invisible(S4_register_union(class, topenv(env)))) } else { msg <- sprintf( "`class` must be an S7 class, S3 class, or S7 union, not a %s.", From 61c4b084e4832862ceadf25902aabc9a29e8e02f Mon Sep 17 00:00:00 2001 From: Michael Lawrence Date: Fri, 19 Jun 2026 09:31:02 -0700 Subject: [PATCH 069/132] move S4 inheritance guidance to the compatbility vignette --- R/S4.R | 15 +++- R/class.R | 11 ++- man/S4_register.Rd | 49 +++---------- man/new_class.Rd | 69 ++---------------- man/rmd/S4-compatibility.Rmd | 63 ---------------- man/rmd/S4-registration.Rmd | 42 ----------- vignettes/compatibility.Rmd | 137 +++++++++++++++++++++++++++++++++-- 7 files changed, 170 insertions(+), 216 deletions(-) delete mode 100644 man/rmd/S4-compatibility.Rmd delete mode 100644 man/rmd/S4-registration.Rmd diff --git a/R/S4.R b/R/S4.R index 54f6a35ab..9422ddc6f 100644 --- a/R/S4.R +++ b/R/S4.R @@ -6,8 +6,19 @@ #' [new_class()] with an S4 parent are registered automatically. #' #' @section Details: -#' ```{r child = "man/rmd/S4-registration.Rmd"} -#' ``` +#' `S4_register()` registers an S7 class, S3 class, or S7 union with S4 and +#' invisibly returns the registered S4 class name. +#' +#' `S4_register_contains()` returns an S4 shim class name for use in +#' `methods::setClass(contains = )`, allowing S4 classes to extend an S7 class. +#' The shim exposes stored S7 properties as S4 slots and carries the `S7_class` +#' slot needed for S7 dispatch and validation. Do not instantiate it directly. +#' +#' Properties with custom getters or setters cannot be represented as S4 slots. +#' Register S7 unions with `S4_register()` before using them in S4 slots or +#' method signatures unless an equivalent S4 union already exists. +#' +#' See `vignette("compatibility")` for examples and caveats. #' #' @param class An S7 class created with [new_class()], or, for #' `S4_register()` only, an S3 class created with [new_S3_class()] or an S7 diff --git a/R/class.R b/R/class.R index 20a518ddb..5c84d9f8f 100644 --- a/R/class.R +++ b/R/class.R @@ -56,8 +56,15 @@ #' either be a type specification (processed by [as_class()]) or a #' full property specification created [new_property()]. #' @section S4 compatibility: -#' ```{r child = "man/rmd/S4-compatibility.Rmd"} -#' ``` +#' `new_class()` can use an S4 class definition or class generator as its +#' `parent`. S4 parent slots become S7 properties, the class is registered with +#' S4 automatically, and S4 generics can dispatch through the S4 parent. +#' +#' S7 objects that directly extend S4 are represented as S3 old-class objects, +#' so `isS4()` is `FALSE` even though [methods::is()] and S4 dispatch see the +#' S4 parent. S4 classes can extend S7 classes with [S4_register_contains()]. +#' +#' See `vignette("compatibility")` for examples and caveats. #' @return A object constructor, a function that can be used to create objects #' of the given class. #' @export diff --git a/man/S4_register.Rd b/man/S4_register.Rd index 8ed7b3197..f50775362 100644 --- a/man/S4_register.Rd +++ b/man/S4_register.Rd @@ -28,48 +28,19 @@ an S7 class that does not extend an S4 class, or an S3 class created by } \section{Details}{ -\code{S4_register()} registers an S7 class, S3 class, or S7 union with S4 so it can -be used in S4 method signatures. It is called automatically for concrete S7 -classes that extend S4 classes. For other S7 classes, call it when S4 code -needs to dispatch on the class or use it in a slot. +\code{S4_register()} registers an S7 class, S3 class, or S7 union with S4 and +invisibly returns the registered S4 class name. -\code{S4_register()} invisibly returns the registered S4 class name. For an S7 class -this is the S4 old-class name used for dispatch. For an S7 union this is the -S4 class union name. +\code{S4_register_contains()} returns an S4 shim class name for use in +\code{methods::setClass(contains = )}, allowing S4 classes to extend an S7 class. +The shim exposes stored S7 properties as S4 slots and carries the \code{S7_class} +slot needed for S7 dispatch and validation. Do not instantiate it directly. -\code{S4_register_contains()} is for the opposite direction: use it when an S4 class -needs to extend an S7 class with \code{methods::setClass(contains = )}. It registers -the S7 class if needed, then creates and returns an S4 shim class whose name -ends in \verb{::S4Slots}. The shim: -\itemize{ -\item contains the S7 old class, so inherited S7 and S4 dispatch can still find the -S7 class; -\item exposes stored S7 properties as formal S4 slots (as does the old class); -\item includes an \code{S7_class} slot so S7 can recover the class object from real S4 -instances; and -\item installs S4 validity methods that recursively call S7 validation. -} - -Do not instantiate the \verb{::S4Slots} shim directly. It exists so another S4 class -can contain it: - -\if{html}{\out{
}}\preformatted{Foo <- new_class("Foo", properties = list(x = class_numeric)) -Foo_S4 <- S4_register_contains(Foo) -methods::setClass("S4Foo", contains = Foo_S4) -}\if{html}{\out{
}} - -S4 subclasses created this way are real S4 objects. Their S7 properties are -also S4 slots, so S4 initialization and S4 slot access can set them. This is -necessary for S4 compatibility, but it means S4 code can bypass custom S7 -property behavior. Because of that, \code{S4_register_contains()} rejects properties -with custom getters or setters. - -Property defaults become the S4 prototype values for the shim. +Properties with custom getters or setters cannot be represented as S4 slots. +Register S7 unions with \code{S4_register()} before using them in S4 slots or +method signatures unless an equivalent S4 union already exists. -S7 unions can be registered with \code{S4_register()}. S7's \code{class_union} maps to -S4's \code{"numeric"} class. For other unions, S7 uses an existing matching S4 class -union if one is already registered; otherwise the union must be explicitly -registered before it can be used as an S4 slot or method signature. +See \code{vignette("compatibility")} for examples and caveats. } \examples{ diff --git a/man/new_class.Rd b/man/new_class.Rd index 48fda15f5..7c245bf8a 100644 --- a/man/new_class.Rd +++ b/man/new_class.Rd @@ -90,70 +90,15 @@ Learn more in \code{vignette("classes-objects")} } \section{S4 compatibility}{ -\code{new_class()} can use an S4 class as its parent. The S4 class can be supplied -as a class definition, such as \code{methods::getClass("Parent")}, or as a class -generator returned by \code{methods::setClass()}. The S4 parent slots become S7 -properties on the new S7 class. - -When an S7 class extends an S4 class, \code{new_class()} automatically registers an -S4 old class for the S7 class. This lets S4 generics dispatch through the S4 -parent: - -\if{html}{\out{
}}\preformatted{methods::setClass("Parent", slots = list(x = "numeric")) -Child <- new_class("Child", methods::getClass("Parent"), - properties = list(y = class_character) -) - -methods::is(Child(x = 1, y = "a"), "Parent") -}\if{html}{\out{
}} +\code{new_class()} can use an S4 class definition or class generator as its +\code{parent}. S4 parent slots become S7 properties, the class is registered with +S4 automatically, and S4 generics can dispatch through the S4 parent. -Things that work reasonably: -\itemize{ -\item S4 dispatch inherits through the S4 parent. An S4 generic with a method for -\code{Parent} can dispatch on a \code{Child} object. -\item \code{methods::is(child, "Parent")} returns \code{TRUE}. -\item S4 parent slots are available as S7 properties, so \code{prop(child, "x")} and -\code{child@x} use the S7 property path. -\item \code{methods::slot(child, "x")} can read stored S4 parent slots and stored S7 -properties. Direct slot access bypasses custom S7 property behavior, so S4 -code should use it only for slots it owns. -\item \code{methods::validObject(child)} checks S4 slot types and recursively runs S7 -property validation and S7 class validators. -\item \code{methods::initialize(child, ...)} can reinitialize S7 objects from S4 code. -Unnamed S7, S4, and S3-data-part arguments contribute their known -properties or slots; later arguments override earlier arguments, and named -arguments override unnamed ones. -\item \code{methods::as(child, "Parent")} and \code{convert(child, to = Parent)} can produce -a real S4 object for the S4 parent class. -} - -Caveats: -\itemize{ -\item An S7 object that directly extends S4 is currently represented as an S3 -old-class object, not as an S4-bit object, so \code{isS4(child)} is \code{FALSE}. -This avoids advertising full S4 object invariants that the object does not -satisfy. -\item The S3 class vector is not scalar. S4 code that needs one primary class name -should use \code{class(x)[1L]}, or \code{methods::class1(x)} if available. -\item \code{methods::new(class(x)[1L], ...)} creates a fresh S4 object from the S4 class -definition. For an S7 class registered with S4, that object can inherit from -\code{S7_object} through the old-class graph while lacking the \code{S7_class} slot or -attribute that makes it an S7 object. Code that updates an existing object -should prefer \code{methods::initialize(x, ...)}. -\item S4 methods that call \verb{methods::slot<-()} can bypass S7 property setters and -ordinary S7 validation. Call \code{methods::validObject()} after such updates when -the object should satisfy the S7 class contract. -\item Properties with custom getters or setters cannot be exposed as S4 slots. An -S7 class that extends S4, or that is intended to be extended by S4, must use -stored properties for the properties that need to cross the S4 boundary. -\item \code{NULL} properties are stored internally using the same sentinel that S4 uses -for \code{NULL} slots. \code{prop()}, \code{@}, and \code{methods::slot()} translate this back to -\code{NULL}; code that reads raw attributes should treat the representation as an -implementation detail. -} +S7 objects that directly extend S4 are represented as S3 old-class objects, +so \code{isS4()} is \code{FALSE} even though \code{\link[methods:is]{methods::is()}} and S4 dispatch see the +S4 parent. S4 classes can extend S7 classes with \code{\link[=S4_register_contains]{S4_register_contains()}}. -S4 classes can also extend S7 classes with \code{S4_register_contains()}. See -\code{S4_register()} for details. +See \code{vignette("compatibility")} for examples and caveats. } \examples{ diff --git a/man/rmd/S4-compatibility.Rmd b/man/rmd/S4-compatibility.Rmd deleted file mode 100644 index 40711cb41..000000000 --- a/man/rmd/S4-compatibility.Rmd +++ /dev/null @@ -1,63 +0,0 @@ -`new_class()` can use an S4 class as its parent. The S4 class can be supplied -as a class definition, such as `methods::getClass("Parent")`, or as a class -generator returned by `methods::setClass()`. The S4 parent slots become S7 -properties on the new S7 class. - -When an S7 class extends an S4 class, `new_class()` automatically registers an -S4 old class for the S7 class. This lets S4 generics dispatch through the S4 -parent: - -```r -methods::setClass("Parent", slots = list(x = "numeric")) -Child <- new_class("Child", methods::getClass("Parent"), - properties = list(y = class_character) -) - -methods::is(Child(x = 1, y = "a"), "Parent") -``` - -Things that work reasonably well: - -* S4 dispatch inherits through the S4 parent. An S4 generic with a method for - `Parent` can dispatch on a `Child` object. -* `methods::is(child, "Parent")` returns `TRUE`. -* S4 parent slots are available as S7 properties, so `prop(child, "x")` and - `child@x` use the S7 property path. -* `methods::slot(child, "x")` can read stored S4 parent slots and stored S7 - properties. Direct slot access bypasses custom S7 property behavior, so S4 - code should use it only for slots it owns. -* `methods::validObject(child)` checks S4 slot types and recursively runs S7 - property validation and S7 class validators. -* `methods::initialize(child, ...)` can reinitialize S7 objects from S4 code. - Unnamed S7, S4, and S3-data-part arguments contribute their known - properties or slots; later arguments override earlier arguments, and named - arguments override unnamed ones. -* `methods::as(child, "Parent")` and `convert(child, to = Parent)` can produce - a real S4 object for the S4 parent class. - -Caveats: - -* An S7 object that directly extends S4 is currently represented as an S3 - old-class object, not as an S4-bit object, so `isS4(child)` is `FALSE`. - This avoids advertising full S4 object invariants that the object does not - satisfy. -* The S3 class vector is not scalar. S4 code that needs one primary class name - should use `class(x)[1L]`, or `methods::class1(x)` if available. -* `methods::new(class(x)[1L], ...)` creates a fresh S4 object from the S4 class - definition. For an S7 class registered with S4, that object can inherit from - `S7_object` through the old-class graph while lacking the `S7_class` slot or - attribute that makes it an S7 object. Code that updates an existing object - should prefer `methods::initialize(x, ...)`. -* S4 methods that call `methods::slot<-()` can bypass S7 property setters and - ordinary S7 validation. Call `methods::validObject()` after such updates when - the object should satisfy the S7 class contract. -* Properties with custom getters or setters cannot be exposed as S4 slots. An - S7 class that extends S4, or that is intended to be extended by S4, must use - stored properties for the properties that need to cross the S4 boundary. -* `NULL` properties are stored internally using the same sentinel that S4 uses - for `NULL` slots. `prop()`, `@`, and `methods::slot()` translate this back to - `NULL`; code that reads raw attributes should treat the representation as an - implementation detail. - -S4 classes can also extend S7 classes with `S4_register_contains()`. See -`S4_register()` for details. diff --git a/man/rmd/S4-registration.Rmd b/man/rmd/S4-registration.Rmd deleted file mode 100644 index 0446b0cd9..000000000 --- a/man/rmd/S4-registration.Rmd +++ /dev/null @@ -1,42 +0,0 @@ -`S4_register()` registers an S7 class, S3 class, or S7 union with S4 so it can -be used in S4 method signatures. It is called automatically for concrete S7 -classes that extend S4 classes. For other S7 classes, call it when S4 code -needs to dispatch on the class or use it in a slot. - -`S4_register()` invisibly returns the registered S4 class name. For an S7 class -this is the S4 old-class name used for dispatch. For an S7 union this is the -S4 class union name. - -`S4_register_contains()` is for inheritance: use it when an S4 class -should be allowed to extend an S7 class with `methods::setClass(contains = )`. It registers -the S7 class if needed, then creates and returns an S4 shim class whose name -ends in `::S4Slots`. The shim: - -* contains the S7 old class, so inherited S7 and S4 dispatch can still find the - S7 class; -* exposes stored S7 properties as formal S4 slots (as does the old class); -* includes an `S7_class` slot so S7 can recover the class object from real S4 - instances; and -* installs S4 validity methods that recursively call S7 validation. - -Do not instantiate the `::S4Slots` shim directly. It exists so another S4 class -can contain it: - -```r -Foo <- new_class("Foo", properties = list(x = class_numeric)) -Foo_S4 <- S4_register_contains(Foo) -methods::setClass("S4Foo", contains = Foo_S4) -``` - -S4 subclasses created this way are real S4 objects. Their S7 properties are -also S4 slots, so S4 initialization and S4 slot access can set them. This is -necessary for S4 compatibility, but it means S4 code can bypass custom S7 -property behavior. Because of that, `S4_register_contains()` rejects properties -with custom getters or setters. - -Property defaults become the S4 prototype values for the shim. - -S7 unions can be registered with `S4_register()`. S7's `class_union` maps to -S4's `"numeric"` class. For other unions, S7 uses an existing matching S4 class -union if one is already registered; otherwise the union must be explicitly -registered before it can be used as an S4 slot or method signature. diff --git a/vignettes/compatibility.Rmd b/vignettes/compatibility.Rmd index bd9ef80ea..c18fa466c 100644 --- a/vignettes/compatibility.Rmd +++ b/vignettes/compatibility.Rmd @@ -143,16 +143,139 @@ The chief disadvantage of this approach is any subclasses will need to be conver ## S4 -S7 properties are equivalent to S4 slots. -The chief difference is that they can be dynamic. +S7 properties play a role similar to S4 slots. +The chief difference is that S7 properties can be dynamic, while S4 slots are +stored fields with a declared S4 class. -- S7 classes can not extend S4 classes -- S4 classes can extend S3 classes -- S7 can register methods for S4 generics and S4 classes +S7 and S4 can interoperate in both directions: + +- S7 classes can extend S4 classes. +- S4 classes can extend S7 classes. +- S7 can register methods for S4 generics and S4 classes. + +### S7 classes that extend S4 classes + +To extend an S4 class, supply its class definition or class generator as the +`parent` of a new S7 class. The S4 parent slots become S7 properties on the new +class, and `new_class()` automatically registers the S7 class with S4. + +```{r} +methods::setClass("S4Point", + slots = c(x = "numeric", y = "numeric") +) + +ColoredPoint <- new_class("ColoredPoint", + parent = methods::getClass("S4Point"), + properties = list(color = class_character) +) + +pt <- ColoredPoint(x = 1, y = 2, color = "red") +pt@x +pt@color +methods::is(pt, "S4Point") +``` + +S4 dispatch follows the S4 parent hierarchy, so S4 methods defined for the +parent can be called on the S7 child. + +```{r} +methods::setGeneric("radius", function(x) standardGeneric("radius")) +methods::setMethod("radius", "S4Point", function(x) { + sqrt(x@x^2 + x@y^2) +}) + +radius(pt) +``` + +S4 code that updates an existing object should use `initialize()` rather than +constructing a new object from `class(x)`. The S7 `initialize()` method accepts +stored S7 properties and S4 slots, and later arguments override earlier ones. + +```{r} +pt <- methods::initialize(pt, x = 3, color = "blue") +pt@x +pt@color +``` + +There are a few important caveats: + +- An S7 object that directly extends S4 is represented as an S3 old-class + object, so `isS4(pt)` is `FALSE`. Use `methods::is()` to ask about S4 + inheritance. +- The class vector is not scalar. S4 code that needs one primary class name + should use `class(x)[1L]`, or `methods::class1(x)` when available. +- `methods::slot()` and `methods::slot<-()` can read and write stored + properties, but they bypass custom S7 getters, setters, and ordinary S7 + validation. Call `methods::validObject()` after direct slot updates when + the object should satisfy the S7 contract. +- Properties with custom getters or setters cannot cross the S4 inheritance + boundary as S4 slots. +- `NULL` properties are stored using the same sentinel that S4 uses for + `NULL` slots. `prop()`, `@`, and `methods::slot()` translate this back to + `NULL`; raw attributes should be treated as an implementation detail. + +### S4 classes that extend S7 classes + +Use `S4_register_contains()` when an S4 class should extend an S7 class. It +returns an S4 shim class name for `methods::setClass(contains = )`. The shim +contains the S7 old class, exposes stored S7 properties as formal S4 slots, and +carries the `S7_class` slot that S7 uses for dispatch and validation. + +```{r} +Sample <- new_class("Sample", + properties = list( + name = class_character, + score = class_numeric + ), + validator = function(self) { + if (length(self@score) != 1) { + "@score must have length 1" + } else if (self@score < 0) { + "@score must be non-negative" + } + } +) + +Sample_S4 <- S4_register_contains(Sample) +methods::setClass("ReplicatedSample", + contains = Sample_S4, + slots = c(replicate = "integer") +) + +rs <- methods::new("ReplicatedSample", + name = "A", + score = 3, + replicate = 1L +) + +isS4(rs) +rs@name +prop(rs, "score") +methods::validObject(rs) +``` + +S7 dispatch still sees the S7 class, even though the concrete object is an S4 +object. + +```{r} +sample_label <- new_generic("sample_label", "x") +method(sample_label, Sample) <- function(x) { + paste0(x@name, ": ", x@score) +} + +sample_label(rs) +``` + +The class returned by `S4_register_contains()` is a compatibility layer, not a +user-facing class. Do not instantiate it directly; use it only as a superclass +for another S4 class. Since S4 subclasses are real S4 objects, S4 code can +access the S7 properties as slots. This is necessary for compatibility, but it +also means S4 code can bypass S7 property setters until validation is run. ### Unions -S4 unions are automatically converted to S7 unions. +S4 unions are automatically converted to S7 unions when they are used as S7 +property classes. There's an important difference in the way that class unions are handled in S4 and S7. In S4, they're handled at method dispatch time, so when you create `setUnion("u1", c("class1", "class2"))`, `class1` and `class2` now extend `u1`. In S7, unions are handled at method registration time so that registering a method for a union is just short-hand for registering a method for each of the classes. @@ -168,3 +291,5 @@ foo ``` S7 unions allow you to restrict the type of a property in the same way that S4 unions allow you to restrict the type of a slot. +S7 unions can also be registered with `S4_register()` for use in S4 slots and +method signatures. From 67e88aef6967acf5818e5b43f794ff43dc78cb83 Mon Sep 17 00:00:00 2001 From: Michael Lawrence Date: Fri, 19 Jun 2026 10:46:44 -0700 Subject: [PATCH 070/132] massive simplification: no longer define ::S4Slots variant to enable S4 to inherit from S7; there's just two types of classes: the stub old class and the reified old class. The former for when only dispatch is needed, the latter for when inheritance (in either direction) is needed. --- NAMESPACE | 1 - R/S4.R | 196 +++++++---------------- R/class.R | 3 +- man/S4_register.Rd | 22 +-- man/new_class.Rd | 3 +- tests/testthat/_snaps/S4.md | 1 + tests/testthat/test-S4.R | 91 +++++------ tests/testthat/test-method-register-S3.R | 6 +- vignettes/compatibility.Rmd | 21 +-- 9 files changed, 134 insertions(+), 210 deletions(-) diff --git a/NAMESPACE b/NAMESPACE index 975fa097e..16148e7b8 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -42,7 +42,6 @@ export("method<-") export("prop<-") export("props<-") export(S4_register) -export(S4_register_contains) export(S7_class) export(S7_class_desc) export(S7_classes) diff --git a/R/S4.R b/R/S4.R index 9422ddc6f..75e8b0fbe 100644 --- a/R/S4.R +++ b/R/S4.R @@ -9,10 +9,10 @@ #' `S4_register()` registers an S7 class, S3 class, or S7 union with S4 and #' invisibly returns the registered S4 class name. #' -#' `S4_register_contains()` returns an S4 shim class name for use in -#' `methods::setClass(contains = )`, allowing S4 classes to extend an S7 class. -#' The shim exposes stored S7 properties as S4 slots and carries the `S7_class` -#' slot needed for S7 dispatch and validation. Do not instantiate it directly. +#' Use `S4_register(contains = TRUE)` when an S4 class should extend an S7 +#' class with `methods::setClass(contains = )`. This creates a virtual S4 class +#' that exposes stored S7 properties as S4 slots and carries the `S7_class` slot +#' needed for S7 dispatch and validation. Do not instantiate it directly. #' #' Properties with custom getters or setters cannot be represented as S4 slots. #' Register S7 unions with `S4_register()` before using them in S4 slots or @@ -24,9 +24,11 @@ #' `S4_register()` only, an S3 class created with [new_S3_class()] or an S7 #' union created with [new_union()]. #' @param env Expert use only. Environment where S4 class will be registered. +#' @param contains If `TRUE`, create the heavier S4 class needed for S4 classes +#' to extend an S7 class. This exposes stored S7 properties as S4 slots. #' @returns -#' Both functions are called for their side effects and invisibly return the -#' registered S4 class name. +#' Called for its side effects and invisibly returns the registered S4 class +#' name. #' @export #' @examples #' methods::setGeneric("S4_generic", function(x) { @@ -40,14 +42,15 @@ #' S4_generic(Foo()) #' #' S4Foo <- new_class("S4Foo", properties = list(x = class_numeric), package = "S7") -#' S4Foo_S4 <- S4_register_contains(S4Foo) +#' S4Foo_S4 <- S4_register(S4Foo, contains = TRUE) #' methods::setClass("S4Child", contains = S4Foo_S4) -S4_register <- function(class, env = parent.frame()) { +S4_register <- function(class, env = parent.frame(), contains = FALSE) { + where <- topenv(env) if (is_union(class)) { - return(invisible(S4_register_union(class, topenv(env)))) + return(invisible(S4_register_union(class, where))) } else if (is_class(class)) { - if (class@abstract) { - return(invisible(S4_register_abstract_class(class, topenv(env)))) + if (contains || class@abstract) { + return(invisible(S4_register_reified_class(class, where))) } classes <- class_dispatch(class) } else if (is_S3_class(class)) { @@ -60,7 +63,7 @@ S4_register <- function(class, env = parent.frame()) { stop2(msg) } - methods::setOldClass(classes, where = topenv(env)) + methods::setOldClass(classes, where = where) invisible(classes[1L]) } @@ -199,80 +202,10 @@ inherits_S4 <- function(x) { } S4_register_subclass <- function(class, env) { - where <- topenv(env) - if (class@abstract) { - S4_register_abstract_class(class, where) - return(invisible()) - } - - subclasses <- S4_old_classes(class) - old_classes <- c(subclasses, "S7_object") - methods::setOldClass( - old_classes, - S4Class = S4_register_prototype_class(class, where), - where = where - ) - S4_set_S3_class_prototype(subclasses[1L], old_classes, where) - - if (length(subclasses) == 1L) { - methods::setValidity(subclasses[1L], S4_validate_old_class, where = where) - methods::setMethod( - "initialize", - subclasses[1L], - S4_initialize, - where = where - ) - } - + S4_register(class, env, contains = TRUE) invisible() } -#' @rdname S4_register -#' @export -S4_register_contains <- function(class, env = parent.frame()) { - if (!is_class(class)) { - msg <- sprintf("`class` must be an S7 class, not a %s.", obj_desc(class)) - stop(msg, call. = FALSE) - } - - where <- topenv(env) - classes <- class_dispatch(class) - if (!methods::isClass(classes[1L], where = where)) { - S4_register(class, where) - } - class_name <- S4_register_with_props(class, where) - invisible(class_name) -} - -S4_register_with_props <- function(class, env) { - where <- topenv(env) - class_name <- S4_register_contains_name(class) - contains <- S4_class(class, where) - properties <- class@properties - properties <- properties[setdiff( - names(properties), - S4_slot_names(contains, where) - )] - methods::setClass( - Class = class_name, - slots = c( - lapply(properties, S4_property_class, S4_env = where), - S7_class = "S7_class" - ), - contains = c(contains), - prototype = S4_properties_prototype(properties, class, where, TRUE), - where = where - ) - S4_set_S3_class_prototype( - class_name, - c(S4_old_classes(class), "S7_object"), - where - ) - methods::setValidity(class_name, S4_validate_shim, where = where) - - class_name -} - S4_set_S3_class_prototype <- function(class, S3_class, env) { class_def <- methods::getClass(class, where = env) attr(class_def@prototype, ".S3Class") <- S3_class @@ -284,10 +217,6 @@ S4_slot_names <- function(class, S4_env) { names(methods::getClass(class, where = S4_env)@slots) } -S4_register_contains_name <- function(class) { - paste0(S7_class_name(class), "::S4Slots") -} - S4_property_class <- function(prop, S4_env) { if (prop_is_dynamic(prop) || prop_has_setter(prop)) { msg <- sprintf( @@ -352,34 +281,56 @@ S4_old_classes <- function(class) { character() } -S4_register_abstract_class <- function(class, env = parent.frame()) { +S4_register_reified_class <- function(class, env = parent.frame()) { where <- topenv(env) class_name <- S7_class_name(class) - parent_class_name <- S4_abstract_parent_class(class, where) - properties <- class@properties + parent_class_name <- S4_reified_parent_class(class, where) + parent_slot_names <- character() if (!is.null(parent_class_name)) { - properties <- properties[setdiff( - names(properties), - S4_slot_names(parent_class_name, where) - )] + parent_slot_names <- S4_slot_names(parent_class_name, where) + } + + properties <- class@properties + properties <- properties[setdiff(names(properties), parent_slot_names)] + slots <- lapply(properties, S4_property_class, S4_env = where) + needs_S7_class_slot <- !"S7_class" %in% parent_slot_names + if (needs_S7_class_slot) { + slots$S7_class <- "S7_class" } methods::setClass( Class = class_name, - slots = lapply(properties, S4_property_class, S4_env = where), + slots = slots, contains = c(parent_class_name, "VIRTUAL"), + prototype = S4_properties_prototype( + properties, + class, + where, + include_S7_class = TRUE + ), where = where ) + if (class@abstract) { + return(class_name) + } + + old_classes <- S4_reified_old_classes(class) + methods::setOldClass(old_classes, S4Class = class_name, where = where) + S4_set_S3_class_prototype(class_name, old_classes, where) + methods::setValidity(class_name, S4_validate_reified_class, where = where) + methods::setMethod("initialize", class_name, S4_initialize, where = where) + class_name } -S4_abstract_parent_class <- function(class, env) { +S4_reified_parent_class <- function(class, env) { parent_class <- class@parent if (is_class(parent_class)) { - if (parent_class@abstract) { - return(S4_class(parent_class, env)) + if (parent_class@name == "S7_object") { + return(NULL) } + return(S4_register(parent_class, env, contains = TRUE)) } else if (is_S4_class(parent_class)) { return(S4_class(parent_class, env)) } @@ -387,33 +338,32 @@ S4_abstract_parent_class <- function(class, env) { NULL } -S4_validate_old_class <- function(object) { - if (isS4(object)) { - # covered by S4_validate_shim() - return(TRUE) +S4_reified_old_classes <- function(class) { + if (S7_extends_S4(class)) { + return(c(S4_old_classes(class), "S7_object")) } - S4_validate(object) + class_dispatch(class) } -S4_validate_shim <- function(object) { - shim_class <- sub("::S4Slots$", "", class(object)[1L]) +S4_validate_reified_class <- function(object) { + class_name <- class(object)[1L] class <- S7_class(object) - if (identical(S7_class_name(class), shim_class)) { + if (identical(S7_class_name(class), class_name)) { return(S4_validate(object)) } while (is_class(class@parent)) { class <- class@parent - if (identical(S7_class_name(class), shim_class)) { + if (identical(S7_class_name(class), class_name)) { return(TRUE) } } sprintf( - "object with S7 class %s does not match S4 shim class %s", + "object with S7 class %s does not match S4 class %s", dQuote(S7_class_name(S7_class(object))), - dQuote(paste0(shim_class, "::S4Slots")) + dQuote(class_name) ) } @@ -498,34 +448,6 @@ S4_initialize_data_part <- function(value, object) { value } -S4_register_prototype_class <- function(class, env = parent.frame()) { - where <- topenv(env) - classes <- class_dispatch(class) - - parent_class <- class@parent - parent_class_name <- S4_class(parent_class, where) - parent_slot_names <- S4_slot_names(parent_class_name, where) - properties <- class@properties - properties <- properties[setdiff( - names(properties), - parent_slot_names - )] - slots <- lapply(properties, S4_property_class, S4_env = where) - if (!"S7_class" %in% parent_slot_names) { - slots$S7_class <- "S7_class" - } - - methods::setClass( - Class = classes[1L], - slots = slots, - contains = c(parent_class_name, "VIRTUAL"), - prototype = S4_properties_prototype(properties, class, where, TRUE), - where = where - ) - - classes[1L] -} - is_S4_class <- function(x) inherits(x, "classRepresentation") S4_to_S7_class <- function(x, error_base = "", call = sys.call(-1L)) { diff --git a/R/class.R b/R/class.R index 5c84d9f8f..764517b52 100644 --- a/R/class.R +++ b/R/class.R @@ -62,7 +62,8 @@ #' #' S7 objects that directly extend S4 are represented as S3 old-class objects, #' so `isS4()` is `FALSE` even though [methods::is()] and S4 dispatch see the -#' S4 parent. S4 classes can extend S7 classes with [S4_register_contains()]. +#' S4 parent. S4 classes can extend S7 classes by calling +#' [S4_register()] with `contains = TRUE`. #' #' See `vignette("compatibility")` for examples and caveats. #' @return A object constructor, a function that can be used to create objects diff --git a/man/S4_register.Rd b/man/S4_register.Rd index f50775362..75bf26de9 100644 --- a/man/S4_register.Rd +++ b/man/S4_register.Rd @@ -2,12 +2,9 @@ % Please edit documentation in R/S4.R \name{S4_register} \alias{S4_register} -\alias{S4_register_contains} \title{Register an S7, S3, or union class with S4} \usage{ -S4_register(class, env = parent.frame()) - -S4_register_contains(class, env = parent.frame()) +S4_register(class, env = parent.frame(), contains = FALSE) } \arguments{ \item{class}{An S7 class created with \code{\link[=new_class]{new_class()}}, or, for @@ -15,10 +12,13 @@ S4_register_contains(class, env = parent.frame()) union created with \code{\link[=new_union]{new_union()}}.} \item{env}{Expert use only. Environment where S4 class will be registered.} + +\item{contains}{If \code{TRUE}, create the heavier S4 class needed for S4 classes +to extend an S7 class. This exposes stored S7 properties as S4 slots.} } \value{ -Both functions are called for their side effects and invisibly return the -registered S4 class name. +Called for its side effects and invisibly returns the registered S4 class +name. } \description{ If you want to use \link{method<-} to register a method for an S4 generic with @@ -31,10 +31,10 @@ an S7 class that does not extend an S4 class, or an S3 class created by \code{S4_register()} registers an S7 class, S3 class, or S7 union with S4 and invisibly returns the registered S4 class name. -\code{S4_register_contains()} returns an S4 shim class name for use in -\code{methods::setClass(contains = )}, allowing S4 classes to extend an S7 class. -The shim exposes stored S7 properties as S4 slots and carries the \code{S7_class} -slot needed for S7 dispatch and validation. Do not instantiate it directly. +Use \code{S4_register(contains = TRUE)} when an S4 class should extend an S7 +class with \code{methods::setClass(contains = )}. This creates a virtual S4 class +that exposes stored S7 properties as S4 slots and carries the \code{S7_class} slot +needed for S7 dispatch and validation. Do not instantiate it directly. Properties with custom getters or setters cannot be represented as S4 slots. Register S7 unions with \code{S4_register()} before using them in S4 slots or @@ -55,6 +55,6 @@ method(S4_generic, Foo) <- function(x) "Hello" S4_generic(Foo()) S4Foo <- new_class("S4Foo", properties = list(x = class_numeric), package = "S7") -S4Foo_S4 <- S4_register_contains(S4Foo) +S4Foo_S4 <- S4_register(S4Foo, contains = TRUE) methods::setClass("S4Child", contains = S4Foo_S4) } diff --git a/man/new_class.Rd b/man/new_class.Rd index 7c245bf8a..32de3f076 100644 --- a/man/new_class.Rd +++ b/man/new_class.Rd @@ -96,7 +96,8 @@ S4 automatically, and S4 generics can dispatch through the S4 parent. S7 objects that directly extend S4 are represented as S3 old-class objects, so \code{isS4()} is \code{FALSE} even though \code{\link[methods:is]{methods::is()}} and S4 dispatch see the -S4 parent. S4 classes can extend S7 classes with \code{\link[=S4_register_contains]{S4_register_contains()}}. +S4 parent. S4 classes can extend S7 classes by calling +\code{\link[=S4_register]{S4_register()}} with \code{contains = TRUE}. See \code{vignette("compatibility")} for examples and caveats. } diff --git a/tests/testthat/_snaps/S4.md b/tests/testthat/_snaps/S4.md index 4a4efe43f..dc702afab 100644 --- a/tests/testthat/_snaps/S4.md +++ b/tests/testthat/_snaps/S4.md @@ -26,3 +26,4 @@ Condition Error: ! Failed to find originating package for S4 generic 'nonexistent_generic' in imports. + diff --git a/tests/testthat/test-S4.R b/tests/testthat/test-S4.R index fd165d00f..1c334ca71 100644 --- a/tests/testthat/test-S4.R +++ b/tests/testthat/test-S4.R @@ -67,7 +67,7 @@ test_that("S4_register registers an S7 union so it can be used with S4 methods", expect_equal(S4regUnionGeneric("x"), "union") }) -test_that("S4_register_contains registers S7 properties as slots for S4 subclasses", { +test_that("S4_register can reify S7 properties as slots for S4 subclasses", { on.exit({ if (methods::isGeneric("S4regContainsGeneric")) { methods::removeGeneric("S4regContainsGeneric") @@ -75,8 +75,7 @@ test_that("S4_register_contains registers S7 properties as slots for S4 subclass S4_remove_classes(c( "S4regContainsS4Child", "S7::S4regContains", - "S7::S4regContainsChild", - "S7::S4regContainsChild::S4Slots" + "S7::S4regContainsChild" )) }) @@ -96,11 +95,11 @@ test_that("S4_register_contains registers S7 properties as slots for S4 subclass ) S4regContainsChild_old <- S4_register(S4regContainsChild) - S4regContainsChild_S4 <- S4_register_contains(S4regContainsChild) - expect_equal(S4regContainsChild_S4, "S7::S4regContainsChild::S4Slots") + S4regContainsChild_S4 <- S4_register(S4regContainsChild, contains = TRUE) + expect_equal(S4regContainsChild_S4, "S7::S4regContainsChild") expect_equal( methods::slotNames(S4regContainsChild_S4), - c("x", "y", "S7_class", ".S3Class") + c("y", "x", "S7_class", ".S3Class") ) expect_contains( methods::extends(S4regContainsChild_S4), @@ -168,12 +167,11 @@ test_that("S4_register_contains registers S7 properties as slots for S4 subclass expect_equal(S4regContainsGeneric(object), 1) }) -test_that("S4_register_contains constructs S4 subclasses of S7 classes that extend S4 classes", { +test_that("S4_register constructs S4 subclasses of S7 classes that extend S4 classes", { on.exit(S4_remove_classes(c( "S4regNewParent", "S4regNewMiddle", "S4regNewChild", - "S4regNewChild::S4Slots", "S4regNewGrandChild" ))) setClass( @@ -206,7 +204,7 @@ test_that("S4_register_contains constructs S4 subclasses of S7 classes that exte }, package = NULL ) - S4regNewChild_S4 <- S4_register_contains(S4regNewChild) + S4regNewChild_S4 <- S4_register(S4regNewChild, contains = TRUE) expect_equal( methods::slotNames("S4regNewChild"), c("status", "metadata", "S7_class", "assays", "rowData", ".S3Class") @@ -232,8 +230,8 @@ test_that("S4_register_contains constructs S4 subclasses of S7 classes that exte expect_equal(methods::slot(object, "rowData"), character()) expect_equal(methods::slot(object, "metadata"), character()) expect_equal(methods::slot(object, "status"), character()) - object_shim <- methods::as(object, S4regNewChild_S4) - object_old <- methods::as(object_shim, "S4regNewChild") + object_reified <- methods::as(object, S4regNewChild_S4) + object_old <- methods::as(object_reified, "S4regNewChild") expect_equal(methods::slot(object_old, "metadata"), character()) expect_equal(methods::slot(object_old, "status"), character()) object_old <- methods::as(object, "S4regNewChild") @@ -267,16 +265,14 @@ test_that("S4_register_contains constructs S4 subclasses of S7 classes that exte expect_error(methods::validObject(invalid), "bad status") }) -test_that("S4_validate_shim validates only matching S7 classes for S4 shim upcasts", { +test_that("S4_validate_reified_class validates only matching S7 classes for S4 upcasts", { on.exit(S4_remove_classes(c( "S4regShimRoot", "S4regShimParent", "S4regShimChild", "S4regShimGrandChild", "S7::S4regShimParent", - "S7::S4regShimChild", - "S7::S4regShimParent::S4Slots", - "S7::S4regShimChild::S4Slots" + "S7::S4regShimChild" ))) setClass("S4regShimRoot", slots = list(root = "numeric")) @@ -293,8 +289,8 @@ test_that("S4_validate_shim validates only matching S7 classes for S4 shim upcas package = "S7" ) - S4regShimParent_S4 <- S4_register_contains(S4regShimParent) - S4regShimChild_S4 <- S4_register_contains(S4regShimChild) + S4regShimParent_S4 <- S4_register(S4regShimParent, contains = TRUE) + S4regShimChild_S4 <- S4_register(S4regShimChild, contains = TRUE) setClass("S4regShimParent", contains = S4regShimParent_S4) setClass( "S4regShimChild", @@ -303,10 +299,10 @@ test_that("S4_validate_shim validates only matching S7 classes for S4 shim upcas setClass("S4regShimGrandChild", contains = "S4regShimChild") object <- methods::new("S4regShimGrandChild", root = 1, x = 2, y = "a") - parent_shim <- methods::as(object, S4regShimParent_S4) + parent_object <- methods::as(object, S4regShimParent_S4) - expect_false("y" %in% methods::slotNames(parent_shim)) - expect_equal(S7_class(parent_shim), S4regShimChild) + expect_false("y" %in% methods::slotNames(parent_object)) + expect_equal(S7_class(parent_object), S4regShimChild) expect_true(methods::validObject(object)) }) @@ -317,7 +313,6 @@ test_that("S4_register registers abstract S7 classes as virtual S4 classes", { "S4regAbstractParent", "S4regAbstract", "S4regAbstractConcrete", - "S4regAbstractConcrete::S4Slots", "S4regAbstractShim" )) }) @@ -343,27 +338,34 @@ test_that("S4_register registers abstract S7 classes as virtual S4 classes", { properties = list(x = class_integer), package = NULL ) - method(dim, S4regAbstractConcrete) <- function(x) { - c(methods::slot(x, "x"), 2L) - } - S4regAbstractConcrete_S4 <- S4_register_contains(S4regAbstractConcrete) + method(dim, S4regAbstractConcrete) <- function(x) c(x@x, 2L) + S4regAbstractConcrete_S4 <- S4_register( + S4regAbstractConcrete, + contains = TRUE + ) setClass("S4regAbstractShim", contains = S4regAbstractConcrete_S4) object <- methods::new("S4regAbstractShim", x = 1L) + abstract_prototype <- methods::getClass("S4regAbstract")@prototype concrete_prototype <- methods::getClass("S4regAbstractConcrete")@prototype expect_true(methods::isVirtualClass("S4regAbstract")) + expect_true("S7_class" %in% methods::slotNames("S4regAbstract")) + expect_equal(methods::slot(abstract_prototype, "S7_class"), S4regAbstract) expect_false(methods::extends("S4regAbstract", "oldClass")) expect_false(methods::extends("S4regAbstract", "S7_object")) + expect_equal( + methods::slot(concrete_prototype, "S7_class"), + S4regAbstractConcrete + ) expect_false("S4regAbstract" %in% attr(concrete_prototype, ".S3Class")) expect_equal(dim(object), c(1L, 2L)) expect_true(methods::validObject(object)) }) -test_that("S4_register_contains uses S7 property defaults as S4 shim prototypes", { +test_that("S4_register uses S7 property defaults as S4 prototypes", { on.exit(S4_remove_classes(c( "S4regPrototype", - "S4regPrototype::S4Slots", "S4regPrototypeChild", "NULL_OR_character" ))) @@ -378,7 +380,7 @@ test_that("S4_register_contains uses S7 property defaults as S4 shim prototypes" ), package = NULL ) - S4regPrototype_S4 <- S4_register_contains(S4regPrototype) + S4regPrototype_S4 <- S4_register(S4regPrototype, contains = TRUE) methods::setClass("S4regPrototypeChild", contains = S4regPrototype_S4) object <- methods::new("S4regPrototypeChild") @@ -392,10 +394,9 @@ test_that("S4_register_contains uses S7 property defaults as S4 shim prototypes" expect_true(methods::validObject(object)) }) -test_that("S4_register_contains treats S4 NULL slot sentinels as NULL-valued S7 properties", { +test_that("S4_register treats S4 NULL slot sentinels as NULL-valued S7 properties", { on.exit(S4_remove_classes(c( "S4regNullable", - "S4regNullable::S4Slots", "S4regNullableChild", "NULL_OR_character" ))) @@ -408,7 +409,7 @@ test_that("S4_register_contains treats S4 NULL slot sentinels as NULL-valued S7 ), package = NULL ) - S4regNullable_S4 <- S4_register_contains(S4regNullable) + S4regNullable_S4 <- S4_register(S4regNullable, contains = TRUE) methods::setClass("S4regNullableChild", contains = S4regNullable_S4) object <- methods::new("S4regNullableChild") @@ -429,12 +430,10 @@ test_that("S4_register_contains treats S4 NULL slot sentinels as NULL-valued S7 expect_identical(attr(plain, "x", exact = TRUE), as.name("\001NULL\001")) }) -test_that("S4_register_contains rejects properties that can not be represented as slots", { +test_that("S4_register rejects properties that can not be represented as slots", { on.exit(S4_remove_classes(c( "S7::S4regContainsDynamic", - "S7::S4regContainsSetter", - "S7::S4regContainsDynamic::S4Slots", - "S7::S4regContainsSetter::S4Slots" + "S7::S4regContainsSetter" ))) S4regContainsDynamic <- new_class( @@ -445,7 +444,7 @@ test_that("S4_register_contains rejects properties that can not be represented a package = "S7" ) expect_error( - S4_register_contains(S4regContainsDynamic), + S4_register(S4regContainsDynamic, contains = TRUE), "custom getter" ) @@ -463,15 +462,14 @@ test_that("S4_register_contains rejects properties that can not be represented a package = "S7" ) expect_error( - S4_register_contains(S4regContainsSetter), + S4_register(S4regContainsSetter, contains = TRUE), "custom setter" ) }) -test_that("S4_register_contains uses registered S7 unions as S4 slots", { +test_that("S4_register uses registered S7 unions as S4 slots", { on.exit(S4_remove_classes(c( "S7::S4regContainsUnion", - "S7::S4regContainsUnion::S4Slots", "integer_OR_numeric_OR_character" ))) @@ -481,23 +479,25 @@ test_that("S4_register_contains uses registered S7 unions as S4 slots", { package = "S7" ) expect_error( - S4_register_contains(S4regContainsUnion), + S4_register(S4regContainsUnion, contains = TRUE), "not been registered" ) S4_register(class_numeric | class_character) - S4regContainsUnion_S4 <- S4_register_contains(S4regContainsUnion) + S4regContainsUnion_S4 <- S4_register( + S4regContainsUnion, + contains = TRUE + ) expect_equal( as.character(methods::getClass(S4regContainsUnion_S4)@slots$x), "integer_OR_numeric_OR_character" ) }) -test_that("S4_register_contains uses matching S4 unions as S4 slots", { +test_that("S4_register uses matching S4 unions as S4 slots", { env <- topenv(environment()) on.exit(S4_remove_classes( c( - "S4regContainsExistingUnion::S4Slots", "S4regContainsExistingUnion", "S4regExistingUnion", "S4regUnionMember2", @@ -523,9 +523,10 @@ test_that("S4_register_contains uses matching S4 unions as S4 slots", { package = NULL ) - S4regContainsExistingUnion_S4 <- S4_register_contains( + S4regContainsExistingUnion_S4 <- S4_register( S4regContainsExistingUnion, - env + env, + contains = TRUE ) expect_equal( as.character( diff --git a/tests/testthat/test-method-register-S3.R b/tests/testthat/test-method-register-S3.R index 61672c0b1..1da211aa2 100644 --- a/tests/testthat/test-method-register-S3.R +++ b/tests/testthat/test-method-register-S3.R @@ -62,7 +62,6 @@ test_that("internal generics register S4 methods for S4-backed S7 classes", { S4_remove_classes(c( "S4regDimParent", "S4regDimChild", - "S4regDimChild::S4Slots", "S4regDimShim" )) }) @@ -78,7 +77,7 @@ test_that("internal generics register S4 methods for S4-backed S7 classes", { package = NULL ) method(dim, S4regDimChild) <- function(x) c(x@x, 2L) - S4regDimChild_S4 <- S4_register_contains(S4regDimChild) + S4regDimChild_S4 <- S4_register(S4regDimChild, contains = TRUE) setClass("S4regDimShim", contains = S4regDimChild_S4) object <- methods::new("S4regDimShim", x = 1L) @@ -99,7 +98,6 @@ test_that("internal replacement generics can register full S4 signatures", { S4_remove_classes(c( "S4regDimnamesParent", "S4regDimnamesChild", - "S4regDimnamesChild::S4Slots", "S4regDimnamesShim" )) }) @@ -116,7 +114,7 @@ test_that("internal replacement generics can register full S4 signatures", { x@x <- value x } - S4regDimnamesChild_S4 <- S4_register_contains(S4regDimnamesChild) + S4regDimnamesChild_S4 <- S4_register(S4regDimnamesChild, contains = TRUE) setClass("S4regDimnamesShim", contains = S4regDimnamesChild_S4) object <- methods::new("S4regDimnamesShim", x = list(NULL, NULL)) diff --git a/vignettes/compatibility.Rmd b/vignettes/compatibility.Rmd index c18fa466c..056cd1e2a 100644 --- a/vignettes/compatibility.Rmd +++ b/vignettes/compatibility.Rmd @@ -216,10 +216,10 @@ There are a few important caveats: ### S4 classes that extend S7 classes -Use `S4_register_contains()` when an S4 class should extend an S7 class. It -returns an S4 shim class name for `methods::setClass(contains = )`. The shim -contains the S7 old class, exposes stored S7 properties as formal S4 slots, and -carries the `S7_class` slot that S7 uses for dispatch and validation. +Use `S4_register(contains = TRUE)` when an S4 class should extend an S7 class. +It returns the virtual S4 class name for `methods::setClass(contains = )`. +This class exposes stored S7 properties as formal S4 slots and carries the +`S7_class` slot that S7 uses for dispatch and validation. ```{r} Sample <- new_class("Sample", @@ -236,7 +236,7 @@ Sample <- new_class("Sample", } ) -Sample_S4 <- S4_register_contains(Sample) +Sample_S4 <- S4_register(Sample, contains = TRUE) methods::setClass("ReplicatedSample", contains = Sample_S4, slots = c(replicate = "integer") @@ -266,11 +266,12 @@ method(sample_label, Sample) <- function(x) { sample_label(rs) ``` -The class returned by `S4_register_contains()` is a compatibility layer, not a -user-facing class. Do not instantiate it directly; use it only as a superclass -for another S4 class. Since S4 subclasses are real S4 objects, S4 code can -access the S7 properties as slots. This is necessary for compatibility, but it -also means S4 code can bypass S7 property setters until validation is run. +The class returned by `S4_register(contains = TRUE)` is a compatibility layer, +not a user-facing class. Do not instantiate it directly; use it only as a +superclass for another S4 class. Since S4 subclasses are real S4 objects, S4 +code can access the S7 properties as slots. This is necessary for +compatibility, but it also means S4 code can bypass S7 property setters until +validation is run. ### Unions From a9c4c7ed595948f873f6730f304f9a5a779ddc53 Mon Sep 17 00:00:00 2001 From: Michael Lawrence Date: Fri, 19 Jun 2026 11:28:08 -0700 Subject: [PATCH 071/132] add NEWS entry --- NEWS.md | 1 + 1 file changed, 1 insertion(+) diff --git a/NEWS.md b/NEWS.md index 11cfd4cc6..ca0d8b303 100644 --- a/NEWS.md +++ b/NEWS.md @@ -2,6 +2,7 @@ * New `:=` operator creates and names an object in one step, so `Foo := new_class()` is equivalent to `Foo <- new_class(name = "Foo")` (#658). * The class object that S7 stores on each instance now lives in the `_S7_class` attribute (previously `S7_class`), moving it into the `_`-prefixed namespace reserved for S7 internals so it can't collide with a user-defined property. Objects created by an older version of S7 (e.g. serialised to disk or baked into another package's lazy-load database) continue to work, as S7 falls back to the old attribute name when reading them (#677). +* S7 and S4 now interoperate through inheritance. `new_class()` can use an S4 class as a parent, mapping S4 slots to S7 properties and registering the class with S4 automatically. Conversely, `S4_register()` registers an S7 class with S4, and `S4_contains()` returns an S4 class name suitable for `methods::setClass(contains = )`, exposing stored S7 properties as S4 slots for S4 subclasses. This support includes S4 initialization and validity integration, and S4/internal generic registration where needed; see `vignette("compatibility")` for caveats (#456). * Errors thrown by S7 now report the function where they occurred, making it easier to track down the source of a problem (#646). * `class_POSIXct` uses the `tzone` attribute (not `tz`), and allows it to be absent (#401). * Base type wrappers like `class_integer` now define their constructor and validator in the S7 namespace. (#553). From dd0ab3982834e36b369a546b1830c3af03af0c17 Mon Sep 17 00:00:00 2001 From: Michael Lawrence Date: Fri, 19 Jun 2026 17:36:40 -0700 Subject: [PATCH 072/132] post-rebase cleanup --- R/class-spec.R | 2 +- R/class.R | 131 ++++++++++++++++++++++++++------------- man/S4_register.Rd | 2 +- man/S7_class.Rd | 2 +- man/new_class.Rd | 10 ++- tests/testthat/test-S4.R | 2 +- 6 files changed, 99 insertions(+), 50 deletions(-) diff --git a/R/class-spec.R b/R/class-spec.R index fcadf9ce4..8696185bf 100644 --- a/R/class-spec.R +++ b/R/class-spec.R @@ -200,7 +200,7 @@ class_constructor <- function(.x) { class_validate <- function(class, object) { if (is_S4_class(class)) { - if (isS4(object) || methods::isClass(class(object)[[1]])) { + if (isS4(object)) { check <- methods::validObject(object, test = TRUE) return(if (isTRUE(check)) NULL else check) } diff --git a/R/class.R b/R/class.R index 764517b52..bdfdfa576 100644 --- a/R/class.R +++ b/R/class.R @@ -144,17 +144,20 @@ new_class <- function( } } + parent_props <- class_properties(parent) new_props <- as_properties(properties) check_prop_names(new_props) + check_prop_overrides(new_props, parent_props, name, parent) # Combine properties from parent, overriding as needed - all_props <- class_properties(parent) + all_props <- parent_props all_props[names(new_props)] <- new_props if (is.null(constructor)) { + constructor_props <- if (is_S4_class(parent)) all_props else new_props constructor <- new_constructor( parent, - all_props, + constructor_props, envir = parent.frame(), package = package ) @@ -288,17 +291,29 @@ check_can_inherit <- function( is_class <- function(x) inherits(x, "S7_class") +# A class you can't supply an instance of: an abstract S7 class, or an S3 class +# registered without a constructor (e.g. a marker class like "gg" or "POSIXt"). +class_is_abstract <- function(class) { + if (is_class(class)) { + class@abstract + } else if (is_S3_class(class)) { + class$abstract %||% is_S3_stub_constructor(class$constructor) + } else { + FALSE + } +} + check_parent <- function(parent, class, call = sys.call(-1L)) { parent_class <- class@parent if (is.null(parent_class)) { stop2( - "`.parent` must not be supplied when class has no parent.", + "`_parent` must not be supplied when class has no parent.", call = call ) } # Ignore abstract classes since you can't supply an instance - if (is_class(parent_class) && parent_class@abstract) { + if (class_is_abstract(parent_class)) { return() } @@ -313,7 +328,7 @@ check_parent <- function(parent, class, call = sys.call(-1L)) { return() } msg <- sprintf( - "`.parent` must be an instance of %s, not %s.", + "`_parent` must be an instance of %s, not %s.", class_desc(parent_class), obj_desc(parent) ) @@ -322,11 +337,15 @@ check_parent <- function(parent, class, call = sys.call(-1L)) { # Object ------------------------------------------------------------------ -#' @param .parent,... Parent object and named properties used to construct the +#' @param _parent,... Parent object and named properties used to construct the #' object. +#' +#' As a convenience, if `...` is a single unnamed list, then the elements of +#' that list are used as the properties. This makes it easy to +#' programmatically construct an object from a list of property values. #' @rdname new_class #' @export -new_object <- function(.parent, ...) { +new_object <- function(`_parent`, ...) { class <- sys.function(-1) if (!inherits(class, "S7_class")) { stop2("`new_object()` must be called from within a constructor.") @@ -339,18 +358,17 @@ new_object <- function(.parent, ...) { stop2(msg) } - if (!missing(.parent)) { - check_parent(.parent, class) + if (!missing(`_parent`)) { + check_parent(`_parent`, class) } - args <- list(...) - if ("" %in% names2(args)) { - stop2("All arguments to `...` must be named.") - } + args <- collect_dots(...) has_setter <- vlapply(class@properties[names(args)], prop_has_setter) + self_attrs <- args[!has_setter] + names(self_attrs) <- prop_storage_rename(names(self_attrs)) - # We must awkwardly operate on `.parent` rather than binding to a local + # We must awkwardly operate on `_parent` rather than binding to a local # variable; since otherwise the extra binding causes ALTREP-wrapped values to # be materialised when byte-compiled (#607). attrs <- c( @@ -359,26 +377,28 @@ new_object <- function(.parent, ...) { attributes(`_parent`) ) attrs <- attrs[!duplicated(names(attrs))] - attributes(.parent) <- attrs + attributes(`_parent`) <- attrs # invoke custom property setters prop_setter_vals <- args[has_setter] for (name in names(prop_setter_vals)) { - prop(.parent, name, check = FALSE) <- prop_setter_vals[[name]] + prop(`_parent`, name, check = FALSE) <- prop_setter_vals[[name]] } - # Don't need to validate if parent class already validated, - # i.e. it's a non-abstract S7 class + # Don't need to validate the parent class if it's already validated and none + # of its properties were reset by this call. parent_validated <- inherits(class@parent, "S7_object") && !class@parent@abstract + parent_props_reset <- parent_validated && + any(names2(args) %in% names2(class@parent@properties)) validate_from( - .parent, - parent = if (parent_validated) class@parent, + `_parent`, + parent = if (parent_validated && !parent_props_reset) class@parent, # Attribute validation failures to the constructor call, not new_object() call = sys.call(-1L) ) - .parent + `_parent` } #' @export @@ -448,34 +468,59 @@ S7_class <- function(object) { check_prop_names <- function(properties, call = sys.call(-1L)) { - # these attributes have special C handlers in base R - forbidden <- c( - "names", - "dim", - "dimnames", - "class", - "tsp", - "comment", - "row.names", - "..." - ) - forbidden <- intersect(forbidden, names(properties)) - if (length(forbidden)) { - msg <- paste0( - "Property can't be named: ", - paste0(forbidden, collapse = ", "), - "." - ) - stop2(msg, call = call) + nms <- names2(properties) + + # `...` can't be a property name because it's special syntax + if ("..." %in% nms) { + stop2("Properties can't be named \"...\".", call = call) } - reserved <- intersect("S7_class", names(properties)) - if (length(reserved)) { + if ("S7_class" %in% nms) { msg <- paste0( "Property can't use S7 reserved name: ", - paste0(reserved, collapse = ", "), + "S7_class", "." ) stop2(msg, call = call) } } + +check_prop_overrides <- function( + child_props, + parent_props, + name, + parent, + call = sys.call(-1L) +) { + overridden <- intersect(names(child_props), names(parent_props)) + + for (prop in overridden) { + child_prop <- child_props[[prop]] + + # Dynamic properties are computed, not stored, so they're never validated + # against the parent's type + if (prop_is_dynamic(child_prop)) { + next + } + + child_class <- child_prop$class + parent_class <- parent_props[[prop]]$class + + if (!class_extends(child_class, parent_class)) { + child_desc <- paste0("<", name, ">") + parent_desc <- class_desc(parent) + msg <- c( + sprintf( + "%s@%s must narrow %s@%s.", + child_desc, + prop, + parent_desc, + prop + ), + sprintf("- %s@%s is %s.", parent_desc, prop, class_desc(parent_class)), + sprintf("- %s@%s is %s.", child_desc, prop, class_desc(child_class)) + ) + stop2(msg, call = call) + } + } +} diff --git a/man/S4_register.Rd b/man/S4_register.Rd index 75bf26de9..487acf07a 100644 --- a/man/S4_register.Rd +++ b/man/S4_register.Rd @@ -48,7 +48,7 @@ methods::setGeneric("S4_generic", function(x) { standardGeneric("S4_generic") }) -Foo := new_class() +Foo <- new_class("Foo") S4_register(Foo) method(S4_generic, Foo) <- function(x) "Hello" diff --git a/man/S7_class.Rd b/man/S7_class.Rd index 2cfcaa955..5802579f8 100644 --- a/man/S7_class.Rd +++ b/man/S7_class.Rd @@ -24,7 +24,7 @@ that can be passed to \code{\link[=method]{method()}} or used in any S7 dispatch } } \examples{ -Foo := new_class() +Foo <- new_class("Foo") S7_class(Foo()) # Also works on non-S7 objects diff --git a/man/new_class.Rd b/man/new_class.Rd index 32de3f076..cfabe8b42 100644 --- a/man/new_class.Rd +++ b/man/new_class.Rd @@ -15,7 +15,7 @@ new_class( validator = NULL ) -new_object(.parent, ...) +new_object(`_parent`, ...) } \arguments{ \item{name}{The name of the class, as a string. (We recommend using @@ -74,8 +74,12 @@ problem, using \verb{@prop_name} to describe where the problem lies. See \code{validate()} for more details, examples, and how to temporarily suppress validation when needed.} -\item{.parent, ...}{Parent object and named properties used to construct the -object.} +\item{_parent, ...}{Parent object and named properties used to construct the +object. + +As a convenience, if \code{...} is a single unnamed list, then the elements of +that list are used as the properties. This makes it easy to +programmatically construct an object from a list of property values.} } \value{ A object constructor, a function that can be used to create objects diff --git a/tests/testthat/test-S4.R b/tests/testthat/test-S4.R index 1c334ca71..a99d9fcac 100644 --- a/tests/testthat/test-S4.R +++ b/tests/testthat/test-S4.R @@ -301,7 +301,7 @@ test_that("S4_validate_reified_class validates only matching S7 classes for S4 u object <- methods::new("S4regShimGrandChild", root = 1, x = 2, y = "a") parent_object <- methods::as(object, S4regShimParent_S4) - expect_false("y" %in% methods::slotNames(parent_object)) + expect_equal(methods::slot(parent_object, "y"), "a") expect_equal(S7_class(parent_object), S4regShimChild) expect_true(methods::validObject(object)) }) From c88dac55766f6e2184180675f9a097afaf252268 Mon Sep 17 00:00:00 2001 From: Michael Lawrence Date: Fri, 19 Jun 2026 21:10:02 -0700 Subject: [PATCH 073/132] revert accidental reversion of switch to := syntax --- R/S4.R | 4 ++-- R/class.R | 11 ++++++----- man/S4_register.Rd | 4 ++-- man/S7_class.Rd | 2 +- man/new_class.Rd | 9 +++++---- 5 files changed, 16 insertions(+), 14 deletions(-) diff --git a/R/S4.R b/R/S4.R index 75e8b0fbe..69ba34733 100644 --- a/R/S4.R +++ b/R/S4.R @@ -35,13 +35,13 @@ #' standardGeneric("S4_generic") #' }) #' -#' Foo <- new_class("Foo") +#' Foo := new_class() #' S4_register(Foo) #' method(S4_generic, Foo) <- function(x) "Hello" #' #' S4_generic(Foo()) #' -#' S4Foo <- new_class("S4Foo", properties = list(x = class_numeric), package = "S7") +#' S4Foo := new_class(properties = list(x = class_numeric), package = "S7") #' S4Foo_S4 <- S4_register(S4Foo, contains = TRUE) #' methods::setClass("S4Child", contains = S4Foo_S4) S4_register <- function(class, env = parent.frame(), contains = FALSE) { diff --git a/R/class.R b/R/class.R index bdfdfa576..836b60f2a 100644 --- a/R/class.R +++ b/R/class.R @@ -11,8 +11,9 @@ #' CamelCase for S7 class names, but it is not required.) #' #' The result of calling `new_class()` should always be assigned to a variable -#' with this name, i.e. `Foo <- new_class("Foo")`. This object both represents -#' the class and is used to construct new instances of the class. +#' with this name, i.e. `Foo <- new_class("Foo", ...)` or +#' `Foo := new_class(...)`. This object both represents the class and is used +#' to construct new instances of the class. #' @param parent The parent class to inherit behavior from. #' There are four options: #' @@ -71,7 +72,7 @@ #' @export #' @examples #' # Create an class that represents a range using a numeric start and end -#' Range <- new_class("Range", +#' Range := new_class( #' properties = list( #' start = class_numeric, #' end = class_numeric @@ -89,7 +90,7 @@ #' #' # But we might also want to use a validator to ensure that start and end #' # are length 1, and that start is < end -#' Range <- new_class("Range", +#' Range := new_class( #' properties = list( #' start = class_numeric, #' end = class_numeric @@ -443,7 +444,7 @@ str.S7_object <- function(object, ..., nest.lev = 0) { #' @returns A class specification. #' @export #' @examples -#' Foo <- new_class("Foo") +#' Foo := new_class() #' S7_class(Foo()) #' #' # Also works on non-S7 objects diff --git a/man/S4_register.Rd b/man/S4_register.Rd index 487acf07a..00b0e3dcb 100644 --- a/man/S4_register.Rd +++ b/man/S4_register.Rd @@ -48,13 +48,13 @@ methods::setGeneric("S4_generic", function(x) { standardGeneric("S4_generic") }) -Foo <- new_class("Foo") +Foo := new_class() S4_register(Foo) method(S4_generic, Foo) <- function(x) "Hello" S4_generic(Foo()) -S4Foo <- new_class("S4Foo", properties = list(x = class_numeric), package = "S7") +S4Foo := new_class(properties = list(x = class_numeric), package = "S7") S4Foo_S4 <- S4_register(S4Foo, contains = TRUE) methods::setClass("S4Child", contains = S4Foo_S4) } diff --git a/man/S7_class.Rd b/man/S7_class.Rd index 5802579f8..2cfcaa955 100644 --- a/man/S7_class.Rd +++ b/man/S7_class.Rd @@ -24,7 +24,7 @@ that can be passed to \code{\link[=method]{method()}} or used in any S7 dispatch } } \examples{ -Foo <- new_class("Foo") +Foo := new_class() S7_class(Foo()) # Also works on non-S7 objects diff --git a/man/new_class.Rd b/man/new_class.Rd index cfabe8b42..f81dafa92 100644 --- a/man/new_class.Rd +++ b/man/new_class.Rd @@ -22,8 +22,9 @@ new_object(`_parent`, ...) CamelCase for S7 class names, but it is not required.) The result of calling \code{new_class()} should always be assigned to a variable -with this name, i.e. \code{Foo <- new_class("Foo")}. This object both represents -the class and is used to construct new instances of the class.} +with this name, i.e. \code{Foo <- new_class("Foo", ...)} or +\code{Foo := new_class(...)}. This object both represents the class and is used +to construct new instances of the class.} \item{parent}{The parent class to inherit behavior from. There are four options: @@ -108,7 +109,7 @@ See \code{vignette("compatibility")} for examples and caveats. \examples{ # Create an class that represents a range using a numeric start and end -Range <- new_class("Range", +Range := new_class( properties = list( start = class_numeric, end = class_numeric @@ -126,7 +127,7 @@ try(Range(start = "hello", end = 20)) # But we might also want to use a validator to ensure that start and end # are length 1, and that start is < end -Range <- new_class("Range", +Range := new_class( properties = list( start = class_numeric, end = class_numeric From ee2212e8ff0e352b892a09fd8fab4190531231f7 Mon Sep 17 00:00:00 2001 From: Michael Lawrence Date: Fri, 19 Jun 2026 21:10:34 -0700 Subject: [PATCH 074/132] tighten up a test --- tests/testthat/_snaps/class.md | 22 ---------------------- tests/testthat/test-class.R | 13 +++++++++---- 2 files changed, 9 insertions(+), 26 deletions(-) diff --git a/tests/testthat/_snaps/class.md b/tests/testthat/_snaps/class.md index 7cd950118..755048acb 100644 --- a/tests/testthat/_snaps/class.md +++ b/tests/testthat/_snaps/class.md @@ -107,28 +107,6 @@ Error in `new_class()`: ! `validator` must be function(self), not function(). -# S7 classes can inherit from S4 but not class unions - - Code - new_class("test", parent = parentS4, package = NULL) - Output - class - @ parent : S4 - @ constructor: function(x) {...} - @ validator : - @ properties : - $ x: or = integer(0) - Code - new_class("test", parent = new_union("character")) - Condition - Error in `as_class()`: - ! Can't convert `..1` to a valid class. - Class specification must be one of the following, not a : - * An S7 class object - * An S3 class object (from `new_S3_class()`) - * An S4 class object - * A base class - # inheritance doesn't let child properties widen or change the parent's type Code diff --git a/tests/testthat/test-class.R b/tests/testthat/test-class.R index fb96b220a..b95fc1370 100644 --- a/tests/testthat/test-class.R +++ b/tests/testthat/test-class.R @@ -62,10 +62,15 @@ test_that("S7 classes check inputs", { test_that("S7 classes can inherit from S4 but not class unions", { parentS4 := local_S4_class(slots = c(x = "numeric")) - expect_snapshot(error = TRUE, { - new_class("test", parent = parentS4, package = NULL) - new_class("test", parent = new_union("character")) - }) + + child <- new_class("test", parent = parentS4, package = NULL) + expect_s3_class(child, "S7_class") + expect_s4_class(child@parent, "classRepresentation") + expect_equal(as.character(child@parent@className), "parentS4") + expect_error( + new_class("test", parent = new_union(class_character)), + "`parent` must be an S7 class, S4 class, S3 class, or base type" + ) }) test_that("inheritance combines properties for parent classes", { From 18521507e8481f3e4dc7b962c05ec77081af4d77 Mon Sep 17 00:00:00 2001 From: Michael Lawrence Date: Fri, 19 Jun 2026 22:01:41 -0700 Subject: [PATCH 075/132] fix local_S4_class(where=); bug was exposed by our stricter version of S4_remove_classes(). --- tests/testthat/helper.R | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/tests/testthat/helper.R b/tests/testthat/helper.R index 912c657d7..0340a330c 100644 --- a/tests/testthat/helper.R +++ b/tests/testthat/helper.R @@ -93,13 +93,13 @@ local_S4_class <- function( where = topenv(env) ) { out <- methods::setClass(name, ..., where = where) - defer(S4_remove_classes(name, env), env) + defer(S4_remove_classes(name, where), env) out } local_S4_union <- function(name, members, env = parent.frame()) { out <- methods::setClassUnion(name, members, where = topenv(env)) - defer(S4_remove_classes(name, env), env) + defer(S4_remove_classes(name, topenv(env)), env) out } From e75b66b3160286d0d369acc01dc62a97f64b7ed3 Mon Sep 17 00:00:00 2001 From: Michael Lawrence Date: Sat, 20 Jun 2026 14:58:46 -0700 Subject: [PATCH 076/132] API rework: S4_register() always includes properties as slots (what contains=TRUE used to do), which ensures that classes are always able to be used as S4 superclasses. Introduce a separate helper S4_contains() that just ensures the S7 class is a suitable parent of an S4 class. --- NAMESPACE | 1 + R/S4.R | 89 +++++++++++------ R/class.R | 2 +- man/S4_register.Rd | 23 +++-- man/new_class.Rd | 2 +- tests/testthat/test-S4.R | 118 ++++++++++++++++------- tests/testthat/test-method-register-S3.R | 4 +- vignettes/compatibility.Rmd | 14 +-- 8 files changed, 168 insertions(+), 85 deletions(-) diff --git a/NAMESPACE b/NAMESPACE index 16148e7b8..d582093cf 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -41,6 +41,7 @@ export("S7_data<-") export("method<-") export("prop<-") export("props<-") +export(S4_contains) export(S4_register) export(S7_class) export(S7_class_desc) diff --git a/R/S4.R b/R/S4.R index 69ba34733..46486a11d 100644 --- a/R/S4.R +++ b/R/S4.R @@ -8,13 +8,15 @@ #' @section Details: #' `S4_register()` registers an S7 class, S3 class, or S7 union with S4 and #' invisibly returns the registered S4 class name. +#' For S7 classes, this creates a virtual S4 old class that exposes stored S7 +#' properties as S4 slots and carries the `S7_class` slot needed for S7 dispatch +#' and validation. #' -#' Use `S4_register(contains = TRUE)` when an S4 class should extend an S7 -#' class with `methods::setClass(contains = )`. This creates a virtual S4 class -#' that exposes stored S7 properties as S4 slots and carries the `S7_class` slot -#' needed for S7 dispatch and validation. Do not instantiate it directly. +#' After registration, `S4_contains()` returns the virtual S4 class name to use +#' when an S4 class should extend an S7 class with +#' `methods::setClass(contains = )`. It asserts that the S7 properties can +#' safely cross the S4 inheritance boundary. #' -#' Properties with custom getters or setters cannot be represented as S4 slots. #' Register S7 unions with `S4_register()` before using them in S4 slots or #' method signatures unless an equivalent S4 union already exists. #' @@ -24,8 +26,6 @@ #' `S4_register()` only, an S3 class created with [new_S3_class()] or an S7 #' union created with [new_union()]. #' @param env Expert use only. Environment where S4 class will be registered. -#' @param contains If `TRUE`, create the heavier S4 class needed for S4 classes -#' to extend an S7 class. This exposes stored S7 properties as S4 slots. #' @returns #' Called for its side effects and invisibly returns the registered S4 class #' name. @@ -42,19 +42,18 @@ #' S4_generic(Foo()) #' #' S4Foo := new_class(properties = list(x = class_numeric), package = "S7") -#' S4Foo_S4 <- S4_register(S4Foo, contains = TRUE) -#' methods::setClass("S4Child", contains = S4Foo_S4) -S4_register <- function(class, env = parent.frame(), contains = FALSE) { +#' S4_register(S4Foo) +#' methods::setClass("S4Child", contains = S4_contains(S4Foo)) +S4_register <- function(class, env = parent.frame()) { where <- topenv(env) if (is_union(class)) { return(invisible(S4_register_union(class, where))) } else if (is_class(class)) { - if (contains || class@abstract) { - return(invisible(S4_register_reified_class(class, where))) - } - classes <- class_dispatch(class) + return(invisible(S4_register_class(class, where))) } else if (is_S3_class(class)) { classes <- class$class + methods::setOldClass(classes, where = where) + return(invisible(classes[1L])) } else { msg <- sprintf( "`class` must be an S7 class, S3 class, or S7 union, not a %s.", @@ -62,9 +61,22 @@ S4_register <- function(class, env = parent.frame(), contains = FALSE) { ) stop2(msg) } +} - methods::setOldClass(classes, where = where) - invisible(classes[1L]) +#' @rdname S4_register +#' @export +S4_contains <- function(class, env = parent.frame()) { + where <- topenv(env) + if (!is_class(class)) { + msg <- sprintf("`class` must be an S7 class, not a %s.", obj_desc(class)) + stop2(msg) + } + + class_name <- as.character( + S4_registered_class(class, where, call = sys.call())@className + ) + S4_check_contains(class) + class_name } S4_register_union <- function(class, env) { @@ -202,7 +214,7 @@ inherits_S4 <- function(x) { } S4_register_subclass <- function(class, env) { - S4_register(class, env, contains = TRUE) + S4_register(class, env) invisible() } @@ -218,17 +230,32 @@ S4_slot_names <- function(class, S4_env) { } S4_property_class <- function(prop, S4_env) { - if (prop_is_dynamic(prop) || prop_has_setter(prop)) { - msg <- sprintf( - "Can't register property %s as an S4 slot because it has a custom %s.", - prop$name, - if (prop_is_dynamic(prop)) "getter" else "setter" - ) - stop(msg, call. = FALSE) - } S4_class(prop$class, S4_env) } +S4_check_contains <- function(class, call = sys.call(-1L)) { + if (!is_class(class)) { + return(invisible()) + } + + for (prop in class@properties) { + if (prop_is_dynamic(prop) || prop_has_setter(prop)) { + msg <- sprintf( + paste0( + "Can't extend S7 class %s with S4 because property %s has a ", + "custom %s." + ), + class_desc(class), + prop$name, + if (prop_is_dynamic(prop)) "getter" else "setter" + ) + stop2(msg, call = call) + } + } + + invisible() +} + S4_properties_prototype <- function( properties, class, @@ -281,7 +308,7 @@ S4_old_classes <- function(class) { character() } -S4_register_reified_class <- function(class, env = parent.frame()) { +S4_register_class <- function(class, env = parent.frame()) { where <- topenv(env) class_name <- S7_class_name(class) parent_class_name <- S4_reified_parent_class(class, where) @@ -318,7 +345,7 @@ S4_register_reified_class <- function(class, env = parent.frame()) { old_classes <- S4_reified_old_classes(class) methods::setOldClass(old_classes, S4Class = class_name, where = where) S4_set_S3_class_prototype(class_name, old_classes, where) - methods::setValidity(class_name, S4_validate_reified_class, where = where) + methods::setValidity(class_name, S4_validate_class, where = where) methods::setMethod("initialize", class_name, S4_initialize, where = where) class_name @@ -330,7 +357,7 @@ S4_reified_parent_class <- function(class, env) { if (parent_class@name == "S7_object") { return(NULL) } - return(S4_register(parent_class, env, contains = TRUE)) + return(S4_register(parent_class, env)) } else if (is_S4_class(parent_class)) { return(S4_class(parent_class, env)) } @@ -346,7 +373,7 @@ S4_reified_old_classes <- function(class) { class_dispatch(class) } -S4_validate_reified_class <- function(object) { +S4_validate_class <- function(object) { class_name <- class(object)[1L] class <- S7_class(object) @@ -385,6 +412,10 @@ S4_validate <- function(object) { } S4_initialize <- function(.Object, ...) { + if (isS4(.Object) && has_S7_class(.Object)) { + S4_check_contains(S7_class(.Object)) + } + args <- list(...) if (length(args) == 0) { return(.Object) diff --git a/R/class.R b/R/class.R index 836b60f2a..7f2782737 100644 --- a/R/class.R +++ b/R/class.R @@ -64,7 +64,7 @@ #' S7 objects that directly extend S4 are represented as S3 old-class objects, #' so `isS4()` is `FALSE` even though [methods::is()] and S4 dispatch see the #' S4 parent. S4 classes can extend S7 classes by calling -#' [S4_register()] with `contains = TRUE`. +#' [S4_contains()] in `methods::setClass(contains = )`. #' #' See `vignette("compatibility")` for examples and caveats. #' @return A object constructor, a function that can be used to create objects diff --git a/man/S4_register.Rd b/man/S4_register.Rd index 00b0e3dcb..7c5edcfcb 100644 --- a/man/S4_register.Rd +++ b/man/S4_register.Rd @@ -2,9 +2,12 @@ % Please edit documentation in R/S4.R \name{S4_register} \alias{S4_register} +\alias{S4_contains} \title{Register an S7, S3, or union class with S4} \usage{ -S4_register(class, env = parent.frame(), contains = FALSE) +S4_register(class, env = parent.frame()) + +S4_contains(class, env = parent.frame()) } \arguments{ \item{class}{An S7 class created with \code{\link[=new_class]{new_class()}}, or, for @@ -12,9 +15,6 @@ S4_register(class, env = parent.frame(), contains = FALSE) union created with \code{\link[=new_union]{new_union()}}.} \item{env}{Expert use only. Environment where S4 class will be registered.} - -\item{contains}{If \code{TRUE}, create the heavier S4 class needed for S4 classes -to extend an S7 class. This exposes stored S7 properties as S4 slots.} } \value{ Called for its side effects and invisibly returns the registered S4 class @@ -30,13 +30,15 @@ an S7 class that does not extend an S4 class, or an S3 class created by \code{S4_register()} registers an S7 class, S3 class, or S7 union with S4 and invisibly returns the registered S4 class name. +For S7 classes, this creates a virtual S4 old class that exposes stored S7 +properties as S4 slots and carries the \code{S7_class} slot needed for S7 dispatch +and validation. -Use \code{S4_register(contains = TRUE)} when an S4 class should extend an S7 -class with \code{methods::setClass(contains = )}. This creates a virtual S4 class -that exposes stored S7 properties as S4 slots and carries the \code{S7_class} slot -needed for S7 dispatch and validation. Do not instantiate it directly. +After registration, \code{S4_contains()} returns the virtual S4 class name to use +when an S4 class should extend an S7 class with +\code{methods::setClass(contains = )}. It asserts that the S7 properties can +safely cross the S4 inheritance boundary. -Properties with custom getters or setters cannot be represented as S4 slots. Register S7 unions with \code{S4_register()} before using them in S4 slots or method signatures unless an equivalent S4 union already exists. @@ -55,6 +57,7 @@ method(S4_generic, Foo) <- function(x) "Hello" S4_generic(Foo()) S4Foo := new_class(properties = list(x = class_numeric), package = "S7") -S4Foo_S4 <- S4_register(S4Foo, contains = TRUE) +S4_register(S4Foo) +S4Foo_S4 <- S4_contains(S4Foo) methods::setClass("S4Child", contains = S4Foo_S4) } diff --git a/man/new_class.Rd b/man/new_class.Rd index f81dafa92..304cbda7c 100644 --- a/man/new_class.Rd +++ b/man/new_class.Rd @@ -102,7 +102,7 @@ S4 automatically, and S4 generics can dispatch through the S4 parent. S7 objects that directly extend S4 are represented as S3 old-class objects, so \code{isS4()} is \code{FALSE} even though \code{\link[methods:is]{methods::is()}} and S4 dispatch see the S4 parent. S4 classes can extend S7 classes by calling -\code{\link[=S4_register]{S4_register()}} with \code{contains = TRUE}. +\code{\link[=S4_contains]{S4_contains()}} in \code{methods::setClass(contains = )}. See \code{vignette("compatibility")} for examples and caveats. } diff --git a/tests/testthat/test-S4.R b/tests/testthat/test-S4.R index a99d9fcac..7bc2d5245 100644 --- a/tests/testthat/test-S4.R +++ b/tests/testthat/test-S4.R @@ -11,6 +11,23 @@ test_that("S4_register registers an S7 class so it can be used with S4 methods", expect_contains(methods::extends("S4regS7"), c("S4regS7", "S7_object")) }) +test_that("S4_contains requires prior S4 registration", { + on.exit(S4_remove_classes("S4regContainsUnregistered")) + S4regContainsUnregistered := new_class(package = NULL) + + expect_error( + S4_contains(S4regContainsUnregistered), + "has not been registered" + ) + expect_false(methods::isClass("S4regContainsUnregistered")) + + S4_register(S4regContainsUnregistered) + expect_equal( + S4_contains(S4regContainsUnregistered), + "S4regContainsUnregistered" + ) +}) + test_that("S4_register registers S4 old classes as virtual S7_object descendants", { on.exit(S4_remove_classes(c("S4regParent", "S4regS7New"))) setClass("S4regParent", slots = list(x = "numeric")) @@ -95,7 +112,7 @@ test_that("S4_register can reify S7 properties as slots for S4 subclasses", { ) S4regContainsChild_old <- S4_register(S4regContainsChild) - S4regContainsChild_S4 <- S4_register(S4regContainsChild, contains = TRUE) + S4regContainsChild_S4 <- S4_contains(S4regContainsChild) expect_equal(S4regContainsChild_S4, "S7::S4regContainsChild") expect_equal( methods::slotNames(S4regContainsChild_S4), @@ -204,7 +221,7 @@ test_that("S4_register constructs S4 subclasses of S7 classes that extend S4 cla }, package = NULL ) - S4regNewChild_S4 <- S4_register(S4regNewChild, contains = TRUE) + S4regNewChild_S4 <- S4_contains(S4regNewChild) expect_equal( methods::slotNames("S4regNewChild"), c("status", "metadata", "S7_class", "assays", "rowData", ".S3Class") @@ -265,7 +282,7 @@ test_that("S4_register constructs S4 subclasses of S7 classes that extend S4 cla expect_error(methods::validObject(invalid), "bad status") }) -test_that("S4_validate_reified_class validates only matching S7 classes for S4 upcasts", { +test_that("S4_validate_class validates only matching S7 classes for S4 upcasts", { on.exit(S4_remove_classes(c( "S4regShimRoot", "S4regShimParent", @@ -289,8 +306,8 @@ test_that("S4_validate_reified_class validates only matching S7 classes for S4 u package = "S7" ) - S4regShimParent_S4 <- S4_register(S4regShimParent, contains = TRUE) - S4regShimChild_S4 <- S4_register(S4regShimChild, contains = TRUE) + S4regShimParent_S4 <- S4_contains(S4regShimParent) + S4regShimChild_S4 <- S4_contains(S4regShimChild) setClass("S4regShimParent", contains = S4regShimParent_S4) setClass( "S4regShimChild", @@ -339,10 +356,7 @@ test_that("S4_register registers abstract S7 classes as virtual S4 classes", { package = NULL ) method(dim, S4regAbstractConcrete) <- function(x) c(x@x, 2L) - S4regAbstractConcrete_S4 <- S4_register( - S4regAbstractConcrete, - contains = TRUE - ) + S4regAbstractConcrete_S4 <- S4_contains(S4regAbstractConcrete) setClass("S4regAbstractShim", contains = S4regAbstractConcrete_S4) object <- methods::new("S4regAbstractShim", x = 1L) @@ -380,7 +394,8 @@ test_that("S4_register uses S7 property defaults as S4 prototypes", { ), package = NULL ) - S4regPrototype_S4 <- S4_register(S4regPrototype, contains = TRUE) + S4_register(S4regPrototype) + S4regPrototype_S4 <- S4_contains(S4regPrototype) methods::setClass("S4regPrototypeChild", contains = S4regPrototype_S4) object <- methods::new("S4regPrototypeChild") @@ -409,7 +424,8 @@ test_that("S4_register treats S4 NULL slot sentinels as NULL-valued S7 propertie ), package = NULL ) - S4regNullable_S4 <- S4_register(S4regNullable, contains = TRUE) + S4_register(S4regNullable) + S4regNullable_S4 <- S4_contains(S4regNullable) methods::setClass("S4regNullableChild", contains = S4regNullable_S4) object <- methods::new("S4regNullableChild") @@ -430,9 +446,11 @@ test_that("S4_register treats S4 NULL slot sentinels as NULL-valued S7 propertie expect_identical(attr(plain, "x", exact = TRUE), as.name("\001NULL\001")) }) -test_that("S4_register rejects properties that can not be represented as slots", { +test_that("S4_contains rejects properties with custom accessors", { on.exit(S4_remove_classes(c( + "S4regContainsDynamicChild", "S7::S4regContainsDynamic", + "S4regContainsSetterChild", "S7::S4regContainsSetter" ))) @@ -443,8 +461,17 @@ test_that("S4_register rejects properties that can not be represented as slots", ), package = "S7" ) + expect_no_error(S4_register(S4regContainsDynamic)) expect_error( - S4_register(S4regContainsDynamic, contains = TRUE), + S4_contains(S4regContainsDynamic), + "custom getter" + ) + methods::setClass( + "S4regContainsDynamicChild", + contains = "S7::S4regContainsDynamic" + ) + expect_error( + methods::new("S4regContainsDynamicChild"), "custom getter" ) @@ -461,8 +488,17 @@ test_that("S4_register rejects properties that can not be represented as slots", ), package = "S7" ) + expect_no_error(S4_register(S4regContainsSetter)) + expect_error( + S4_contains(S4regContainsSetter), + "custom setter" + ) + methods::setClass( + "S4regContainsSetterChild", + contains = "S7::S4regContainsSetter" + ) expect_error( - S4_register(S4regContainsSetter, contains = TRUE), + methods::new("S4regContainsSetterChild"), "custom setter" ) }) @@ -479,15 +515,13 @@ test_that("S4_register uses registered S7 unions as S4 slots", { package = "S7" ) expect_error( - S4_register(S4regContainsUnion, contains = TRUE), + S4_register(S4regContainsUnion), "not been registered" ) S4_register(class_numeric | class_character) - S4regContainsUnion_S4 <- S4_register( - S4regContainsUnion, - contains = TRUE - ) + S4_register(S4regContainsUnion) + S4regContainsUnion_S4 <- S4_contains(S4regContainsUnion) expect_equal( as.character(methods::getClass(S4regContainsUnion_S4)@slots$x), "integer_OR_numeric_OR_character" @@ -523,10 +557,10 @@ test_that("S4_register uses matching S4 unions as S4 slots", { package = NULL ) - S4regContainsExistingUnion_S4 <- S4_register( + S4_register(S4regContainsExistingUnion, env) + S4regContainsExistingUnion_S4 <- S4_contains( S4regContainsExistingUnion, - env, - contains = TRUE + env ) expect_equal( as.character( @@ -666,7 +700,11 @@ test_that("S7 classes can extend S4 classes", { }) test_that("S4 initialization sets S4 slots on subclasses of S7 classes", { - on.exit(S4_remove_classes(c("ParentForSlots", "ChildForSlots", "S4ChildForSlots"))) + on.exit(S4_remove_classes(c( + "ParentForSlots", + "ChildForSlots", + "S4ChildForSlots" + ))) setClass("ParentForSlots", slots = list(x = "numeric")) ChildForSlots <- new_class( @@ -746,22 +784,30 @@ test_that("S4 initialize supports S3 data parts", { }) test_that("S4 classes can not extend S7-over-S4 classes with property setters", { - on.exit(S4_remove_classes(c("Parent2", "Child2"))) + on.exit(S4_remove_classes(c("Parent2", "Child2", "S4Child2"))) setClass("Parent2", slots = list(x = "numeric")) - expect_error( - new_class( - "Child2", - parent = getClass("Parent2"), - properties = list( - y = new_property(class_character, setter = function(self, value) { - attr(self, "setter_called") <- TRUE - attr(self, "y") <- value - self - }) - ), - package = NULL + Child2 <- new_class( + "Child2", + parent = getClass("Parent2"), + properties = list( + y = new_property(class_character, setter = function(self, value) { + attr(self, "setter_called") <- TRUE + attr(self, "y") <- value + self + }) ), + package = NULL + ) + expect_true(attr(Child2(x = 1, y = "a"), "setter_called", exact = TRUE)) + expect_error( + S4_contains(Child2), + "custom setter" + ) + + methods::setClass("S4Child2", contains = "Child2") + expect_error( + methods::new("S4Child2"), "custom setter" ) }) diff --git a/tests/testthat/test-method-register-S3.R b/tests/testthat/test-method-register-S3.R index 1da211aa2..a2a7aaffa 100644 --- a/tests/testthat/test-method-register-S3.R +++ b/tests/testthat/test-method-register-S3.R @@ -77,7 +77,7 @@ test_that("internal generics register S4 methods for S4-backed S7 classes", { package = NULL ) method(dim, S4regDimChild) <- function(x) c(x@x, 2L) - S4regDimChild_S4 <- S4_register(S4regDimChild, contains = TRUE) + S4regDimChild_S4 <- S4_contains(S4regDimChild) setClass("S4regDimShim", contains = S4regDimChild_S4) object <- methods::new("S4regDimShim", x = 1L) @@ -114,7 +114,7 @@ test_that("internal replacement generics can register full S4 signatures", { x@x <- value x } - S4regDimnamesChild_S4 <- S4_register(S4regDimnamesChild, contains = TRUE) + S4regDimnamesChild_S4 <- S4_contains(S4regDimnamesChild) setClass("S4regDimnamesShim", contains = S4regDimnamesChild_S4) object <- methods::new("S4regDimnamesShim", x = list(NULL, NULL)) diff --git a/vignettes/compatibility.Rmd b/vignettes/compatibility.Rmd index 056cd1e2a..d9b8e8add 100644 --- a/vignettes/compatibility.Rmd +++ b/vignettes/compatibility.Rmd @@ -216,10 +216,11 @@ There are a few important caveats: ### S4 classes that extend S7 classes -Use `S4_register(contains = TRUE)` when an S4 class should extend an S7 class. -It returns the virtual S4 class name for `methods::setClass(contains = )`. -This class exposes stored S7 properties as formal S4 slots and carries the -`S7_class` slot that S7 uses for dispatch and validation. +After calling `S4_register()`, use `S4_contains()` when an S4 class should +extend an S7 class. It returns the virtual S4 class name for +`methods::setClass(contains = )`. This class exposes stored S7 properties as +formal S4 slots and carries the `S7_class` slot that S7 uses for dispatch and +validation. ```{r} Sample <- new_class("Sample", @@ -236,7 +237,8 @@ Sample <- new_class("Sample", } ) -Sample_S4 <- S4_register(Sample, contains = TRUE) +S4_register(Sample) +Sample_S4 <- S4_contains(Sample) methods::setClass("ReplicatedSample", contains = Sample_S4, slots = c(replicate = "integer") @@ -266,7 +268,7 @@ method(sample_label, Sample) <- function(x) { sample_label(rs) ``` -The class returned by `S4_register(contains = TRUE)` is a compatibility layer, +The class returned by `S4_contains()` is a compatibility layer, not a user-facing class. Do not instantiate it directly; use it only as a superclass for another S4 class. Since S4 subclasses are real S4 objects, S4 code can access the S7 properties as slots. This is necessary for From abf31be773c3f459ae64a444ffb4fd1ac75e7ee4 Mon Sep 17 00:00:00 2001 From: Michael Lawrence Date: Sat, 20 Jun 2026 15:26:01 -0700 Subject: [PATCH 077/132] fix regression from introduction of external generics --- R/method-register-S4.R | 10 ++++++- tests/testthat/test-method-register-S3.R | 37 ++++++++++++++++++++++++ 2 files changed, 46 insertions(+), 1 deletion(-) diff --git a/R/method-register-S4.R b/R/method-register-S4.R index 89dd0f033..170e20da8 100644 --- a/R/method-register-S4.R +++ b/R/method-register-S4.R @@ -28,7 +28,10 @@ class_has_S4_ancestor <- function(class) { } S3_generic_S4_signature <- function(generic) { - if (!is_S3_generic(generic) || !is_internal_generic(generic$name)) { + if ( + !(is_S3_generic(generic) || is_external_S3_generic(generic)) || + !is_internal_generic(generic$name) + ) { return(NULL) } @@ -39,3 +42,8 @@ S3_generic_S4_signature <- function(generic) { generic@signature } + +is_external_S3_generic <- function(generic) { + is_external_generic(generic) && + identical(generic$dispatch_args, "__S3__") +} diff --git a/tests/testthat/test-method-register-S3.R b/tests/testthat/test-method-register-S3.R index a2a7aaffa..77ba65a5d 100644 --- a/tests/testthat/test-method-register-S3.R +++ b/tests/testthat/test-method-register-S3.R @@ -128,6 +128,43 @@ test_that("internal replacement generics can register full S4 signatures", { )) }) +test_that("sentinels for internal replacement generics keep full S4 signatures", { + on.exit(S4_remove_classes(c( + "S4regDimnamesSentinelParent", + "S4regDimnamesSentinelChild" + ))) + + setClass("S4regDimnamesSentinelParent", contains = "VIRTUAL") + S4regDimnamesSentinelChild <- new_class( + "S4regDimnamesSentinelChild", + parent = getClass("S4regDimnamesSentinelParent"), + properties = list(x = class_list), + package = NULL + ) + + dimnames_sentinel <- generic_sentinel(as_generic(`dimnames<-`)) + expect_no_error( + register_method( + dimnames_sentinel, + list(S4regDimnamesSentinelChild, class_list), + function(x, value) x, + package = NULL + ) + ) + on.exit( + methods::removeMethod( + "dimnames<-", + c("S4regDimnamesSentinelChild", "list") + ), + add = TRUE, + after = FALSE + ) + expect_true(methods::hasMethod( + "dimnames<-", + c("S4regDimnamesSentinelChild", "list") + )) +}) + test_that("S3 registration for a multi-class S3 class uses only the first class", { local_s3_generic("s3_gen") method(s3_gen, new_S3_class(c("ordered", "factor"))) <- function(x) "ord" From c88c241bcc4f465f063e05fdfb4dea12511fcb76 Mon Sep 17 00:00:00 2001 From: Michael Lawrence Date: Mon, 22 Jun 2026 18:06:36 -0700 Subject: [PATCH 078/132] update for rename of @S7_class to @_S7_class --- R/S4.R | 8 ++++---- R/convert.R | 5 ++++- R/inherits.R | 2 +- R/property.R | 2 +- man/S4_register.Rd | 2 +- tests/testthat/test-S4.R | 23 +++++++++++++---------- vignettes/compatibility.Rmd | 4 ++-- 7 files changed, 26 insertions(+), 20 deletions(-) diff --git a/R/S4.R b/R/S4.R index 46486a11d..b97666ccf 100644 --- a/R/S4.R +++ b/R/S4.R @@ -9,7 +9,7 @@ #' `S4_register()` registers an S7 class, S3 class, or S7 union with S4 and #' invisibly returns the registered S4 class name. #' For S7 classes, this creates a virtual S4 old class that exposes stored S7 -#' properties as S4 slots and carries the `S7_class` slot needed for S7 dispatch +#' properties as S4 slots and carries the `_S7_class` slot needed for S7 dispatch #' and validation. #' #' After registration, `S4_contains()` returns the virtual S4 class name to use @@ -270,7 +270,7 @@ S4_properties_prototype <- function( } } if (include_S7_class) { - args$S7_class <- class + args$`_S7_class` <- class } do.call(methods::prototype, args) } @@ -320,9 +320,9 @@ S4_register_class <- function(class, env = parent.frame()) { properties <- class@properties properties <- properties[setdiff(names(properties), parent_slot_names)] slots <- lapply(properties, S4_property_class, S4_env = where) - needs_S7_class_slot <- !"S7_class" %in% parent_slot_names + needs_S7_class_slot <- !"_S7_class" %in% parent_slot_names if (needs_S7_class_slot) { - slots$S7_class <- "S7_class" + slots$`_S7_class` <- "S7_class" } methods::setClass( diff --git a/R/convert.R b/R/convert.R index e2abf2c45..82bb4100a 100644 --- a/R/convert.R +++ b/R/convert.R @@ -187,7 +187,10 @@ convert_up <- function(from, to, call = sys.call(-1L)) { stop2(msg, call = call) } - from <- zap_attr(from, c(setdiff(from_props, to_props), "S7_class")) + from <- zap_attr( + from, + c(setdiff(from_props, to_props), "_S7_class", "S7_class") + ) attr(from, "_S7_class") <- to class(from) <- class_dispatch(to) } else if (is_S4_coerce(from, to)) { diff --git a/R/inherits.R b/R/inherits.R index 9d5501d05..5dfb269ef 100644 --- a/R/inherits.R +++ b/R/inherits.R @@ -49,7 +49,7 @@ S7_inherits <- function(x, class = NULL) { has_S7_class <- function(x) { identical(class(x), "S7_object") || inherits(x, "S7_class") || - !is.null(attr(x, "S7_class", exact = TRUE)) + !is.null(.Call(S7_class_, x)) } #' @export diff --git a/R/property.R b/R/property.R index 181ea69ec..948146bd8 100644 --- a/R/property.R +++ b/R/property.R @@ -365,7 +365,7 @@ prop_call <- function(object, name) { #' @rawNamespace S3method("@<-",S7_object) `@<-.S7_object` <- function(object, name, value) { - if (isS4(object) && !name %in% names(slot(object, "S7_class")@properties)) { + if (isS4(object) && !name %in% names(S7_class(object)@properties)) { methods::slot(object, name) <- value return(object) } diff --git a/man/S4_register.Rd b/man/S4_register.Rd index 7c5edcfcb..6b641b790 100644 --- a/man/S4_register.Rd +++ b/man/S4_register.Rd @@ -31,7 +31,7 @@ an S7 class that does not extend an S4 class, or an S3 class created by \code{S4_register()} registers an S7 class, S3 class, or S7 union with S4 and invisibly returns the registered S4 class name. For S7 classes, this creates a virtual S4 old class that exposes stored S7 -properties as S4 slots and carries the \code{S7_class} slot needed for S7 dispatch +properties as S4 slots and carries the \code{_S7_class} slot needed for S7 dispatch and validation. After registration, \code{S4_contains()} returns the virtual S4 class name to use diff --git a/tests/testthat/test-S4.R b/tests/testthat/test-S4.R index 7bc2d5245..f5cec3039 100644 --- a/tests/testthat/test-S4.R +++ b/tests/testthat/test-S4.R @@ -43,7 +43,7 @@ test_that("S4_register registers S4 old classes as virtual S7_object descendants "trying to generate an object from a virtual class" ) expect_true(methods::extends("S4regS7New", "S7_object")) - expect_true("S7_class" %in% methods::slotNames("S4regS7New")) + expect_true("_S7_class" %in% methods::slotNames("S4regS7New")) }) test_that("S4_register registers an S3 class so it can be used with S4 methods", { @@ -116,7 +116,7 @@ test_that("S4_register can reify S7 properties as slots for S4 subclasses", { expect_equal(S4regContainsChild_S4, "S7::S4regContainsChild") expect_equal( methods::slotNames(S4regContainsChild_S4), - c("y", "x", "S7_class", ".S3Class") + c("y", "x", "_S7_class", ".S3Class") ) expect_contains( methods::extends(S4regContainsChild_S4), @@ -138,7 +138,7 @@ test_that("S4_register can reify S7 properties as slots for S4 subclasses", { expect_equal(methods::slot(object, "x"), 1) expect_equal(methods::slot(object, "y"), "a") expect_equal(methods::slot(object, "z"), TRUE) - expect_equal(methods::slot(object, "S7_class"), S4regContainsChild) + expect_equal(methods::slot(object, "_S7_class"), S4regContainsChild) expect_equal(prop_names(object), c("x", "y")) expect_equal(prop(object, "x"), 1) expect_equal(prop(object, "y"), "a") @@ -224,11 +224,11 @@ test_that("S4_register constructs S4 subclasses of S7 classes that extend S4 cla S4regNewChild_S4 <- S4_contains(S4regNewChild) expect_equal( methods::slotNames("S4regNewChild"), - c("status", "metadata", "S7_class", "assays", "rowData", ".S3Class") + c("status", "metadata", "_S7_class", "assays", "rowData", ".S3Class") ) expect_contains( methods::slotNames(S4regNewChild_S4), - c("assays", "rowData", "metadata", "status", "S7_class") + c("assays", "rowData", "metadata", "status", "_S7_class") ) setClass( "S4regNewGrandChild", @@ -242,7 +242,7 @@ test_that("S4_register constructs S4 subclasses of S7 classes that extend S4 cla expect_true(methods::is(object, "S4regNewParent")) expect_true(methods::is(object, S4regNewChild_S4)) expect_true(S7_inherits(object, S4regNewChild)) - expect_equal(methods::slot(object, "S7_class"), S4regNewChild) + expect_equal(methods::slot(object, "_S7_class"), S4regNewChild) expect_equal(methods::slot(object, "assays"), list()) expect_equal(methods::slot(object, "rowData"), character()) expect_equal(methods::slot(object, "metadata"), character()) @@ -364,12 +364,12 @@ test_that("S4_register registers abstract S7 classes as virtual S4 classes", { concrete_prototype <- methods::getClass("S4regAbstractConcrete")@prototype expect_true(methods::isVirtualClass("S4regAbstract")) - expect_true("S7_class" %in% methods::slotNames("S4regAbstract")) - expect_equal(methods::slot(abstract_prototype, "S7_class"), S4regAbstract) + expect_true("_S7_class" %in% methods::slotNames("S4regAbstract")) + expect_equal(methods::slot(abstract_prototype, "_S7_class"), S4regAbstract) expect_false(methods::extends("S4regAbstract", "oldClass")) expect_false(methods::extends("S4regAbstract", "S7_object")) expect_equal( - methods::slot(concrete_prototype, "S7_class"), + methods::slot(concrete_prototype, "_S7_class"), S4regAbstractConcrete ) expect_false("S4regAbstract" %in% attr(concrete_prototype, ".S3Class")) @@ -672,7 +672,10 @@ test_that("S7 classes can extend S4 classes", { expect_true(methods::is(child, "Parent")) expect_true(methods::validObject(child)) expect_equal(as.character(methods::getClass("Child")@className), "Child") - expect_equal(methods::slotNames("Child"), c("y", "S7_class", "x", ".S3Class")) + expect_equal( + methods::slotNames("Child"), + c("y", "_S7_class", "x", ".S3Class") + ) expect_equal(methods::slot(child, "x"), 2) expect_equal(methods::slot(child, "y"), "b") diff --git a/vignettes/compatibility.Rmd b/vignettes/compatibility.Rmd index d9b8e8add..b79a4e881 100644 --- a/vignettes/compatibility.Rmd +++ b/vignettes/compatibility.Rmd @@ -26,7 +26,7 @@ library(S7) S7 objects *are* S3 objects, because S7 is implemented on top of S3. There are two main differences between an S7 object and an S3 object: -- As well as the `class` attribute possessed by S3 objects, S7 objects have an additional `S7_class` attribute that contains the object that defines the class. +- As well as the `class` attribute possessed by S3 objects, S7 objects have an additional `_S7_class` attribute that contains the object that defines the class. - S7 objects have properties; S3 objects have attributes. Properties are implemented on top of attributes, so you can access them directly with `attr` and friends. @@ -219,7 +219,7 @@ There are a few important caveats: After calling `S4_register()`, use `S4_contains()` when an S4 class should extend an S7 class. It returns the virtual S4 class name for `methods::setClass(contains = )`. This class exposes stored S7 properties as -formal S4 slots and carries the `S7_class` slot that S7 uses for dispatch and +formal S4 slots and carries the `_S7_class` slot that S7 uses for dispatch and validation. ```{r} From 02a53485f4fd86c1ed54b11c173d8cc8850381ad Mon Sep 17 00:00:00 2001 From: Tomasz Kalinowski Date: Wed, 24 Jun 2026 09:14:37 -0400 Subject: [PATCH 079/132] Fix S4 bridge review findings [P1] Reject or fully register abstract S7 bridge classes: When `S4_contains()` is used with an abstract S7 class, `setClass()` creates a virtual S4 class with an `_S7_class` slot, but the early return skips `setOldClass()`, `setValidity()`, and `initialize`. A concrete S4 subclass of that bridge is then `S7_inherits()`-TRUE but lacks the `.S3Class`/`S7_object` marker used by the C property path, so calls like `prop(obj, "x")` can hang instead of returning or erroring. Either reject abstract classes in `S4_contains()` or register a consistent bridge before returning. `/Users/tomasz/github/RConsortium/S7/R/S4.R:341-342` [P1] Run S4 validity for S7 objects with S4 parents: For an S7 object that directly extends an S4 class, the object is an S3 old-class object (`isS4()` is FALSE), so this branch returns `NULL` and skips the S4 parent's validity method during construction and `validate()`. With `setValidity("Parent", ...)`, `Child <- new_class(parent = getClass("Parent"))` allows `Child(x = invalid)` even though `methods::validObject()` reports the parent invalid. The S4 validity needs to run for these old-class S7 descendants too. `/Users/tomasz/github/RConsortium/S7/R/class-spec.R:202-207` [P2] Preserve S4 slot prototypes when importing slots: When an S7 class extends an S4 parent whose slot has a prototype/default, the generated property has no default, so the S7 constructor falls back to the slot class's empty constructor instead of the S4 prototype. For example `setClass("P", slots = list(x = "numeric"), prototype = list(x = 10)); C <- new_class(parent = getClass("P"))` makes `C()` store `integer(0)` for `x`, while `methods::new("P")` uses `10`. `/Users/tomasz/github/RConsortium/S7/R/S4.R:529-531` [P2] Keep overridden inherited properties in S4 prototypes: This drops every property whose name is already present as an inherited S4 slot before computing the S4 prototype, including properties that the S7 subclass deliberately overrides. If `Child` overrides an inherited `x` default from 1 to 2, an S4 subclass created with `contains = S4_contains(Child)` still gets `x = 1` from the parent prototype while `Child()` gets `x = 2`; keep overridden property definitions in the prototype even when the slot itself is inherited. `/Users/tomasz/github/RConsortium/S7/R/S4.R:321` --- R/S4.R | 42 ++++++++++++++-- R/class-spec.R | 58 ++++++++++++++++++++-- tests/testthat/test-S4.R | 101 +++++++++++++++++++++++++++++++++++++++ 3 files changed, 192 insertions(+), 9 deletions(-) diff --git a/R/S4.R b/R/S4.R index b97666ccf..d079c8a2f 100644 --- a/R/S4.R +++ b/R/S4.R @@ -71,6 +71,9 @@ S4_contains <- function(class, env = parent.frame()) { msg <- sprintf("`class` must be an S7 class, not a %s.", obj_desc(class)) stop2(msg) } + if (class@abstract) { + stop2("S4 classes can not extend abstract S7 classes.", call = sys.call()) + } class_name <- as.character( S4_registered_class(class, where, call = sys.call())@className @@ -279,8 +282,10 @@ S4_property_prototype <- function(prop, env, package) { tryCatch( { value <- prop_default(prop, env, package) + value <- S4_decode_pseudo_null(value) if (is.call(value) || is.symbol(value)) { value <- eval(value, env) + value <- S4_decode_pseudo_null(value) } list(value) }, @@ -293,6 +298,10 @@ S4_property_prototype <- function(prop, env, package) { ) } +S4_decode_pseudo_null <- function(value) { + if (identical(value, as.name("\001NULL\001"))) NULL else value +} + S4_old_classes <- function(class) { subclasses <- character() while (is_class(class)) { @@ -318,8 +327,9 @@ S4_register_class <- function(class, env = parent.frame()) { } properties <- class@properties - properties <- properties[setdiff(names(properties), parent_slot_names)] - slots <- lapply(properties, S4_property_class, S4_env = where) + prototype_properties <- properties[setdiff(names(properties), ".Data")] + slot_properties <- properties[setdiff(names(properties), parent_slot_names)] + slots <- lapply(slot_properties, S4_property_class, S4_env = where) needs_S7_class_slot <- !"_S7_class" %in% parent_slot_names if (needs_S7_class_slot) { slots$`_S7_class` <- "S7_class" @@ -330,7 +340,7 @@ S4_register_class <- function(class, env = parent.frame()) { slots = slots, contains = c(parent_class_name, "VIRTUAL"), prototype = S4_properties_prototype( - properties, + prototype_properties, class, where, include_S7_class = TRUE @@ -520,18 +530,40 @@ S4_to_S7_class <- function(x, error_base = "", call = sys.call(-1L)) { } S4_slot_properties <- function(class) { - properties <- Map(S4_slot_property, class@slots, names(class@slots)) + properties <- Map( + S4_slot_property, + class@slots, + names(class@slots), + MoreArgs = list(owner = class) + ) names(properties) <- names(class@slots) properties } -S4_slot_property <- function(class, name) { +S4_slot_property <- function(class, name, owner) { new_property( class = S4_to_S7_class(methods::getClass(class)), + default = S4_slot_prototype_default(owner, name), name = name ) } +S4_slot_prototype_default <- function(class, name) { + if (identical(name, ".Data")) { + return(bquote( + methods::getClass(.(as.character(class@className)))@prototype@.Data + )) + } + + bquote( + attr( + methods::getClass(.(as.character(class@className)))@prototype, + .(name), + exact = TRUE + ) + ) +} + S4_basic_classes <- function() { list( NULL = NULL, diff --git a/R/class-spec.R b/R/class-spec.R index 8696185bf..0b9a8ac21 100644 --- a/R/class-spec.R +++ b/R/class-spec.R @@ -200,11 +200,12 @@ class_constructor <- function(.x) { class_validate <- function(class, object) { if (is_S4_class(class)) { - if (isS4(object)) { - check <- methods::validObject(object, test = TRUE) - return(if (isTRUE(check)) NULL else check) + if (!isS4(object) && has_S7_class(object)) { + return(S4_validate_old_class(class, object)) } - return(NULL) + + check <- methods::validObject(object, test = TRUE) + return(if (isTRUE(check)) NULL else check) } validator <- switch( @@ -222,6 +223,55 @@ class_validate <- function(class, object) { } } +S4_validate_old_class <- function(class, object) { + any_strings <- function(x) { + if (isTRUE(x)) character() else x + } + + errors <- character() + extends <- rev(class@contains) + for (ext in extends) { + super_class <- ext@superClass + if (!ext@simple && !methods::is(object, super_class)) { + next + } + + super_def <- methods::getClassDef(super_class) + if (is.null(super_def)) { + errors <- c( + errors, + sprintf( + "superclass %s not defined in the environment of the object's class", + dQuote(super_class) + ) + ) + break + } + + validity <- methods::getValidity(super_def) + if (is.function(validity)) { + errors <- c( + errors, + any_strings(validity(methods::as(object, super_class))) + ) + if (length(errors)) { + break + } + } + } + + validity <- methods::getValidity(class) + if (length(errors) == 0L && is.function(validity)) { + errors <- c(errors, any_strings(validity(object))) + } + + if (length(errors) == 0L) { + NULL + } else { + errors + } +} + #' Format a class specification as a string #' #' `S7_class_desc()` turns any [class specification][as_class] into a short, diff --git a/tests/testthat/test-S4.R b/tests/testthat/test-S4.R index f5cec3039..7d644327b 100644 --- a/tests/testthat/test-S4.R +++ b/tests/testthat/test-S4.R @@ -377,6 +377,26 @@ test_that("S4_register registers abstract S7 classes as virtual S4 classes", { expect_true(methods::validObject(object)) }) +test_that("S4_contains rejects abstract S7 classes", { + defer(S4_remove_classes(c( + "S4regAbstractContainsParent", + "S4regAbstractContains" + ))) + + setClass("S4regAbstractContainsParent", contains = "VIRTUAL") + S4regAbstractContains <- new_class( + "S4regAbstractContains", + parent = getClass("S4regAbstractContainsParent"), + abstract = TRUE, + package = NULL + ) + + expect_error( + S4_contains(S4regAbstractContains), + "abstract" + ) +}) + test_that("S4_register uses S7 property defaults as S4 prototypes", { on.exit(S4_remove_classes(c( "S4regPrototype", @@ -409,6 +429,57 @@ test_that("S4_register uses S7 property defaults as S4 prototypes", { expect_true(methods::validObject(object)) }) +test_that("S4 parents preserve slot prototypes in S7 constructors", { + defer(S4_remove_classes(c( + "S4regSlotPrototypeParent", + "S4regSlotPrototypeChild" + ))) + + setClass( + "S4regSlotPrototypeParent", + slots = list(x = "numeric"), + prototype = list(x = 10) + ) + S4regSlotPrototypeChild <- new_class( + "S4regSlotPrototypeChild", + parent = getClass("S4regSlotPrototypeParent"), + package = NULL + ) + + object <- S4regSlotPrototypeChild() + + expect_equal(methods::slot(object, "x"), 10) + expect_equal(prop(object, "x"), 10) +}) + +test_that("S4 prototypes use overridden inherited S7 property defaults", { + defer(S4_remove_classes(c( + "S4regOverrideParent", + "S4regOverrideChild", + "S4regOverrideShim" + ))) + + setClass( + "S4regOverrideParent", + slots = list(x = "numeric"), + prototype = list(x = 1) + ) + S4regOverrideChild <- new_class( + "S4regOverrideChild", + parent = getClass("S4regOverrideParent"), + properties = list(x = new_property(class_numeric, default = 2)), + package = NULL + ) + S4regOverrideChild_S4 <- S4_contains(S4regOverrideChild) + setClass("S4regOverrideShim", contains = S4regOverrideChild_S4) + + expect_equal(prop(S4regOverrideChild(), "x"), 2) + + object <- methods::new("S4regOverrideShim") + expect_equal(methods::slot(object, "x"), 2) + expect_equal(prop(object, "x"), 2) +}) + test_that("S4_register treats S4 NULL slot sentinels as NULL-valued S7 properties", { on.exit(S4_remove_classes(c( "S4regNullable", @@ -702,6 +773,36 @@ test_that("S7 classes can extend S4 classes", { expect_error(Child(x = "x", y = "a")) }) +test_that("S7 classes run S4 parent validity", { + defer(S4_remove_classes(c( + "S4regValidityParent", + "S4regValidityChild" + ))) + + setClass("S4regValidityParent", slots = list(x = "numeric")) + methods::setValidity("S4regValidityParent", function(object) { + if (length(methods::slot(object, "x")) != 1) { + "x must have length 1" + } else { + TRUE + } + }) + S4regValidityChild <- new_class( + "S4regValidityChild", + parent = getClass("S4regValidityParent"), + package = NULL + ) + + expect_error( + S4regValidityChild(x = numeric()), + "x must have length 1" + ) + + object <- S4regValidityChild(x = 1) + methods::slot(object, "x") <- numeric() + expect_error(validate(object), "x must have length 1") +}) + test_that("S4 initialization sets S4 slots on subclasses of S7 classes", { on.exit(S4_remove_classes(c( "ParentForSlots", From 77edc5d67a58a3b0bac7648ae1d64df5192b3fb7 Mon Sep 17 00:00:00 2001 From: Tomasz Kalinowski Date: Wed, 24 Jun 2026 09:29:41 -0400 Subject: [PATCH 080/132] Fix S4 compatibility review regressions MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Finding 1: <<>> [P2] Use `.Data` as the S4 data-part seed — /Users/tomasz/github/RConsortium/S7/R/constructor.R:24-28. When the S4 parent has a data part, such as `contains = "numeric"`, the generated constructor always passes the parent prototype as `_parent`; the user-supplied `.Data` is then handled as a normal property/attribute. As a result, `Child(.Data = 1)` still has the prototype data part (`as.vector()` is unchanged), and S4 validity or methods that inspect the data part see stale data. <<>> Finding 2: <<>> [P2] Drop `oldClass` from converted S3 class vectors — /Users/tomasz/github/RConsortium/S7/R/S4.R:518-519. For classes created with `setOldClass()`, `methods::extends(x)` includes the implementation superclass `"oldClass"`. Returning `new_S3_class(c(..., "oldClass"))` makes converted S4 slot/property classes reject normal S3 objects whose `class()` vector only contains the user classes, e.g. `c("foo", "bar")`. <<>> Finding 3: <<>> [P2] Don't reserve legacy `S7_class` properties — /Users/tomasz/github/RConsortium/S7/R/class.R:479-485. This now rejects a user property named `S7_class`, but the internal class object is stored in `_S7_class`, and the documented reason for that move is to avoid collisions with user-defined properties. Code that legitimately defines a `S7_class` property now fails in `new_class()` even though the current storage no longer needs that name. <<>> Finding 4: <<>> [P2] Read S4 slots by their public property names — /Users/tomasz/github/RConsortium/S7/src/prop.c:527-528. For S4 subclasses created via `S4_contains()`, formal slots are registered with the public property names, but `prop()` still maps names like `names`, `dim`, and `class` through `prop_storage_sym()`. In those cases construction writes `_names` while the formal S4 slot `names` remains at its prototype, so S4 code using `methods::slot()` sees stale data. <<>> --- R/S4.R | 2 +- R/class.R | 9 ---- R/constructor.R | 4 +- src/prop.c | 18 ++++++-- tests/testthat/test-S4.R | 82 +++++++++++++++++++++++++++++++++++++ tests/testthat/test-class.R | 12 ++++++ 6 files changed, 110 insertions(+), 17 deletions(-) diff --git a/R/S4.R b/R/S4.R index d079c8a2f..f928c4ae6 100644 --- a/R/S4.R +++ b/R/S4.R @@ -516,7 +516,7 @@ S4_to_S7_class <- function(x, error_base = "", call = sys.call(-1L)) { } } if (is_oldClass(x)) { - new_S3_class(methods::extends(x)) + new_S3_class(setdiff(methods::extends(x), "oldClass")) } else { x } diff --git a/R/class.R b/R/class.R index 7f2782737..d1011d138 100644 --- a/R/class.R +++ b/R/class.R @@ -475,15 +475,6 @@ check_prop_names <- function(properties, call = sys.call(-1L)) { if ("..." %in% nms) { stop2("Properties can't be named \"...\".", call = call) } - - if ("S7_class" %in% nms) { - msg <- paste0( - "Property can't use S7 reserved name: ", - "S7_class", - "." - ) - stop2(msg, call = call) - } } check_prop_overrides <- function( diff --git a/R/constructor.R b/R/constructor.R index 86e8403c0..973b0b92e 100644 --- a/R/constructor.R +++ b/R/constructor.R @@ -23,9 +23,7 @@ new_constructor <- function( s4_data_part <- is_S4_class(parent) && ".Data" %in% names(parent@slots) parent_call <- if (s4_data_part) { - bquote( - methods::getClass(.(as.character(parent@className)))@prototype@.Data - ) + quote(.Data) } else if (has_S7_symbols(envir, "S7_object")) { quote(S7_object()) } else { diff --git a/src/prop.c b/src/prop.c index 91045f323..95aa9302f 100644 --- a/src/prop.c +++ b/src/prop.c @@ -219,9 +219,16 @@ SEXP pseudo_null(void) { return pseudo_NULL; } +static inline +Rboolean prop_has_public_slot(SEXP object, SEXP name_sym) { + return Rf_isS4(object) && R_has_slot(object, name_sym); +} + static inline SEXP prop_get_storage(SEXP object, SEXP name_sym) { - SEXP value = Rf_getAttrib(object, name_sym); + SEXP value = prop_has_public_slot(object, name_sym) ? + R_do_slot(object, name_sym) : + Rf_getAttrib(object, prop_storage_sym(name_sym)); return value == pseudo_null() ? R_NilValue : value; } @@ -229,7 +236,10 @@ static inline SEXP prop_set_storage(SEXP object, SEXP name_sym, SEXP value) { if (value == R_NilValue) value = pseudo_null(); - Rf_setAttrib(object, name_sym, value); + if (prop_has_public_slot(object, name_sym)) + R_do_slot_assign(object, name_sym, value); + else + Rf_setAttrib(object, prop_storage_sym(name_sym), value); return object; } @@ -525,7 +535,7 @@ SEXP prop_(SEXP object, SEXP name) { } // try to resolve property from the object attributes - SEXP value = prop_get_storage(object, prop_storage_sym(name_sym)); + SEXP value = prop_get_storage(object, name_sym); // This is commented out because we currently have no way to distinguish between // a prop with a value of NULL, and a prop value that is unset/missing. @@ -610,7 +620,7 @@ SEXP prop_set_(SEXP object, SEXP name, SEXP check_sexp, SEXP value) { // don't use setter() if (should_validate_prop) prop_validate(property, value, object, name); - object = PROTECT(prop_set_storage(object, prop_storage_sym(name_sym), value)); + object = PROTECT(prop_set_storage(object, name_sym, value)); n_protected++; } diff --git a/tests/testthat/test-S4.R b/tests/testthat/test-S4.R index 7d644327b..f46c03169 100644 --- a/tests/testthat/test-S4.R +++ b/tests/testthat/test-S4.R @@ -713,6 +713,28 @@ test_that("converts S4 representation of S3 classes to S7 representation", { ) }) +test_that("S4 old-class slots accept normal S3 class vectors", { + defer(S4_remove_classes(c( + "S4regOldSlotChild", + "S4regOldSlotParent", + "S4regOldFoo", + "S4regOldBar" + ))) + + setOldClass(c("S4regOldFoo", "S4regOldBar")) + setClass("S4regOldSlotParent", slots = list(x = "S4regOldFoo")) + S4regOldSlotChild <- new_class( + "S4regOldSlotChild", + parent = getClass("S4regOldSlotParent"), + package = NULL + ) + x <- structure(list(), class = c("S4regOldFoo", "S4regOldBar")) + + object <- S4regOldSlotChild(x = x) + + expect_equal(prop(object, "x"), x) +}) + test_that("errors on non-S4 classes", { expect_snapshot(S4_to_S7_class(1), error = TRUE) }) @@ -887,6 +909,66 @@ test_that("S4 initialize supports S3 data parts", { expect_true(methods::validObject(child)) }) +test_that("S4 data part constructors use the .Data argument", { + defer(S4_remove_classes(c( + "S4regDataPartParent", + "S4regDataPartChild" + ))) + + setClass("S4regDataPartParent", contains = "numeric") + methods::setValidity("S4regDataPartParent", function(object) { + if (!identical(as.vector(object), 1)) { + "data part must be 1" + } else { + TRUE + } + }) + S4regDataPartChild <- new_class( + "S4regDataPartChild", + parent = getClass("S4regDataPartParent"), + package = NULL + ) + + object <- S4regDataPartChild(.Data = 1) + + expect_equal(as.vector(object), 1) + expect_equal(prop(object, ".Data"), 1) + expect_true(methods::validObject(object)) +}) + +test_that("S4 subclasses read and write special-named S7 property slots", { + defer(S4_remove_classes(c( + "S4regSpecialSlotsChild", + "S4regSpecialSlots" + ))) + + S4regSpecialSlots <- new_class( + "S4regSpecialSlots", + properties = list( + names = class_character, + dim = class_integer + ), + package = NULL + ) + S4_register(S4regSpecialSlots) + S4regSpecialSlots_S4 <- S4_contains(S4regSpecialSlots) + setClass("S4regSpecialSlotsChild", contains = S4regSpecialSlots_S4) + + object <- methods::new( + "S4regSpecialSlotsChild", + names = "n", + dim = 2L + ) + + expect_equal(methods::slot(object, "names"), "n") + expect_equal(methods::slot(object, "dim"), 2L) + expect_equal(prop(object, "names"), "n") + + prop(object, "names") <- "updated" + expect_equal(methods::slot(object, "names"), "updated") + expect_equal(prop(object, "names"), "updated") +}) + test_that("S4 classes can not extend S7-over-S4 classes with property setters", { on.exit(S4_remove_classes(c("Parent2", "Child2", "S4Child2"))) setClass("Parent2", slots = list(x = "numeric")) diff --git a/tests/testthat/test-class.R b/tests/testthat/test-class.R index b95fc1370..86115ec97 100644 --- a/tests/testthat/test-class.R +++ b/tests/testthat/test-class.R @@ -73,6 +73,18 @@ test_that("S7 classes can inherit from S4 but not class unions", { ) }) +test_that("S7_class can be used as a property name", { + foo <- new_class( + "foo", + properties = list(S7_class = class_numeric), + package = NULL + ) + object <- foo(S7_class = 1) + + expect_equal(prop(object, "S7_class"), 1) + expect_equal(S7_class(object), foo) +}) + test_that("inheritance combines properties for parent classes", { foo1 := new_class(properties = list(x = class_double)) foo2 := new_class(foo1, properties = list(y = class_double)) From ca4f885ea4325d466f8ca59a4527660b17e8f91e Mon Sep 17 00:00:00 2001 From: Tomasz Kalinowski Date: Wed, 24 Jun 2026 09:56:51 -0400 Subject: [PATCH 081/132] Fix S4 compatibility regressions MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Finding 1: [P2] Treat ordered old-class representations as S3 — /Users/tomasz/github/RConsortium/S7/R/S4.R:620-621: With the new is_oldClass() check, getClass('ordered') is no longer treated as an S3 old-class representation because its prototype .S3Class is factor, not ordered. As a result, method(g, getClass('ordered')) <- ... registers an S4 signature that does not dispatch for ordinary ordered factors, regressing the previous old-class path; keep these S3 old-class representations converting to new_S3_class() while still excluding the new S7 compatibility classes. Finding 2: [P2] Downcast S4 parents by slots, not .data — /Users/tomasz/github/RConsortium/S7/R/convert.R:131-132: When from is an S4 parent and to is an S7 class that extends it, is_down_cast() is true, so execution enters convert_down() before this S4 coercion fallback. convert_down() still treats non-S7 from values as base/S3 and passes them as .data, but the generated S7-over-S4 constructor expects the S4 slot/property arguments, so convert(new('P', x = 1), Child, y = 'a') errors with an unused .data; handle S4 parents before the generic downcast path or copy their slots in convert_down(). Finding 3: [P2] Preserve S4 objects when updating data parts — /Users/tomasz/github/RConsortium/S7/R/S4.R:485-489: When .Object is a real S4 subclass of an S7 class with an S4 data part, this helper replaces the S4 instance with the bare .Data vector and copied attributes. Constructing such a subclass with .Data = ... then operates on a malformed object and can hang instead of returning an S4 instance with its slots intact; update the data part in place for S4 objects rather than replacing .Object. Finding 4: [P2] Preserve S4-only slots from unnamed initializers — /Users/tomasz/github/RConsortium/S7/R/S4.R:443-443: When an unnamed initializer is an existing S4 subclass, this path keeps only S7 properties from the initializer and never copies child-only S4 slots. new('Child', existing_child) therefore resets those S4-only slots to prototypes instead of preserving them like normal S4 initialization; split unnamed S4 slot values into s4_vals instead of discarding them. Finding 5: [P2] Allow S7-over-S4 classes to narrow S4 slots — /Users/tomasz/github/RConsortium/S7/R/class.R:148-151: Now that S4 parent slots are converted into parent_props, overriding a slot with an S7 class that itself extends the slot's S4 class is rejected by check_prop_overrides() because class_extends() only accepts S4-vs-S4 narrowing. For example, a Kennel S4 slot of class Animal cannot be narrowed to an S7 Dog class whose parent is getClass('Animal'); allow S7-over-S4 classes in the override check. --- R/S4.R | 55 ++++++++++++++++++++++++++++------- R/class-spec.R | 10 +++++-- R/convert.R | 14 +++++++++ tests/testthat/test-S4.R | 44 ++++++++++++++++++++++++++++ tests/testthat/test-class.R | 15 ++++++++++ tests/testthat/test-convert.R | 19 ++++++++++++ 6 files changed, 144 insertions(+), 13 deletions(-) diff --git a/R/S4.R b/R/S4.R index f928c4ae6..af1e3c7bc 100644 --- a/R/S4.R +++ b/R/S4.R @@ -434,20 +434,30 @@ S4_initialize <- function(.Object, ...) { nms <- names2(args) prop_nms <- prop_names(.Object) vals <- list() + s4_vals <- list() + s4_slot_nms <- character() + if (isS4(.Object)) { + s4_slot_nms <- setdiff(methods::slotNames(.Object), prop_nms) + } data_part <- NULL for (arg in args[nms == ""]) { arg_vals <- S4_initialize_values(arg) if (".Data" %in% names(arg_vals)) { - data_part <- arg + data_part <- if (isS4(arg)) arg_vals$.Data else arg + } + if (isS4(arg)) { + arg_s4_vals <- arg_vals[names(arg_vals) %in% s4_slot_nms] + s4_vals <- modify_list(s4_vals, arg_s4_vals) } arg_vals <- arg_vals[names(arg_vals) %in% prop_nms] vals <- modify_list(vals, arg_vals) } named_args <- args[nms != ""] - s4_vals <- list() - if (isS4(.Object)) { - s4_slot_nms <- setdiff(methods::slotNames(.Object), prop_nms) - s4_vals <- named_args[names(named_args) %in% s4_slot_nms] + if (length(s4_slot_nms) > 0L) { + s4_vals <- modify_list( + s4_vals, + named_args[names(named_args) %in% s4_slot_nms] + ) named_args <- named_args[!names(named_args) %in% s4_slot_nms] } vals <- modify_list(vals, named_args) @@ -467,11 +477,11 @@ S4_initialize <- function(.Object, ...) { } S4_initialize_values <- function(object) { - if (S7_inherits(object)) { - props(object) - } else if (isS4(object)) { + if (isS4(object)) { slots <- methods::slotNames(object) stats::setNames(lapply(slots, methods::slot, object = object), slots) + } else if (S7_inherits(object)) { + props(object) } else { attrs <- attributes(object) %||% list() attrs$class <- NULL @@ -485,6 +495,12 @@ S4_initialize_values <- function(object) { S4_initialize_data_part <- function(value, object) { incoming <- attributes(value) %||% list() incoming$class <- NULL + if (isS4(object)) { + methods::slot(object, ".Data") <- unclass(value) + attributes(object) <- modify_list(attributes(object), incoming) + return(object) + } + attributes(value) <- modify_list(attributes(object), incoming) value } @@ -515,8 +531,8 @@ S4_to_S7_class <- function(x, error_base = "", call = sys.call(-1L)) { return(basic_classes[[x@className]]) } } - if (is_oldClass(x)) { - new_S3_class(setdiff(methods::extends(x), "oldClass")) + if (is_S3_oldClass(x)) { + new_S3_class(S3_oldClass_classes(x)) } else { x } @@ -621,6 +637,25 @@ is_oldClass <- function(x) { x@className %in% attr(x@prototype, ".S3Class") } +is_S3_oldClass <- function(x) { + methods::extends(x, "oldClass") && + !"_S7_class" %in% names(x@slots) && + (is_oldClass(x) || is_ordered_oldClass(x)) +} + +is_ordered_oldClass <- function(x) { + identical(as.character(x@className), "ordered") && + identical(attr(x@prototype, ".S3Class"), "factor") +} + +S3_oldClass_classes <- function(x) { + class <- attr(x@prototype, ".S3Class") + if (!x@className %in% class) { + class <- c(as.character(x@className), class) + } + class +} + S4_class_name <- function(x) { if (is_oldClass(x)) { return(x@className) diff --git a/R/class-spec.R b/R/class-spec.R index 0b9a8ac21..97ddf46bc 100644 --- a/R/class-spec.R +++ b/R/class-spec.R @@ -396,9 +396,13 @@ class_extends <- function(child, parent) { # as a parent, NULL only accepts NULL is.null(child) } else if (is_S4_class(child) || is_S4_class(parent)) { - is_S4_class(child) && - is_S4_class(parent) && - methods::extends(child@className, parent@className) + if (!is_S4_class(parent)) { + FALSE + } else { + child <- if (is_S4_class(child)) child else S4_ancestor(child) + !is.null(child) && + methods::extends(child@className, parent@className) + } } else if (is_class(parent) && parent@name == "S7_object") { is_class(child) } else { diff --git a/R/convert.R b/R/convert.R index 82bb4100a..69add8218 100644 --- a/R/convert.R +++ b/R/convert.R @@ -209,6 +209,20 @@ convert_down <- function(from, to, user_args = list()) { from_class <- S7_class(from) if (!is_class(from_class)) { + if (isS4(from)) { + from_slot_values <- S4_initialize_values(from) + from_slot_names <- names(from_slot_values) + + to_constructor_arg_names <- names(formals(to)) + if (!"..." %in% to_constructor_arg_names) { + from_slot_names <- intersect(from_slot_names, to_constructor_arg_names) + } + + from_slot_names <- setdiff(from_slot_names, names(user_args)) + constructor_args <- c(from_slot_values[from_slot_names], user_args) + return(do.call(to, constructor_args)) + } + # `from` is a base or S3 object; pass it as `.data` to the constructor user_args$.data <- from return(do.call(to, user_args)) diff --git a/tests/testthat/test-S4.R b/tests/testthat/test-S4.R index f46c03169..ada0b80f0 100644 --- a/tests/testthat/test-S4.R +++ b/tests/testthat/test-S4.R @@ -713,6 +713,13 @@ test_that("converts S4 representation of S3 classes to S7 representation", { ) }) +test_that("S4 old-class representations dispatch as S3 class vectors", { + S4regOrderedGeneric := new_generic(dispatch_args = "x") + method(S4regOrderedGeneric, getClass("ordered")) <- function(x) "ordered" + + expect_equal(S4regOrderedGeneric(ordered("a")), "ordered") +}) + test_that("S4 old-class slots accept normal S3 class vectors", { defer(S4_remove_classes(c( "S4regOldSlotChild", @@ -859,6 +866,10 @@ test_that("S4 initialization sets S4 slots on subclasses of S7 classes", { child@y <- "d" expect_equal(methods::slot(child, "z"), "c") expect_equal(prop(child, "y"), "d") + + child <- methods::new("S4ChildForSlots", child) + expect_equal(methods::slot(child, "z"), "c") + expect_equal(prop(child, "y"), "d") }) test_that("@<- sets S4-only slots on subclasses of S7 classes", { @@ -936,6 +947,39 @@ test_that("S4 data part constructors use the .Data argument", { expect_true(methods::validObject(object)) }) +test_that("S4 data part initialization preserves S4 subclasses", { + defer(S4_remove_classes(c( + "S4regDataPartGrandChild", + "S4regDataPartChild", + "S4regDataPartParent" + ))) + + setClass("S4regDataPartParent", contains = "numeric") + S4regDataPartChild := new_class( + parent = getClass("S4regDataPartParent"), + properties = list(y = class_character), + package = NULL + ) + setClass( + "S4regDataPartGrandChild", + slots = list(z = "logical"), + contains = "S4regDataPartChild" + ) + + object <- methods::new( + "S4regDataPartGrandChild", + .Data = 1, + y = "a", + z = TRUE + ) + + expect_s4_class(object, "S4regDataPartGrandChild") + expect_equal(as.vector(object), 1) + expect_equal(prop(object, "y"), "a") + expect_equal(methods::slot(object, "z"), TRUE) + expect_true(methods::validObject(object)) +}) + test_that("S4 subclasses read and write special-named S7 property slots", { defer(S4_remove_classes(c( "S4regSpecialSlotsChild", diff --git a/tests/testthat/test-class.R b/tests/testthat/test-class.R index 86115ec97..a40ddfcf1 100644 --- a/tests/testthat/test-class.R +++ b/tests/testthat/test-class.R @@ -130,6 +130,21 @@ test_that("inheritance lets child properties narrow with S4 inheritance", { expect_s4_class(Child(x = x)@x, "S4PropertyChild") }) +test_that("inheritance lets child properties narrow S4 slots with S7-over-S4 classes", { + 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 doesn't let child properties narrow S7_object with base or S3 classes", { Parent <- new_class( "Parent", diff --git a/tests/testthat/test-convert.R b/tests/testthat/test-convert.R index 37298acdc..5e3306922 100644 --- a/tests/testthat/test-convert.R +++ b/tests/testthat/test-convert.R @@ -155,6 +155,25 @@ test_that("fallback convert can convert_up() an S4-derived S7 object to an S4 ob expect_equal(methods::slot(parent, "x"), 10) }) +test_that("fallback convert can convert_down() an S4 object to an S7 child", { + local_methods(convert) + on.exit(S4_remove_classes(c("ParentS4", "ChildS7"))) + setClass("ParentS4", slots = list(x = "numeric")) + + ChildS7 := new_class( + parent = getClass("ParentS4"), + properties = list(y = class_character), + package = NULL + ) + + parent <- methods::new("ParentS4", x = 10) + child <- convert(parent, to = ChildS7, y = "a") + + expect_true(S7_inherits(child, ChildS7)) + expect_equal(prop(child, "x"), 10) + expect_equal(prop(child, "y"), "a") +}) + test_that("fallback convert can use explicit S4 coercion via methods::as", { on.exit(S4_remove_classes(c("ParentS4", "ChildS7", "UnrelatedS4"))) setClass("ParentS4", slots = list(x = "numeric")) From b1843a578caca04af0342eaa09a766648ffdcc87 Mon Sep 17 00:00:00 2001 From: Tomasz Kalinowski Date: Wed, 24 Jun 2026 10:17:16 -0400 Subject: [PATCH 082/132] Address S4 property review findings [P1] Preserve S4-only slot reads through @: When an S4 class extends an S7 class and adds its own slot, assignment like `b@z <- 'x'` now works via the replacement fallback, but reading `b@z` still dispatches to the existing `@.S7_object <- prop` and fails with `Property not found` because `z` is not an S7 property. Add the same S4-slot fallback to the read method so normal S4 slots remain accessible. File: /Users/tomasz/github/RConsortium/S7/R/property.R:367-370 [P2] Recognize S4 subclasses when narrowing S7 properties: When an S4 class extends an S7 class with `S4_contains(A)`, every instance satisfies `S7_inherits(..., A)`, but the branch returns `FALSE` whenever the parent is S7 and the child is S4. As a result, overriding a property from `A` to `getClass('B')` is rejected even though `B` extends `A`, so S4 subclasses cannot be used as refined property classes. File: /Users/tomasz/github/RConsortium/S7/R/class-spec.R:398-400 [P3] Declare new slot names used in S4 validation: The added direct slot accesses cause `R CMD check` to emit a new codetools NOTE for undefined globals `contains` and `simple`. Add these names to `globalVariables()` or avoid the direct slot syntax to keep package checks clean. File: /Users/tomasz/github/RConsortium/S7/R/class-spec.R:232-235 --- R/class-spec.R | 8 ++++++-- R/compatibility.R | 2 +- R/property.R | 10 +++++++++- tests/testthat/test-S4.R | 3 +++ tests/testthat/test-class.R | 26 ++++++++++++++++++++++++++ 5 files changed, 45 insertions(+), 4 deletions(-) diff --git a/R/class-spec.R b/R/class-spec.R index 97ddf46bc..a39e0a910 100644 --- a/R/class-spec.R +++ b/R/class-spec.R @@ -395,6 +395,10 @@ class_extends <- function(child, parent) { } else if (is.null(parent)) { # as a parent, NULL only accepts NULL is.null(child) + } else if (is_S4_class(child) && is_class(parent)) { + parent_class <- S7_class_name(parent) + methods::isClass(parent_class) && + methods::extends(child@className, parent_class) } else if (is_S4_class(child) || is_S4_class(parent)) { if (!is_S4_class(parent)) { FALSE @@ -466,5 +470,5 @@ union_contains_any <- function(x) { is_union(x) && any(vlapply(x$classes, is_class_any)) } -# Suppress @className false positive -globalVariables("className") +# Suppress direct S4 representation slot false positives +globalVariables(c("className", "contains", "simple")) diff --git a/R/compatibility.R b/R/compatibility.R index b7421ee9b..0f98fec5e 100644 --- a/R/compatibility.R +++ b/R/compatibility.R @@ -14,7 +14,7 @@ activate_backward_compatiblility <- function() { `@` <- function(object, name) { if (inherits(object, "S7_object")) { name <- as.character(substitute(name)) - prop(object, name) + prop_or_slot(object, name) } else { name <- substitute(name) do.call(base::`@`, list(object, name)) diff --git a/R/property.R b/R/property.R index 948146bd8..2f39d871c 100644 --- a/R/property.R +++ b/R/property.R @@ -361,7 +361,15 @@ prop_call <- function(object, name) { #' @usage object@name #' @rawNamespace if (getRversion() >= "4.3.0") S3method(base::`@`, S7_object) #' @name prop -`@.S7_object` <- prop +prop_or_slot <- function(object, name) { + if (isS4(object) && !name %in% names(S7_class(object)@properties)) { + return(methods::slot(object, name)) + } + + prop(object, name) +} + +`@.S7_object` <- prop_or_slot #' @rawNamespace S3method("@<-",S7_object) `@<-.S7_object` <- function(object, name, value) { diff --git a/tests/testthat/test-S4.R b/tests/testthat/test-S4.R index ada0b80f0..fc39e7127 100644 --- a/tests/testthat/test-S4.R +++ b/tests/testthat/test-S4.R @@ -890,9 +890,12 @@ test_that("@<- sets S4-only slots on subclasses of S7 classes", { ) child <- methods::new("S4ChildForAt", ChildForAt(x = 1, y = "a"), z = "b") + expect_equal(child@z, "b") + child@z <- "c" child@y <- "d" + expect_equal(child@z, "c") expect_equal(methods::slot(child, "z"), "c") expect_equal(prop(child, "y"), "d") }) diff --git a/tests/testthat/test-class.R b/tests/testthat/test-class.R index a40ddfcf1..e7f0aaa5b 100644 --- a/tests/testthat/test-class.R +++ b/tests/testthat/test-class.R @@ -145,6 +145,32 @@ test_that("inheritance lets child properties narrow S4 slots with S7-over-S4 cla expect_equal(prop(DogKennel(dog = dog), "dog"), dog) }) +test_that("inheritance lets child properties narrow to S4 subclasses of S7 classes", { + 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( "Parent", From a582828022dde4da456dbf14b0bef08eaff831d8 Mon Sep 17 00:00:00 2001 From: Tomasz Kalinowski Date: Wed, 24 Jun 2026 10:59:28 -0400 Subject: [PATCH 083/132] Fix S4 storage edge cases [P2] Exclude dynamic properties from S4 slots: `S4_register()` builds S4 slots from all properties, including getter-backed dynamic properties that are never stored on instances. This can make `validObject()` fail for registered classes. Only stored properties should become S4 slots, or such classes should be rejected at registration. [P2] Keep S4 data parts in one storage location: when the S4 parent has a `.Data` slot, the constructor passes `.Data` as the parent object while also splicing it as a normal property, creating two copies. Updating `prop(x, ".Data")` changes only the attribute while vector/coercion behavior keeps the old data; `.Data` should read/write the actual data part instead. [P2] Preserve S4 slot storage for renamed slot names: importing every S4 slot as an ordinary S7 property breaks S4 parents with slots that S7 stores under renamed attributes, such as `names` or `dim`. Direct S7 children may store values in renamed attributes like `_names`, causing `slot()` and `convert()` to fail or read separate storage; these slots need S4-aware storage or should be rejected. --- R/S4.R | 32 +++++++++++++++++++++-- R/class.R | 4 +++ R/constructor.R | 7 +++-- R/property.R | 34 +++++++++++++++++++++++++ tests/testthat/_snaps/S4.md | 10 ++++++++ tests/testthat/test-S4.R | 51 +++++++++++++++++++++++++++++++++++-- 6 files changed, 132 insertions(+), 6 deletions(-) diff --git a/R/S4.R b/R/S4.R index af1e3c7bc..71fd9d6d4 100644 --- a/R/S4.R +++ b/R/S4.R @@ -327,8 +327,15 @@ S4_register_class <- function(class, env = parent.frame()) { } properties <- class@properties - prototype_properties <- properties[setdiff(names(properties), ".Data")] - slot_properties <- properties[setdiff(names(properties), parent_slot_names)] + stored_properties <- properties[!vlapply(properties, prop_is_dynamic)] + prototype_properties <- stored_properties[setdiff( + names(stored_properties), + ".Data" + )] + slot_properties <- stored_properties[setdiff( + names(stored_properties), + parent_slot_names + )] slots <- lapply(slot_properties, S4_property_class, S4_env = where) needs_S7_class_slot <- !"_S7_class" %in% parent_slot_names if (needs_S7_class_slot) { @@ -361,6 +368,27 @@ S4_register_class <- function(class, env = parent.frame()) { class_name } +S4_check_slot_storage <- function(class, call = sys.call(-1L)) { + nms <- names(class@slots) + renamed <- nms[prop_storage_rename(nms) != nms & nms != ".Data"] + if (length(renamed) == 0L) { + return(invisible()) + } + + renamed_label <- paste(dQuote(renamed), collapse = ", ") + slot_label <- if (length(renamed) == 1L) "slot" else "slots" + msg <- c( + sprintf( + "Can't extend S4 class %s because %s %s would need renamed S7 storage.", + class_desc(class), + slot_label, + renamed_label + ), + "These S4 slots can not be represented safely on direct S7 child objects." + ) + stop2(msg, call = call) +} + S4_reified_parent_class <- function(class, env) { parent_class <- class@parent if (is_class(parent_class)) { diff --git a/R/class.R b/R/class.R index d1011d138..31d7f5116 100644 --- a/R/class.R +++ b/R/class.R @@ -145,6 +145,10 @@ new_class <- function( } } + if (is_S4_class(parent)) { + S4_check_slot_storage(parent, call = sys.call()) + } + parent_props <- class_properties(parent) new_props <- as_properties(properties) check_prop_names(new_props) diff --git a/R/constructor.R b/R/constructor.R index 973b0b92e..93ef0a5e8 100644 --- a/R/constructor.R +++ b/R/constructor.R @@ -19,16 +19,19 @@ new_constructor <- function( ) arg_info <- constructor_args(parent, all_props, envir, package) - self_args <- as_names(names(arg_info$self)) + force_args <- as_names(names(arg_info$self)) s4_data_part <- is_S4_class(parent) && ".Data" %in% names(parent@slots) + self_arg_names <- names(arg_info$self) parent_call <- if (s4_data_part) { + self_arg_names <- setdiff(self_arg_names, ".Data") quote(.Data) } else if (has_S7_symbols(envir, "S7_object")) { quote(S7_object()) } else { quote(S7::S7_object()) } + self_args <- as_names(self_arg_names) new_object_call <- if (has_S7_symbols(envir, "new_object")) { bquote(new_object(.(parent_call), ..(self_args)), splice = TRUE) @@ -42,7 +45,7 @@ new_constructor <- function( quote(`{`), # Force all promises here so that any errors are signaled from # the constructor() call instead of the new_object() call. - unname(self_args), + unname(force_args), new_object_call )), env = envir diff --git a/R/property.R b/R/property.R index 2f39d871c..cd4e64062 100644 --- a/R/property.R +++ b/R/property.R @@ -277,6 +277,10 @@ class_default_desc <- function(class, package = NULL) { #' lexington@height <- 14 #' prop(lexington, "height") <- 15 prop <- function(object, name) { + if (prop_is_S4_data_part(object, name)) { + return(S7_data(object)) + } + .Call(prop_, object, name) } @@ -285,9 +289,39 @@ prop <- function(object, name) { #' [validate()] on the object before returning. #' @export `prop<-` <- function(object, name, check = TRUE, value) { + if (prop_is_S4_data_part(object, name)) { + property <- S7_class(object)@properties[[name]] + if (isTRUE(check)) { + error <- prop_validate(property, value, object) + if (!is.null(error)) { + signal_prop_error(error, object, name) + } + } + + object <- `S7_data<-`(object, check = FALSE, value = value) + if (isTRUE(check)) { + validate(object) + } + return(object) + } + .Call(prop_set_, object, name, check, value) } +prop_is_S4_data_part <- function(object, name) { + if (!identical(name, ".Data") || isS4(object) || !S7_inherits(object)) { + return(FALSE) + } + + class <- S7_class(object) + if (!is_class(class)) { + return(FALSE) + } + + parent <- S4_ancestor(class) + !is.null(parent) && ".Data" %in% names(parent@slots) +} + # called from src/prop.c signal_prop_error <- function(msg, object, name) { stop2(msg, call = prop_call(object, name)) diff --git a/tests/testthat/_snaps/S4.md b/tests/testthat/_snaps/S4.md index dc702afab..503708d46 100644 --- a/tests/testthat/_snaps/S4.md +++ b/tests/testthat/_snaps/S4.md @@ -19,6 +19,16 @@ Error: ! Unsupported S4 object: must be a class generator or a class definition, not a . +# S4 parents reject slots that need renamed S7 storage + + Code + new_class("S4regRenamedSlotChild", parent = getClass("S4regRenamedSlotParent"), + package = NULL) + Condition + Error in `new_class()`: + ! Can't extend S4 class S4 because slot "names" would need renamed S7 storage. + These S4 slots can not be represented safely on direct S7 child objects. + # S4_package_name errors if originating package can't be found Code diff --git a/tests/testthat/test-S4.R b/tests/testthat/test-S4.R index fc39e7127..eccb4dfa3 100644 --- a/tests/testthat/test-S4.R +++ b/tests/testthat/test-S4.R @@ -574,6 +574,29 @@ test_that("S4_contains rejects properties with custom accessors", { ) }) +test_that("S4_register excludes dynamic properties from S4 slots", { + defer(S4_remove_classes("S4regDynamicSlots")) + + S4regDynamicSlots <- new_class( + "S4regDynamicSlots", + properties = list( + x = new_property(class_numeric, getter = function(self) 1), + y = class_numeric + ), + package = NULL + ) + + S4_register(S4regDynamicSlots) + object <- S4regDynamicSlots(y = 2) + + expect_equal( + methods::slotNames("S4regDynamicSlots"), + c("y", "_S7_class", ".S3Class") + ) + expect_equal(prop(object, "x"), 1) + expect_true(methods::validObject(object)) +}) + test_that("S4_register uses registered S7 unions as S4 slots", { on.exit(S4_remove_classes(c( "S7::S4regContainsUnion", @@ -931,8 +954,9 @@ test_that("S4 data part constructors use the .Data argument", { setClass("S4regDataPartParent", contains = "numeric") methods::setValidity("S4regDataPartParent", function(object) { - if (!identical(as.vector(object), 1)) { - "data part must be 1" + data <- as.vector(object) + if (!identical(data, 1) && !identical(data, 2)) { + "data part must be 1 or 2" } else { TRUE } @@ -947,6 +971,12 @@ test_that("S4 data part constructors use the .Data argument", { expect_equal(as.vector(object), 1) expect_equal(prop(object, ".Data"), 1) + expect_null(attr(object, ".Data", exact = TRUE)) + + prop(object, ".Data") <- 2 + expect_equal(as.vector(object), 2) + expect_equal(prop(object, ".Data"), 2) + expect_null(attr(object, ".Data", exact = TRUE)) expect_true(methods::validObject(object)) }) @@ -1045,6 +1075,23 @@ test_that("S4 classes can not extend S7-over-S4 classes with property setters", ) }) +test_that("S4 parents reject slots that need renamed S7 storage", { + defer(S4_remove_classes(c( + "S4regRenamedSlotChild", + "S4regRenamedSlotParent" + ))) + + setClass("S4regRenamedSlotParent", slots = list(names = "character")) + + expect_snapshot(error = TRUE, { + new_class( + "S4regRenamedSlotChild", + parent = getClass("S4regRenamedSlotParent"), + package = NULL + ) + }) +}) + test_that("S4_class_dispatch returns name of base class", { Foo1 := local_S4_class(slots = list("x" = "numeric")) From d957dc723390082d31971795e71e0564841f17d0 Mon Sep 17 00:00:00 2001 From: Tomasz Kalinowski Date: Wed, 24 Jun 2026 11:22:16 -0400 Subject: [PATCH 084/132] Fix S4 parent initialization and defaults MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit [P2] Preserve S4 parent initialize methods — /Users/tomasz/github/RConsortium/S7/R/constructor.R:9-12: Putting S4 parents in the no-delegation branch makes the generated S7 constructor seed new_object() from S7_object()/.Data instead of an initialized S4 parent. This bypasses S4 parent initialize methods that set or normalize slots, so S7 children can get raw prototypes or fail validity unless users redundantly pass every slot. [P2] Do not freeze expression defaults in S4 prototypes — /Users/tomasz/github/RConsortium/S7/R/S4.R:286-288: S7 property defaults that are calls or symbols are evaluated while S4_register() builds the shim prototype. S4 subclasses created with methods::new() then reuse that single prototype value for every instance, freezing defaults like quote(Sys.time()) and sharing mutable defaults like quote(new.env()) instead of evaluating them per object as the S7 constructor does. --- R/S4.R | 82 +++++++++++++++++++++++++++++++++++----- R/class.R | 3 +- R/constructor.R | 79 +++++++++++++++++++++++++++++++++++++- tests/testthat/test-S4.R | 63 +++++++++++++++++++++++++++++- 4 files changed, 214 insertions(+), 13 deletions(-) diff --git a/R/S4.R b/R/S4.R index 71fd9d6d4..62e5a4a98 100644 --- a/R/S4.R +++ b/R/S4.R @@ -284,8 +284,7 @@ S4_property_prototype <- function(prop, env, package) { value <- prop_default(prop, env, package) value <- S4_decode_pseudo_null(value) if (is.call(value) || is.symbol(value)) { - value <- eval(value, env) - value <- S4_decode_pseudo_null(value) + return(list()) } list(value) }, @@ -298,6 +297,27 @@ S4_property_prototype <- function(prop, env, package) { ) } +S4_property_deferred_default <- function(prop, env, package) { + tryCatch( + { + value <- prop_default(prop, env, package) + value <- S4_decode_pseudo_null(value) + if (!is.call(value) && !is.symbol(value)) { + return(list()) + } + value <- eval(value, env) + value <- S4_decode_pseudo_null(value) + list(value) + }, + error = function(cnd) { + if (!is.null(prop$default)) { + stop(cnd) + } + list() + } + ) +} + S4_decode_pseudo_null <- function(value) { if (identical(value, as.name("\001NULL\001"))) NULL else value } @@ -363,7 +383,12 @@ S4_register_class <- function(class, env = parent.frame()) { methods::setOldClass(old_classes, S4Class = class_name, where = where) S4_set_S3_class_prototype(class_name, old_classes, where) methods::setValidity(class_name, S4_validate_class, where = where) - methods::setMethod("initialize", class_name, S4_initialize, where = where) + methods::setMethod( + "initialize", + class_name, + S4_initialize_method(where), + where = where + ) class_name } @@ -449,16 +474,19 @@ S4_validate <- function(object) { ) } -S4_initialize <- function(.Object, ...) { +S4_initialize_method <- function(env) { + force(env) + function(.Object, ...) { + S4_initialize(.Object, ..., .S4_default_env = env) + } +} + +S4_initialize <- function(.Object, ..., .S4_default_env = parent.frame()) { if (isS4(.Object) && has_S7_class(.Object)) { S4_check_contains(S7_class(.Object)) } args <- list(...) - if (length(args) == 0) { - return(.Object) - } - nms <- names2(args) prop_nms <- prop_names(.Object) vals <- list() @@ -497,13 +525,49 @@ S4_initialize <- function(.Object, ...) { .Object <- S4_initialize_data_part(data_part, .Object) } - props(.Object) <- vals + vals <- modify_list( + S4_initialize_default_values(.Object, names(vals), .S4_default_env), + vals + ) + if (length(vals) > 0L) { + props(.Object) <- vals + } for (name in names(s4_vals)) { methods::slot(.Object, name) <- s4_vals[[name]] } .Object } +S4_initialize_default_values <- function(object, supplied, env) { + class <- S7_class(object) + properties <- class@properties + properties <- properties[!vlapply(properties, prop_is_dynamic)] + properties <- properties[names(properties) %in% methods::slotNames(object)] + properties <- properties[setdiff(names(properties), supplied)] + + values <- list() + for (name in names(properties)) { + if (!S4_slot_has_prototype_value(object, name)) { + next + } + + value <- S4_property_deferred_default( + properties[[name]], + env, + class@package + ) + if (length(value) != 0L) { + values[[name]] <- value[[1L]] + } + } + values +} + +S4_slot_has_prototype_value <- function(object, name) { + prototype <- methods::getClass(class(object)[1L])@prototype + identical(methods::slot(object, name), methods::slot(prototype, name)) +} + S4_initialize_values <- function(object) { if (isS4(object)) { slots <- methods::slotNames(object) diff --git a/R/class.R b/R/class.R index 31d7f5116..627f9804d 100644 --- a/R/class.R +++ b/R/class.R @@ -159,10 +159,9 @@ new_class <- function( all_props[names(new_props)] <- new_props if (is.null(constructor)) { - constructor_props <- if (is_S4_class(parent)) all_props else new_props constructor <- new_constructor( parent, - constructor_props, + new_props, envir = parent.frame(), package = package ) diff --git a/R/constructor.R b/R/constructor.R index 93ef0a5e8..926faf733 100644 --- a/R/constructor.R +++ b/R/constructor.R @@ -6,6 +6,10 @@ new_constructor <- function( ) { properties <- as_properties(properties) + if (is_S4_class(parent) && !parent@virtual) { + return(new_S4_constructor(parent, properties, envir, package)) + } + if ( identical(parent, S7_object) || is_S4_class(parent) || @@ -13,8 +17,13 @@ new_constructor <- function( ) { # There's no parent constructor to delegate to, so the constructor must # handle all properties: inherited and newly declared (which win). + parent_props <- if (is_S4_class(parent)) { + class_properties(parent) + } else { + attr(parent, "properties", exact = TRUE) + } all_props <- modify_list( - attr(parent, "properties", exact = TRUE), + parent_props, properties ) @@ -112,6 +121,74 @@ new_constructor <- function( new_function(constr_args[constr_nms], child_call, env) } +new_S4_constructor <- function(parent, properties, envir, package) { + parent_props <- class_properties(parent) + parent_nms <- names2(parent_props) + override_nms <- intersect(names2(properties), parent_nms) + self_props <- properties[setdiff(names2(properties), parent_nms)] + + parent_args <- as.pairlist(lapply( + setNames(, parent_nms), + function(name) { + if (name %in% override_nms) { + prop_default(properties[[name]], envir, package) + } else { + quote(expr = ) + } + } + )) + self_args <- constructor_args(S7_object, self_props, envir, package)$self + constr_args <- modify_list(parent_args, self_args) + + parent_arg_exprs <- lapply(parent_nms, function(name) { + value <- as.name(name) + if (name %in% override_nms) { + bquote(.parent_args[.(name)] <- list(.(value))) + } else { + bquote(if (!missing(.(value))) .parent_args[.(name)] <- list(.(value))) + } + }) + + parent_value_nms <- setdiff(parent_nms, ".Data") + parent_value_args <- lapply(parent_value_nms, function(name) { + bquote(.parent_values[[.(name)]]) + }) + names(parent_value_args) <- parent_value_nms + + self_value_args <- as_names(names2(self_args)) + parent_seed <- if (".Data" %in% parent_nms) { + quote(.parent_values[[".Data"]]) + } else { + quote(.S7_object()) + } + new_object_call <- as.call(c( + list(quote(.S7_new_object), parent_seed), + parent_value_args, + self_value_args + )) + + env <- new.env(parent = envir) + env$.S4_parent <- class_constructor(parent) + env$.S4_initialize_values <- S4_initialize_values + env$.S7_new_object <- new_object + env$.S7_object <- S7_object + + new_function( + constr_args, + as.call(c( + quote(`{`), + quote(.parent_args <- list()), + parent_arg_exprs, + list( + quote(.parent <- do.call(.S4_parent, .parent_args)), + quote(.parent_values <- .S4_initialize_values(.parent)), + new_object_call + ) + )), + env + ) +} + constructor_args <- function( parent, properties = list(), diff --git a/tests/testthat/test-S4.R b/tests/testthat/test-S4.R index eccb4dfa3..e12fda8e0 100644 --- a/tests/testthat/test-S4.R +++ b/tests/testthat/test-S4.R @@ -397,7 +397,7 @@ test_that("S4_contains rejects abstract S7 classes", { ) }) -test_that("S4_register uses S7 property defaults as S4 prototypes", { +test_that("S4_register uses S7 property defaults for S4 objects", { on.exit(S4_remove_classes(c( "S4regPrototype", "S4regPrototypeChild", @@ -429,6 +429,33 @@ test_that("S4_register uses S7 property defaults as S4 prototypes", { expect_true(methods::validObject(object)) }) +test_that("S4_register evaluates expression defaults for each S4 object", { + defer(S4_remove_classes(c( + "S4regPrototypeExpr", + "S4regPrototypeExprChild" + ))) + + S4regPrototypeExpr <- new_class( + "S4regPrototypeExpr", + properties = list( + x = new_property( + class_environment, + default = quote(new.env(parent = emptyenv())) + ) + ), + package = NULL + ) + S4_register(S4regPrototypeExpr) + S4regPrototypeExpr_S4 <- S4_contains(S4regPrototypeExpr) + methods::setClass("S4regPrototypeExprChild", contains = S4regPrototypeExpr_S4) + + object1 <- methods::new("S4regPrototypeExprChild") + object2 <- methods::new("S4regPrototypeExprChild") + + prop(object1, "x")$value <- 1 + expect_null(prop(object2, "x")$value) +}) + test_that("S4 parents preserve slot prototypes in S7 constructors", { defer(S4_remove_classes(c( "S4regSlotPrototypeParent", @@ -452,6 +479,40 @@ test_that("S4 parents preserve slot prototypes in S7 constructors", { expect_equal(prop(object, "x"), 10) }) +test_that("S7 constructors delegate to S4 parent initialize methods", { + defer(S4_remove_classes(c( + "S4regInitializeParent", + "S4regInitializeChild" + ))) + + setClass("S4regInitializeParent", slots = list(x = "numeric")) + methods::setMethod( + "initialize", + "S4regInitializeParent", + function(.Object, x = 1, ...) { + .Object <- callNextMethod(.Object, ...) + .Object@x <- x * 10 + .Object + } + ) + S4regInitializeChild <- new_class( + "S4regInitializeChild", + parent = getClass("S4regInitializeParent"), + properties = list(y = class_character), + package = NULL + ) + + object <- S4regInitializeChild(x = 2, y = "a") + + expect_equal(prop(object, "x"), 20) + expect_equal(methods::slot(object, "x"), 20) + expect_equal(prop(object, "y"), "a") + + object <- S4regInitializeChild(y = "b") + expect_equal(prop(object, "x"), 10) + expect_equal(prop(object, "y"), "b") +}) + test_that("S4 prototypes use overridden inherited S7 property defaults", { defer(S4_remove_classes(c( "S4regOverrideParent", From 0b960b2f11d2a4f0a9e1f095b687c39d7a23c05f Mon Sep 17 00:00:00 2001 From: Tomasz Kalinowski Date: Wed, 24 Jun 2026 11:39:17 -0400 Subject: [PATCH 085/132] Fix S4 deferred defaults MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Finding 1: [P2] Use the constructor environment for deferred defaults — /Users/tomasz/github/RConsortium/S7/R/S4.R:308. When an S7 property default is a quoted expression that closes over a local binding, S4 subclass construction evaluates it in `topenv(env)` from registration instead of the constructor's environment. For example, a class created in `local({ x <- 1; new_class(..., default = quote(x)) })` works via `Foo()` but `methods::new()` on an S4 subclass errors with `object 'x' not found`, so S4 subclasses do not preserve existing S7 default semantics. Finding 2: [P2] Preserve NULL deferred defaults when collecting values — /Users/tomasz/github/RConsortium/S7/R/S4.R:560. When a deferred default evaluates to `NULL`, assigning with `values[[name]] <- NULL` removes the entry from the list. For an S4 subclass this means the default is never applied or validated; for example, a numeric property with `default = quote({ NULL })` errors with the S7 constructor but `methods::new()` succeeds using the slot prototype, so invalid defaults can be silently ignored. --- R/S4.R | 3 ++- tests/testthat/_snaps/S4.md | 9 +++++++ tests/testthat/test-S4.R | 49 +++++++++++++++++++++++++++++++++++++ 3 files changed, 60 insertions(+), 1 deletion(-) diff --git a/R/S4.R b/R/S4.R index 62e5a4a98..aead5005c 100644 --- a/R/S4.R +++ b/R/S4.R @@ -540,6 +540,7 @@ S4_initialize <- function(.Object, ..., .S4_default_env = parent.frame()) { S4_initialize_default_values <- function(object, supplied, env) { class <- S7_class(object) + env <- environment(class) properties <- class@properties properties <- properties[!vlapply(properties, prop_is_dynamic)] properties <- properties[names(properties) %in% methods::slotNames(object)] @@ -557,7 +558,7 @@ S4_initialize_default_values <- function(object, supplied, env) { class@package ) if (length(value) != 0L) { - values[[name]] <- value[[1L]] + values[name] <- value } } values diff --git a/tests/testthat/_snaps/S4.md b/tests/testthat/_snaps/S4.md index 503708d46..9b51ea262 100644 --- a/tests/testthat/_snaps/S4.md +++ b/tests/testthat/_snaps/S4.md @@ -1,3 +1,12 @@ +# S4_register validates deferred NULL defaults + + Code + methods::new("S4regNullDefaultChild") + Condition + Error in `validate()`: + ! S4 object properties are invalid: + - @x must be or , not + # S4_register errors on unsupported inputs Code diff --git a/tests/testthat/test-S4.R b/tests/testthat/test-S4.R index e12fda8e0..c34074185 100644 --- a/tests/testthat/test-S4.R +++ b/tests/testthat/test-S4.R @@ -456,6 +456,55 @@ test_that("S4_register evaluates expression defaults for each S4 object", { expect_null(prop(object2, "x")$value) }) +test_that("S4_register evaluates deferred defaults in the constructor environment", { + defer(S4_remove_classes(c( + "S4regDefaultEnv", + "S4regDefaultEnvChild" + ))) + + S4regDefaultEnv <- local({ + x <- 1 + S4regDefaultEnv := new_class( + properties = list(x = new_property(class_numeric, default = quote(x))), + package = NULL + ) + }) + S4_register(S4regDefaultEnv) + S4regDefaultEnv_S4 <- S4_contains(S4regDefaultEnv) + methods::setClass("S4regDefaultEnvChild", contains = S4regDefaultEnv_S4) + + object <- methods::new("S4regDefaultEnvChild") + + expect_equal(methods::slot(object, "x"), 1) + expect_equal(prop(object, "x"), 1) +}) + +test_that("S4_register validates deferred NULL defaults", { + defer(S4_remove_classes(c( + "S4regNullDefault", + "S4regNullDefaultChild" + ))) + + S4regNullDefault := new_class( + properties = list( + x = new_property( + class_numeric, + default = quote({ + NULL + }) + ) + ), + package = NULL + ) + S4_register(S4regNullDefault) + S4regNullDefault_S4 <- S4_contains(S4regNullDefault) + methods::setClass("S4regNullDefaultChild", contains = S4regNullDefault_S4) + + expect_snapshot(error = TRUE, { + methods::new("S4regNullDefaultChild") + }) +}) + test_that("S4 parents preserve slot prototypes in S7 constructors", { defer(S4_remove_classes(c( "S4regSlotPrototypeParent", From 2c5cdb079c24ca4ec7c907a3e4c7b2d50fff7213 Mon Sep 17 00:00:00 2001 From: Tomasz Kalinowski Date: Wed, 24 Jun 2026 12:04:21 -0400 Subject: [PATCH 086/132] Reject internal S4 metadata during upcasts MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit [P2] Reject internal S4 slots during S7 initialization — /Users/tomasz/github/RConsortium/S7/R/S4.R:513-516: When constructing an S4 subclass of an S7 class, `s4_slot_nms` includes the internal `_S7_class` and `.S3Class` slots, so this block accepts user-supplied values for them as ordinary slots. Passing `.S3Class = "bogus"` or `_S7_class = OtherClass` to `methods::new()` overwrites dispatch metadata and produces an object whose S4 and S7 classes no longer match. Filter or reject these internal slots before merging named S4 slot values. [P2] Drop S4-only slots when upcasting to S7 — /Users/tomasz/github/RConsortium/S7/R/convert.R:190-195: When `from` is an S4 subclass created through `S4_contains()`, `from_props` contains only S7 properties. This branch strips only those properties before `class(from) <- ...`, so an upcast such as `convert(methods::new("Child", x = 1, y = "a"), Parent)` warns that the result is no longer S4 and leaves S4-only slot data like `y` and `.S3Class` as ordinary attributes on the returned S7 object. Strip the S4-only slots/internal S4 attributes or use S4 coercion for this case. --- R/S4.R | 19 ++++++++++++++++++- R/convert.R | 19 ++++++++++++++++--- tests/testthat/_snaps/S4.md | 16 ++++++++++++++++ tests/testthat/test-S4.R | 35 +++++++++++++++++++++++++++++++++++ tests/testthat/test-convert.R | 28 ++++++++++++++++++++++++++++ 5 files changed, 113 insertions(+), 4 deletions(-) diff --git a/R/S4.R b/R/S4.R index aead5005c..92a86786b 100644 --- a/R/S4.R +++ b/R/S4.R @@ -232,6 +232,10 @@ S4_slot_names <- function(class, S4_env) { names(methods::getClass(class, where = S4_env)@slots) } +S4_internal_slot_names <- function() { + c("_S7_class", ".S3Class") +} + S4_property_class <- function(prop, S4_env) { S4_class(prop$class, S4_env) } @@ -493,7 +497,10 @@ S4_initialize <- function(.Object, ..., .S4_default_env = parent.frame()) { s4_vals <- list() s4_slot_nms <- character() if (isS4(.Object)) { - s4_slot_nms <- setdiff(methods::slotNames(.Object), prop_nms) + s4_slot_nms <- setdiff( + methods::slotNames(.Object), + c(prop_nms, S4_internal_slot_names()) + ) } data_part <- NULL for (arg in args[nms == ""]) { @@ -509,6 +516,16 @@ S4_initialize <- function(.Object, ..., .S4_default_env = parent.frame()) { vals <- modify_list(vals, arg_vals) } named_args <- args[nms != ""] + internal_arg_nms <- intersect(names2(named_args), S4_internal_slot_names()) + if (length(internal_arg_nms) > 0L) { + slot_label <- if (length(internal_arg_nms) == 1L) "slot" else "slots" + msg <- sprintf( + "Can't initialize internal S4 %s %s.", + slot_label, + paste(dQuote(internal_arg_nms), collapse = ", ") + ) + stop2(msg, call = sys.call(-1L)) + } if (length(s4_slot_nms) > 0L) { s4_vals <- modify_list( s4_vals, diff --git a/R/convert.R b/R/convert.R index 69add8218..b948294c0 100644 --- a/R/convert.R +++ b/R/convert.R @@ -181,18 +181,31 @@ convert_up <- function(from, to, call = sys.call(-1L)) { from <- zap_attr(from, c(from_props, "_S7_class", "S7_class")) class(from) <- to$class } else if (is_class(to)) { - to_props <- prop_storage_rename(names(to@properties)) + to_prop_nms <- names(to@properties) + to_props <- prop_storage_rename(to_prop_nms) if (to@abstract) { msg <- sprintf("Can't convert to abstract class <%s>.", to@name) stop2(msg, call = call) } + is_s4_subclass <- isS4(from) && + is_class(from_class) && + !identical(class(from)[[1L]], S7_class_name(from_class)) + s4_slot_attrs <- if (is_s4_subclass) { + setdiff(methods::slotNames(from), c(to_prop_nms, ".Data")) + } else { + character() + } from <- zap_attr( from, - c(setdiff(from_props, to_props), "_S7_class", "S7_class") + c(setdiff(from_props, to_props), s4_slot_attrs, "_S7_class", "S7_class") ) attr(from, "_S7_class") <- to - class(from) <- class_dispatch(to) + if (is_s4_subclass) { + from <- suppressWarnings(`class<-`(from, class_dispatch(to))) + } else { + class(from) <- class_dispatch(to) + } } else if (is_S4_coerce(from, to)) { from <- convert_S4(from, to) } else { diff --git a/tests/testthat/_snaps/S4.md b/tests/testthat/_snaps/S4.md index 9b51ea262..3633b89a1 100644 --- a/tests/testthat/_snaps/S4.md +++ b/tests/testthat/_snaps/S4.md @@ -1,3 +1,19 @@ +# S4 subclasses reject internal S7/S4 slots during initialization + + Code + methods::new("S4regInternalSlotChild", x = 1, `_S7_class` = S4regInternalOther) + Condition + Error in `initialize()`: + ! Can't initialize internal S4 slot "_S7_class". + +--- + + Code + methods::new("S4regInternalSlotChild", x = 1, .S3Class = "bogus") + Condition + Error in `initialize()`: + ! Can't initialize internal S4 slot ".S3Class". + # S4_register validates deferred NULL defaults Code diff --git a/tests/testthat/test-S4.R b/tests/testthat/test-S4.R index c34074185..5b7dfa654 100644 --- a/tests/testthat/test-S4.R +++ b/tests/testthat/test-S4.R @@ -184,6 +184,41 @@ test_that("S4_register can reify S7 properties as slots for S4 subclasses", { expect_equal(S4regContainsGeneric(object), 1) }) +test_that("S4 subclasses reject internal S7/S4 slots during initialization", { + defer(S4_remove_classes(c( + "S4regInternalSlotChild", + "S4regInternalSlots" + ))) + + S4regInternalSlots := new_class( + properties = list(x = class_numeric), + package = NULL + ) + S4_register(S4regInternalSlots) + S4regInternalSlots_S4 <- S4_contains(S4regInternalSlots) + methods::setClass( + "S4regInternalSlotChild", + contains = S4regInternalSlots_S4 + ) + + S4regInternalOther := new_class(package = NULL) + + expect_snapshot(error = TRUE, { + methods::new( + "S4regInternalSlotChild", + x = 1, + `_S7_class` = S4regInternalOther + ) + }) + expect_snapshot(error = TRUE, { + methods::new( + "S4regInternalSlotChild", + x = 1, + .S3Class = "bogus" + ) + }) +}) + test_that("S4_register constructs S4 subclasses of S7 classes that extend S4 classes", { on.exit(S4_remove_classes(c( "S4regNewParent", diff --git a/tests/testthat/test-convert.R b/tests/testthat/test-convert.R index 5e3306922..a5beced81 100644 --- a/tests/testthat/test-convert.R +++ b/tests/testthat/test-convert.R @@ -174,6 +174,34 @@ test_that("fallback convert can convert_down() an S4 object to an S7 child", { expect_equal(prop(child, "y"), "a") }) +test_that("fallback convert drops S4-only slots when upcasting S4 subclasses", { + defer(S4_remove_classes(c( + "ConvertS4OnlyChild", + "ConvertS4OnlyParent" + ))) + + ConvertS4OnlyParent := new_class( + properties = list(x = class_numeric), + package = NULL + ) + S4_register(ConvertS4OnlyParent) + ConvertS4OnlyParent_S4 <- S4_contains(ConvertS4OnlyParent) + methods::setClass( + "ConvertS4OnlyChild", + contains = ConvertS4OnlyParent_S4, + slots = list(y = "character") + ) + + child <- methods::new("ConvertS4OnlyChild", x = 1, y = "a") + parent <- convert(child, to = ConvertS4OnlyParent) + + expect_identical(isS4(parent), FALSE) + expect_equal(S7_class(parent), ConvertS4OnlyParent) + expect_equal(prop(parent, "x"), 1) + expect_null(attr(parent, "y", exact = TRUE)) + expect_null(attr(parent, ".S3Class", exact = TRUE)) +}) + test_that("fallback convert can use explicit S4 coercion via methods::as", { on.exit(S4_remove_classes(c("ParentS4", "ChildS7", "UnrelatedS4"))) setClass("ParentS4", slots = list(x = "numeric")) From 1fa15862b5844ab0e7db9652ff155be07b974218 Mon Sep 17 00:00:00 2001 From: Tomasz Kalinowski Date: Wed, 24 Jun 2026 12:25:49 -0400 Subject: [PATCH 087/132] Fix S4 slot storage and S7 marker checks MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit [P2] Populate declared S4 slots for registered S7 properties — /Users/tomasz/github/RConsortium/S7/R/S4.R:363-363: With nullable properties or properties whose storage is renamed (e.g. `names`/`dim`), declaring the S4 slot from the public property name makes ordinary S7 instances fail S4 validity because their constructor either omits `NULL` attributes or stores the value under `prop_storage_rename()`. For example, after `Foo <- new_class("Foo", properties = list(x = NULL | class_character), package = NULL); S4_register(Foo)`, `methods::validObject(Foo())` reports that slot `x` is missing. The registration path needs to populate the declared S4 slots for direct S7 instances or avoid declaring slots they cannot satisfy. [P2] Check the S7 object marker before trusting `_S7_class` — /Users/tomasz/github/RConsortium/S7/R/inherits.R:49-52: `has_S7_class()` trusts the internal attribute without checking that the object is actually marked as an S7 object. Any regular object carrying `_S7_class` or the legacy `S7_class` is then reported by `S7_inherits()` as S7, and callers such as `validate()` can enter S7-class code on a non-S7 object. Require the `S7_object`/old-class marker in addition to the attribute so unrelated attributes are not accepted. --- R/S4.R | 20 ++++++++----- R/class.R | 2 +- R/inherits.R | 7 +++-- R/property.R | 4 +++ tests/testthat/test-S4.R | 55 +++++++++++++++++++++++++++++++--- tests/testthat/test-inherits.R | 12 ++++++++ 6 files changed, 84 insertions(+), 16 deletions(-) diff --git a/R/S4.R b/R/S4.R index 92a86786b..12ec6633d 100644 --- a/R/S4.R +++ b/R/S4.R @@ -273,7 +273,8 @@ S4_properties_prototype <- function( for (name in names(properties)) { value <- S4_property_prototype(properties[[name]], env, class@package) if (length(value) != 0L) { - args[[name]] <- value[[1L]] + slot_name <- prop_storage_rename(name) + args[[slot_name]] <- value[[1L]] } } if (include_S7_class) { @@ -356,11 +357,11 @@ S4_register_class <- function(class, env = parent.frame()) { names(stored_properties), ".Data" )] - slot_properties <- stored_properties[setdiff( - names(stored_properties), - parent_slot_names - )] + slot_properties <- stored_properties[ + !prop_storage_rename(names(stored_properties)) %in% parent_slot_names + ] slots <- lapply(slot_properties, S4_property_class, S4_env = where) + names(slots) <- prop_storage_rename(names(slot_properties)) needs_S7_class_slot <- !"_S7_class" %in% parent_slot_names if (needs_S7_class_slot) { slots$`_S7_class` <- "S7_class" @@ -497,9 +498,10 @@ S4_initialize <- function(.Object, ..., .S4_default_env = parent.frame()) { s4_vals <- list() s4_slot_nms <- character() if (isS4(.Object)) { + prop_storage_nms <- prop_storage_rename(prop_nms) s4_slot_nms <- setdiff( methods::slotNames(.Object), - c(prop_nms, S4_internal_slot_names()) + c(prop_nms, prop_storage_nms, S4_internal_slot_names()) ) } data_part <- NULL @@ -560,12 +562,14 @@ S4_initialize_default_values <- function(object, supplied, env) { env <- environment(class) properties <- class@properties properties <- properties[!vlapply(properties, prop_is_dynamic)] - properties <- properties[names(properties) %in% methods::slotNames(object)] + property_slot_nms <- prop_storage_rename(names(properties)) + properties <- properties[property_slot_nms %in% methods::slotNames(object)] properties <- properties[setdiff(names(properties), supplied)] values <- list() for (name in names(properties)) { - if (!S4_slot_has_prototype_value(object, name)) { + slot_name <- prop_storage_rename(name) + if (!S4_slot_has_prototype_value(object, slot_name)) { next } diff --git a/R/class.R b/R/class.R index 627f9804d..04d79ef43 100644 --- a/R/class.R +++ b/R/class.R @@ -369,7 +369,7 @@ new_object <- function(`_parent`, ...) { args <- collect_dots(...) has_setter <- vlapply(class@properties[names(args)], prop_has_setter) - self_attrs <- args[!has_setter] + self_attrs <- lapply(args[!has_setter], prop_encode_pseudo_null) names(self_attrs) <- prop_storage_rename(names(self_attrs)) # We must awkwardly operate on `_parent` rather than binding to a local diff --git a/R/inherits.R b/R/inherits.R index 5dfb269ef..d7c57a926 100644 --- a/R/inherits.R +++ b/R/inherits.R @@ -47,9 +47,10 @@ S7_inherits <- function(x, class = NULL) { } has_S7_class <- function(x) { - identical(class(x), "S7_object") || - inherits(x, "S7_class") || - !is.null(.Call(S7_class_, x)) + inherits(x, "S7_object") && + (identical(class(x), "S7_object") || + inherits(x, "S7_class") || + !is.null(.Call(S7_class_, x))) } #' @export diff --git a/R/property.R b/R/property.R index cd4e64062..65e530e07 100644 --- a/R/property.R +++ b/R/property.R @@ -639,6 +639,10 @@ prop_storage_rename <- function(names) { .Call(prop_storage_rename_, names) } +prop_encode_pseudo_null <- function(value) { + if (is.null(value)) as.name("\001NULL\001") else value +} + prop_storage_names <- function(object) { prop_storage_rename(prop_names(object)) } diff --git a/tests/testthat/test-S4.R b/tests/testthat/test-S4.R index 5b7dfa654..f6f06f778 100644 --- a/tests/testthat/test-S4.R +++ b/tests/testthat/test-S4.R @@ -662,6 +662,28 @@ test_that("S4_register treats S4 NULL slot sentinels as NULL-valued S7 propertie expect_identical(attr(plain, "x", exact = TRUE), as.name("\001NULL\001")) }) +test_that("S4_register keeps direct S7 nullable property slots valid", { + defer(S4_remove_classes(c( + "S4regDirectNullable", + "NULL_OR_character" + ))) + + S4_register(NULL | class_character) + S4regDirectNullable <- new_class( + "S4regDirectNullable", + properties = list(x = NULL | class_character), + package = NULL + ) + S4_register(S4regDirectNullable) + + object <- S4regDirectNullable() + + expect_equal(prop(object, "x"), NULL) + expect_equal(methods::slot(object, "x"), NULL) + expect_true(methods::validObject(object)) + expect_identical(attr(object, "x", exact = TRUE), as.name("\001NULL\001")) +}) + test_that("S4_contains rejects properties with custom accessors", { on.exit(S4_remove_classes(c( "S4regContainsDynamicChild", @@ -1158,7 +1180,7 @@ test_that("S4 data part initialization preserves S4 subclasses", { expect_true(methods::validObject(object)) }) -test_that("S4 subclasses read and write special-named S7 property slots", { +test_that("S4 subclasses read and write special-named S7 property storage slots", { defer(S4_remove_classes(c( "S4regSpecialSlotsChild", "S4regSpecialSlots" @@ -1182,15 +1204,40 @@ test_that("S4 subclasses read and write special-named S7 property slots", { dim = 2L ) - expect_equal(methods::slot(object, "names"), "n") - expect_equal(methods::slot(object, "dim"), 2L) + expect_equal(methods::slot(object, "_names"), "n") + expect_equal(methods::slot(object, "_dim"), 2L) expect_equal(prop(object, "names"), "n") + expect_true(methods::validObject(object)) prop(object, "names") <- "updated" - expect_equal(methods::slot(object, "names"), "updated") + expect_equal(methods::slot(object, "_names"), "updated") expect_equal(prop(object, "names"), "updated") }) +test_that("S4_register keeps direct S7 special-name property slots valid", { + defer(S4_remove_classes("S4regDirectSpecialSlots")) + + S4regDirectSpecialSlots <- new_class( + "S4regDirectSpecialSlots", + properties = list( + names = class_character, + dim = class_integer + ), + package = NULL + ) + S4_register(S4regDirectSpecialSlots) + + object <- S4regDirectSpecialSlots( + names = "n", + dim = 2L + ) + + expect_equal(methods::slot(object, "_names"), "n") + expect_equal(methods::slot(object, "_dim"), 2L) + expect_equal(prop(object, "names"), "n") + expect_true(methods::validObject(object)) +}) + test_that("S4 classes can not extend S7-over-S4 classes with property setters", { on.exit(S4_remove_classes(c("Parent2", "Child2", "S4Child2"))) setClass("Parent2", slots = list(x = "numeric")) diff --git a/tests/testthat/test-inherits.R b/tests/testthat/test-inherits.R index 73755a9df..1b155dfaf 100644 --- a/tests/testthat/test-inherits.R +++ b/tests/testthat/test-inherits.R @@ -30,6 +30,18 @@ test_that("checks that input is a class", { expect_snapshot(S7_inherits(1:10, "x"), error = TRUE) }) +test_that("ignores S7 class attributes without an S7 object marker", { + Foo := new_class(package = NULL) + + object <- structure(1, `_S7_class` = Foo) + legacy_object <- structure(1, S7_class = Foo) + + expect_false(S7_inherits(object)) + expect_false(S7_inherits(object, Foo)) + expect_false(S7_inherits(legacy_object)) + expect_false(S7_inherits(legacy_object, Foo)) +}) + test_that("throws informative error", { expect_snapshot(error = TRUE, { foo1 := new_class(package = NULL) From 63fb2e39374520cc264a9501267999f735c55647 Mon Sep 17 00:00:00 2001 From: Tomasz Kalinowski Date: Wed, 24 Jun 2026 12:46:46 -0400 Subject: [PATCH 088/132] Fix S4 renamed slots and abstract parent registration MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit [P2] Preserve S7 dispatch for abstract parents — /Users/tomasz/github/RConsortium/S7/R/S4.R:383-384: With an ordinary abstract S7 parent, this early return leaves the abstract class as a plain virtual S4 class. Then `Abs <- new_class("Abs", abstract = TRUE); Conc <- new_class("Conc", parent = Abs); S4_register(Conc)` fails in the later `setOldClass(c("Conc", "Abs", "S7_object"), ...)` call with inconsistent old-style class information, and S4 subclasses of concrete children also dispatch on `S4/Abs` instead of the S7 `Abs` method key. [P2] Read S4 property slots by storage name — /Users/tomasz/github/RConsortium/S7/src/prop.c:223-224: For an S7 property whose storage name is renamed, such as `names` -> `_names`, an S4 subclass can also have a real S4 slot named `names`. This helper checks the unrenamed name first, so `prop(obj, "names")` and `prop(obj, "names") <- value` read/write that unrelated S4 slot instead of the `_names` S7 property slot, making the supported special-name property inaccessible or corrupted. [P2] Map copied S4 slots back to property names — /Users/tomasz/github/RConsortium/S7/R/S4.R:517-518: When an existing S4 object is used as an unnamed initializer, `S4_initialize_values()` returns S4 slot names, but this filters them against unrenamed property names. For special-name properties stored as `_names`, `methods::new("Child", old_child)` drops `_names` instead of copying it, so the new object silently falls back to the prototype/default value. [P2] Preserve renamed property slots when upcasting — /Users/tomasz/github/RConsortium/S7/R/convert.R:195: This compares S4 slot names with unrenamed property names, so upcasting an S4 subclass of an S7 class with a renamed property treats the real property slot as S4-only. For example, a `names` property is stored in `_names`; `convert(child, to = Parent)` includes `_names` in `s4_slot_attrs` and zaps it, returning a parent object with the property lost. --- R/S4.R | 24 +++++++++++- R/convert.R | 2 +- src/prop.c | 18 +++++---- tests/testthat/test-S4.R | 74 ++++++++++++++++++++++++++++++++++- tests/testthat/test-convert.R | 31 +++++++++++++++ 5 files changed, 137 insertions(+), 12 deletions(-) diff --git a/R/S4.R b/R/S4.R index 12ec6633d..0c47212be 100644 --- a/R/S4.R +++ b/R/S4.R @@ -380,11 +380,15 @@ S4_register_class <- function(class, env = parent.frame()) { where = where ) + old_classes <- S4_reified_old_classes(class) if (class@abstract) { + if (!S7_extends_S4(class)) { + methods::setOldClass(old_classes, S4Class = class_name, where = where) + S4_set_S3_class_prototype(class_name, old_classes, where) + } return(class_name) } - old_classes <- S4_reified_old_classes(class) methods::setOldClass(old_classes, S4Class = class_name, where = where) S4_set_S3_class_prototype(class_name, old_classes, where) methods::setValidity(class_name, S4_validate_class, where = where) @@ -514,7 +518,11 @@ S4_initialize <- function(.Object, ..., .S4_default_env = parent.frame()) { arg_s4_vals <- arg_vals[names(arg_vals) %in% s4_slot_nms] s4_vals <- modify_list(s4_vals, arg_s4_vals) } - arg_vals <- arg_vals[names(arg_vals) %in% prop_nms] + arg_vals <- S4_initialize_prop_values( + arg_vals, + prop_nms, + storage = isS4(arg) + ) vals <- modify_list(vals, arg_vals) } named_args <- args[nms != ""] @@ -557,6 +565,18 @@ S4_initialize <- function(.Object, ..., .S4_default_env = parent.frame()) { .Object } +S4_initialize_prop_values <- function(values, properties, storage = FALSE) { + if (!storage) { + return(values[names(values) %in% properties]) + } + + storage_nms <- prop_storage_rename(properties) + idx <- match(names(values), storage_nms) + values <- values[!is.na(idx)] + names(values) <- properties[idx[!is.na(idx)]] + values +} + S4_initialize_default_values <- function(object, supplied, env) { class <- S7_class(object) env <- environment(class) diff --git a/R/convert.R b/R/convert.R index b948294c0..405a92760 100644 --- a/R/convert.R +++ b/R/convert.R @@ -192,7 +192,7 @@ convert_up <- function(from, to, call = sys.call(-1L)) { is_class(from_class) && !identical(class(from)[[1L]], S7_class_name(from_class)) s4_slot_attrs <- if (is_s4_subclass) { - setdiff(methods::slotNames(from), c(to_prop_nms, ".Data")) + setdiff(methods::slotNames(from), c(to_props, ".Data")) } else { character() } diff --git a/src/prop.c b/src/prop.c index 95aa9302f..fff38e7b2 100644 --- a/src/prop.c +++ b/src/prop.c @@ -220,26 +220,28 @@ SEXP pseudo_null(void) { } static inline -Rboolean prop_has_public_slot(SEXP object, SEXP name_sym) { - return Rf_isS4(object) && R_has_slot(object, name_sym); +Rboolean prop_has_storage_slot(SEXP object, SEXP storage_sym) { + return Rf_isS4(object) && R_has_slot(object, storage_sym); } static inline SEXP prop_get_storage(SEXP object, SEXP name_sym) { - SEXP value = prop_has_public_slot(object, name_sym) ? - R_do_slot(object, name_sym) : - Rf_getAttrib(object, prop_storage_sym(name_sym)); + SEXP storage_sym = prop_storage_sym(name_sym); + SEXP value = prop_has_storage_slot(object, storage_sym) ? + R_do_slot(object, storage_sym) : + Rf_getAttrib(object, storage_sym); return value == pseudo_null() ? R_NilValue : value; } static inline SEXP prop_set_storage(SEXP object, SEXP name_sym, SEXP value) { + SEXP storage_sym = prop_storage_sym(name_sym); if (value == R_NilValue) value = pseudo_null(); - if (prop_has_public_slot(object, name_sym)) - R_do_slot_assign(object, name_sym, value); + if (prop_has_storage_slot(object, storage_sym)) + R_do_slot_assign(object, storage_sym, value); else - Rf_setAttrib(object, prop_storage_sym(name_sym), value); + Rf_setAttrib(object, storage_sym, value); return object; } diff --git a/tests/testthat/test-S4.R b/tests/testthat/test-S4.R index f6f06f778..bf7595c82 100644 --- a/tests/testthat/test-S4.R +++ b/tests/testthat/test-S4.R @@ -412,6 +412,41 @@ test_that("S4_register registers abstract S7 classes as virtual S4 classes", { expect_true(methods::validObject(object)) }) +test_that("S4_register preserves S7 dispatch through abstract S7 parents", { + defer(S4_remove_classes(c( + "S4regAbstractPlainChild", + "S4regAbstractPlainConcrete", + "S4regAbstractPlain" + ))) + + S4regAbstractPlain := new_class( + abstract = TRUE, + package = NULL + ) + S4regAbstractPlainConcrete := new_class( + parent = S4regAbstractPlain, + package = NULL + ) + S4_register(S4regAbstractPlainConcrete) + S4regAbstractPlainConcrete_S4 <- S4_contains(S4regAbstractPlainConcrete) + setClass( + "S4regAbstractPlainChild", + contains = S4regAbstractPlainConcrete_S4 + ) + + object <- methods::new("S4regAbstractPlainChild") + S4regAbstractPlainGeneric <- new_generic("S4regAbstractPlainGeneric", "x") + method(S4regAbstractPlainGeneric, S4regAbstractPlain) <- function(x) { + "abstract" + } + + expect_equal(S4regAbstractPlainGeneric(object), "abstract") + expect_contains( + obj_dispatch(object), + c("S4regAbstractPlainConcrete", "S4regAbstractPlain") + ) +}) + test_that("S4_contains rejects abstract S7 classes", { defer(S4_remove_classes(c( "S4regAbstractContainsParent", @@ -1196,24 +1231,61 @@ test_that("S4 subclasses read and write special-named S7 property storage slots" ) S4_register(S4regSpecialSlots) S4regSpecialSlots_S4 <- S4_contains(S4regSpecialSlots) - setClass("S4regSpecialSlotsChild", contains = S4regSpecialSlots_S4) + setClass( + "S4regSpecialSlotsChild", + contains = S4regSpecialSlots_S4, + slots = list(names = "character") + ) object <- methods::new( "S4regSpecialSlotsChild", names = "n", dim = 2L ) + methods::slot(object, "names") <- "s4-only" expect_equal(methods::slot(object, "_names"), "n") expect_equal(methods::slot(object, "_dim"), 2L) + expect_equal(methods::slot(object, "names"), "s4-only") expect_equal(prop(object, "names"), "n") expect_true(methods::validObject(object)) prop(object, "names") <- "updated" expect_equal(methods::slot(object, "_names"), "updated") + expect_equal(methods::slot(object, "names"), "s4-only") expect_equal(prop(object, "names"), "updated") }) +test_that("S4 initializers copy renamed S7 property storage slots", { + defer(S4_remove_classes(c( + "S4regCopySpecialSlotsChild", + "S4regCopySpecialSlots" + ))) + + S4regCopySpecialSlots := new_class( + properties = list(names = class_character), + package = NULL + ) + S4_register(S4regCopySpecialSlots) + S4regCopySpecialSlots_S4 <- S4_contains(S4regCopySpecialSlots) + setClass( + "S4regCopySpecialSlotsChild", + contains = S4regCopySpecialSlots_S4, + slots = list(extra = "character") + ) + + old <- methods::new( + "S4regCopySpecialSlotsChild", + names = "n", + extra = "old" + ) + new <- methods::new("S4regCopySpecialSlotsChild", old) + + expect_equal(prop(new, "names"), "n") + expect_equal(methods::slot(new, "_names"), "n") + expect_equal(methods::slot(new, "extra"), "old") +}) + test_that("S4_register keeps direct S7 special-name property slots valid", { defer(S4_remove_classes("S4regDirectSpecialSlots")) diff --git a/tests/testthat/test-convert.R b/tests/testthat/test-convert.R index a5beced81..1812b6b28 100644 --- a/tests/testthat/test-convert.R +++ b/tests/testthat/test-convert.R @@ -202,6 +202,37 @@ test_that("fallback convert drops S4-only slots when upcasting S4 subclasses", { expect_null(attr(parent, ".S3Class", exact = TRUE)) }) +test_that("fallback convert preserves renamed S7 property slots when upcasting", { + defer(S4_remove_classes(c( + "ConvertS4SpecialChild", + "ConvertS4SpecialParent" + ))) + + ConvertS4SpecialParent := new_class( + properties = list(names = class_character), + package = NULL + ) + S4_register(ConvertS4SpecialParent) + ConvertS4SpecialParent_S4 <- S4_contains(ConvertS4SpecialParent) + methods::setClass( + "ConvertS4SpecialChild", + contains = ConvertS4SpecialParent_S4, + slots = list(extra = "character") + ) + + child <- methods::new( + "ConvertS4SpecialChild", + names = "n", + extra = "old" + ) + parent <- convert(child, to = ConvertS4SpecialParent) + + expect_identical(isS4(parent), FALSE) + expect_equal(S7_class(parent), ConvertS4SpecialParent) + expect_equal(prop(parent, "names"), "n") + expect_null(attr(parent, "extra", exact = TRUE)) +}) + test_that("fallback convert can use explicit S4 coercion via methods::as", { on.exit(S4_remove_classes(c("ParentS4", "ChildS7", "UnrelatedS4"))) setClass("ParentS4", slots = list(x = "numeric")) From f1333069194bd9ed20c62f0403d7fe8e413e44a1 Mon Sep 17 00:00:00 2001 From: Tomasz Kalinowski Date: Wed, 24 Jun 2026 13:14:35 -0400 Subject: [PATCH 089/132] Fix S7/S4 abstract dispatch and virtual initialization MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Finding 1: <<>> [P2] Include abstract S7 parents in S4 dispatch — /Users/tomasz/github/RConsortium/S7/R/S4.R:333-334: When an S7 class extends an abstract S7 class whose root is S4, this early return omits the abstract S7 parent from the old-class vector used by S4 subclasses. A class created with `methods::setClass(contains = S4_contains(Concrete))` then dispatches as `Concrete, S7_object, S4/Abstract...`, so an S7 method registered on `Abstract` is skipped for the S4 subclass even though it works for `Concrete()` directly. <<>> Finding 2: <<>> [P2] Delegate virtual S4 parent initialization — /Users/tomasz/github/RConsortium/S7/R/constructor.R:9-10: When the S4 parent is virtual, this branch skips `new_S4_constructor()` and the generated S7 constructor never calls the parent's `initialize` method. Virtual S4 bases can define inherited initialization for their concrete subclasses, so an S7 subclass of such a base leaves slots at the raw prototype and bypasses argument normalization/defaults that `new("ConcreteS4Child")` would apply. <<>> --- R/S4.R | 13 +++++++ R/constructor.R | 51 +++++++++++++++++++++---- tests/testthat/test-S4.R | 80 ++++++++++++++++++++++++++++++++++++++++ 3 files changed, 136 insertions(+), 8 deletions(-) diff --git a/R/S4.R b/R/S4.R index 0c47212be..474563fd7 100644 --- a/R/S4.R +++ b/R/S4.R @@ -794,6 +794,10 @@ S4_class_name <- function(x) { if (is_oldClass(x)) { return(x@className) } + S7_class <- S4_reified_S7_class(x) + if (!is.null(S7_class)) { + return(S7_class_name(S7_class)) + } class <- x@className package <- x@package %||% attr(class, "package") @@ -807,6 +811,15 @@ S4_class_name <- function(x) { } } +S4_reified_S7_class <- function(x) { + if (!"_S7_class" %in% names(x@slots)) { + return(NULL) + } + + class <- methods::slot(x@prototype, "_S7_class") + if (is_class(class) && class@abstract) class +} + S4_package_name <- function(f, env) { if (methods::getPackageName(topenv(env), create = FALSE) == f@package) { ## current ns might not be loaded yet, catch here diff --git a/R/constructor.R b/R/constructor.R index 926faf733..0322e8ecf 100644 --- a/R/constructor.R +++ b/R/constructor.R @@ -6,7 +6,7 @@ new_constructor <- function( ) { properties <- as_properties(properties) - if (is_S4_class(parent) && !parent@virtual) { + if (is_S4_class(parent)) { return(new_S4_constructor(parent, properties, envir, package)) } @@ -132,6 +132,8 @@ new_S4_constructor <- function(parent, properties, envir, package) { function(name) { if (name %in% override_nms) { prop_default(properties[[name]], envir, package) + } else if (parent@virtual) { + prop_default(parent_props[[name]], envir, package) } else { quote(expr = ) } @@ -150,14 +152,18 @@ new_S4_constructor <- function(parent, properties, envir, package) { }) parent_value_nms <- setdiff(parent_nms, ".Data") - parent_value_args <- lapply(parent_value_nms, function(name) { - bquote(.parent_values[[.(name)]]) - }) + parent_value_args <- if (parent@virtual) { + as_names(parent_value_nms) + } else { + lapply(parent_value_nms, function(name) { + bquote(.parent_values[[.(name)]]) + }) + } names(parent_value_args) <- parent_value_nms self_value_args <- as_names(names2(self_args)) parent_seed <- if (".Data" %in% parent_nms) { - quote(.parent_values[[".Data"]]) + if (parent@virtual) quote(.Data) else quote(.parent_values[[".Data"]]) } else { quote(.S7_object()) } @@ -169,12 +175,22 @@ new_S4_constructor <- function(parent, properties, envir, package) { env <- new.env(parent = envir) env$.S4_parent <- class_constructor(parent) + env$.S4_initialize_parent <- S4_initialize_parent(parent@className) env$.S4_initialize_values <- S4_initialize_values env$.S7_new_object <- new_object env$.S7_object <- S7_object - new_function( - constr_args, + body <- if (parent@virtual) { + as.call(c( + quote(`{`), + quote(.parent_args <- list()), + parent_arg_exprs, + list( + bquote(.object <- .(new_object_call)), + quote(do.call(.S4_initialize_parent, c(list(.object), .parent_args))) + ) + )) + } else { as.call(c( quote(`{`), quote(.parent_args <- list()), @@ -184,11 +200,30 @@ new_S4_constructor <- function(parent, properties, envir, package) { quote(.parent_values <- .S4_initialize_values(.parent)), new_object_call ) - )), + )) + } + + new_function( + constr_args, + body, env ) } +S4_initialize_parent <- function(class) { + force(class) + function(.Object, ...) { + method <- methods::selectMethod("initialize", class) + if (methods::is(method, "derivedDefaultMethod")) { + return(.Object) + } + + out <- method(.Object, ...) + validate(out) + out + } +} + constructor_args <- function( parent, properties = list(), diff --git a/tests/testthat/test-S4.R b/tests/testthat/test-S4.R index bf7595c82..6db0d6b03 100644 --- a/tests/testthat/test-S4.R +++ b/tests/testthat/test-S4.R @@ -447,6 +447,48 @@ test_that("S4_register preserves S7 dispatch through abstract S7 parents", { ) }) +test_that("S4_register preserves S7 dispatch through S4-rooted abstract S7 parents", { + defer(S4_remove_classes(c( + "S4regAbstractRootChild", + "S4regAbstractRootConcrete", + "S4regAbstractRoot", + "S4regAbstractRootParent" + ))) + + setClass("S4regAbstractRootParent", contains = "VIRTUAL") + S4regAbstractRoot := new_class( + parent = getClass("S4regAbstractRootParent"), + abstract = TRUE, + package = NULL + ) + S4regAbstractRootConcrete := new_class( + parent = S4regAbstractRoot, + package = NULL + ) + S4_register(S4regAbstractRootConcrete) + S4regAbstractRootConcrete_S4 <- S4_contains(S4regAbstractRootConcrete) + setClass( + "S4regAbstractRootChild", + contains = S4regAbstractRootConcrete_S4 + ) + + object <- methods::new("S4regAbstractRootChild") + S4regAbstractRootGeneric <- new_generic("S4regAbstractRootGeneric", "x") + method(S4regAbstractRootGeneric, S4regAbstractRoot) <- function(x) { + "abstract" + } + + expect_equal( + S4regAbstractRootGeneric(S4regAbstractRootConcrete()), + "abstract" + ) + expect_equal(S4regAbstractRootGeneric(object), "abstract") + expect_contains( + obj_dispatch(object), + c("S4regAbstractRootConcrete", "S4regAbstractRoot") + ) +}) + test_that("S4_contains rejects abstract S7 classes", { defer(S4_remove_classes(c( "S4regAbstractContainsParent", @@ -632,6 +674,44 @@ test_that("S7 constructors delegate to S4 parent initialize methods", { expect_equal(prop(object, "y"), "b") }) +test_that("S7 constructors delegate to virtual S4 parent initialize methods", { + defer(S4_remove_classes(c( + "S4regVirtualInitializeParent", + "S4regVirtualInitializeChild" + ))) + + setClass( + "S4regVirtualInitializeParent", + slots = list(x = "numeric"), + contains = "VIRTUAL", + prototype = list(x = -1) + ) + methods::setMethod( + "initialize", + "S4regVirtualInitializeParent", + function(.Object, x = 1, ...) { + .Object <- callNextMethod(.Object, ...) + .Object@x <- x * 10 + .Object + } + ) + S4regVirtualInitializeChild := new_class( + parent = getClass("S4regVirtualInitializeParent"), + properties = list(y = class_character), + package = NULL + ) + + object <- S4regVirtualInitializeChild(x = 2, y = "a") + + expect_equal(prop(object, "x"), 20) + expect_equal(methods::slot(object, "x"), 20) + expect_equal(prop(object, "y"), "a") + + object <- S4regVirtualInitializeChild(y = "b") + expect_equal(prop(object, "x"), 10) + expect_equal(prop(object, "y"), "b") +}) + test_that("S4 prototypes use overridden inherited S7 property defaults", { defer(S4_remove_classes(c( "S4regOverrideParent", From 69b7673aa7c6b5eff9e1570e983ed23608b3ea61 Mon Sep 17 00:00:00 2001 From: Tomasz Kalinowski Date: Wed, 24 Jun 2026 13:38:25 -0400 Subject: [PATCH 090/132] Fix S4 registration regressions MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit [P2] Avoid failing S4_register on S7-valued properties — /Users/tomasz/github/RConsortium/S7/R/S4.R:363-364: S4_register() now requires every stored property type to already resolve to an S4 class during slot reification. A class with an S7-valued property, such as Foo with other = Other, now errors with “please call S4_register(Other)”, although dispatch-only registration worked before and automatic registration through an S4 parent now fails. Recursively register these S7 property classes or avoid requiring slot classes for the dispatch-only path. [P2] Filter internal S4 slots before making S7 properties — /Users/tomasz/github/RConsortium/S7/R/S4.R:682-690: When an S7 class extends an S4 class that already contains an S7/oldClass superclass, class@slots includes implementation slots such as _S7_class and .S3Class. Importing them makes those internal fields public S7 properties and can make generated construction or validation fail. Exclude these slots before mapping S4 slots to S7 properties. --- R/S4.R | 27 ++++++++++++-- R/class-spec.R | 3 ++ tests/testthat/test-S4.R | 76 ++++++++++++++++++++++++++++++++++++++++ 3 files changed, 103 insertions(+), 3 deletions(-) diff --git a/R/S4.R b/R/S4.R index 474563fd7..835cdb5d1 100644 --- a/R/S4.R +++ b/R/S4.R @@ -237,9 +237,19 @@ S4_internal_slot_names <- function() { } S4_property_class <- function(prop, S4_env) { + S4_register_property_class(prop$class, S4_env) S4_class(prop$class, S4_env) } +S4_register_property_class <- function(class, S4_env) { + if ( + is_class(class) && !methods::isClass(class_register(class), where = S4_env) + ) { + S4_register(class, S4_env) + } + invisible() +} + S4_check_contains <- function(class, call = sys.call(-1L)) { if (!is_class(class)) { return(invisible()) @@ -680,13 +690,15 @@ S4_to_S7_class <- function(x, error_base = "", call = sys.call(-1L)) { } S4_slot_properties <- function(class) { + slots <- class@slots + slots <- slots[!names(slots) %in% S4_internal_slot_names()] properties <- Map( S4_slot_property, - class@slots, - names(class@slots), + slots, + names(slots), MoreArgs = list(owner = class) ) - names(properties) <- names(class@slots) + names(properties) <- names(slots) properties } @@ -820,6 +832,15 @@ S4_reified_S7_class <- function(x) { if (is_class(class) && class@abstract) class } +S4_is_reified_S7_class <- function(x) { + if (!"_S7_class" %in% names(x@slots)) { + return(FALSE) + } + + class <- methods::slot(x@prototype, "_S7_class") + is_class(class) && identical(as.character(x@className), S7_class_name(class)) +} + S4_package_name <- function(f, env) { if (methods::getPackageName(topenv(env), create = FALSE) == f@package) { ## current ns might not be loaded yet, catch here diff --git a/R/class-spec.R b/R/class-spec.R index a39e0a910..d80fe4db0 100644 --- a/R/class-spec.R +++ b/R/class-spec.R @@ -247,6 +247,9 @@ S4_validate_old_class <- function(class, object) { ) break } + if (S4_is_reified_S7_class(super_def)) { + next + } validity <- methods::getValidity(super_def) if (is.function(validity)) { diff --git a/tests/testthat/test-S4.R b/tests/testthat/test-S4.R index 6db0d6b03..2d406fb2c 100644 --- a/tests/testthat/test-S4.R +++ b/tests/testthat/test-S4.R @@ -11,6 +11,48 @@ test_that("S4_register registers an S7 class so it can be used with S4 methods", expect_contains(methods::extends("S4regS7"), c("S4regS7", "S7_object")) }) +test_that("S4_register registers S7 property classes", { + defer(S4_remove_classes(c( + "S4regS7PropParent", + "S4regS7PropChild", + "S4regS7PropOther2", + "S4regS7PropFoo", + "S4regS7PropOther1" + ))) + + S4regS7PropOther1 := new_class(package = NULL) + S4regS7PropFoo := new_class( + properties = list(other = S4regS7PropOther1), + package = NULL + ) + + expect_false(methods::isClass("S4regS7PropOther1")) + expect_equal(S4_register(S4regS7PropFoo), "S4regS7PropFoo") + expect_true(methods::isClass("S4regS7PropOther1")) + expect_equal( + as.character(methods::getClass("S4regS7PropFoo")@slots$other), + "S4regS7PropOther1" + ) + expect_true(methods::validObject(S4regS7PropFoo( + other = S4regS7PropOther1() + ))) + + setClass("S4regS7PropParent", slots = list(x = "numeric")) + S4regS7PropOther2 := new_class(package = NULL) + S4regS7PropChild := new_class( + parent = getClass("S4regS7PropParent"), + properties = list(other = S4regS7PropOther2), + package = NULL + ) + object <- S4regS7PropChild( + x = 1, + other = S4regS7PropOther2() + ) + + expect_true(methods::isClass("S4regS7PropOther2")) + expect_true(methods::validObject(object)) +}) + test_that("S4_contains requires prior S4 registration", { on.exit(S4_remove_classes("S4regContainsUnregistered")) S4regContainsUnregistered := new_class(package = NULL) @@ -1047,6 +1089,40 @@ test_that("S4 old-class slots accept normal S3 class vectors", { expect_equal(prop(object, "x"), x) }) +test_that("S7 classes do not import internal slots from S4 parents", { + defer(S4_remove_classes(c( + "S4regImportInternalChild", + "S4regImportInternalParent", + "S4regImportInternalBase" + ))) + + S4regImportInternalBase := new_class( + properties = list(x = class_numeric), + package = NULL + ) + S4_register(S4regImportInternalBase) + setClass( + "S4regImportInternalParent", + contains = S4_contains(S4regImportInternalBase), + slots = list(y = "character") + ) + S4regImportInternalChild := new_class( + parent = getClass("S4regImportInternalParent"), + properties = list(z = class_logical), + package = NULL + ) + + object <- S4regImportInternalChild( + x = 1, + y = "a", + z = TRUE + ) + + expect_equal(names(formals(S4regImportInternalChild)), c("y", "x", "z")) + expect_equal(prop_names(object), c("y", "x", "z")) + expect_true(methods::validObject(object)) +}) + test_that("errors on non-S4 classes", { expect_snapshot(S4_to_S7_class(1), error = TRUE) }) From ac79ae5c13090572b0b9fd374f7a542acc56f8b2 Mon Sep 17 00:00:00 2001 From: Tomasz Kalinowski Date: Wed, 24 Jun 2026 14:13:46 -0400 Subject: [PATCH 091/132] Fix S4 package identity regressions MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit [P2] Preserve S4 class package metadata — /Users/tomasz/github/RConsortium/S7/R/S4.R:102. When the supplied S4 class comes from a package and another S4 class with the same name is visible, `as.character(x@className)` strips the package attribute. This helper is used for S4 parent classes, slot classes, unions, and method signatures, so registration can silently extend or dispatch on the wrong S4 class instead of the class object the caller passed. [P2] Use the captured S4 class for slot defaults — /Users/tomasz/github/RConsortium/S7/R/S4.R:720-724. For virtual S4 parents, omitted slot arguments are filled by evaluating this expression later, but the bare `getClass("name")` lookup can resolve to a different same-named S4 class in the constructor environment. In that case an S7 child of `pkgA::Foo` can inherit prototype defaults from another `Foo`, so the default should preserve the captured class/package identity. [P2] Support callNextMethod in virtual parent initializers — /Users/tomasz/github/RConsortium/S7/R/constructor.R:221. When a virtual S4 parent defines `initialize()` using the common `callNextMethod()` pattern, this calls it with the S7 old-class object whose `class()` vector has multiple entries, and the next default initializer errors instead of constructing the child. Ordinary S4 subclasses of the same virtual parent initialize correctly, so S7 classes extending those parents cannot be constructed. --- R/S4.R | 94 ++++++++++++++++++++++-------- R/constructor.R | 3 + tests/testthat/test-S4.R | 121 +++++++++++++++++++++++++++++++++++++++ 3 files changed, 195 insertions(+), 23 deletions(-) diff --git a/R/S4.R b/R/S4.R index 835cdb5d1..e53d4cd02 100644 --- a/R/S4.R +++ b/R/S4.R @@ -86,7 +86,7 @@ S4_register_union <- function(class, env) { name <- S4_union_name(class, env) methods::setClassUnion( name, - vcapply(class$classes, S4_class, S4_env = env), + lapply(class$classes, S4_class, S4_env = env), where = env ) name @@ -99,13 +99,9 @@ S4_class <- function(x, S4_env, call = sys.call(-1L)) { missing = "missing", any = "ANY", S7_base = base_to_S4(x$class), - S4 = as.character(x@className), - S7 = as.character( - S4_registered_class(x, S4_env, call = call)@className - ), - S7_S3 = as.character( - S4_registered_class(x, S4_env, call = call)@className - ), + S4 = x@className, + S7 = S4_registered_class(x, S4_env, call = call)@className, + S7_S3 = S4_registered_class(x, S4_env, call = call)@className, S7_union = S4_union_class(x, S4_env) ) } @@ -140,11 +136,15 @@ S4_union_class <- function(x, S4_env) { } name <- S4_union_name(x, S4_env) - if (methods::isClass(name, where = S4_env)) { + members <- S4_union_member_classes(x, S4_env) + if ( + methods::isClass(name, where = S4_env) && + S4_union_matches(name, members, S4_env) + ) { return(name) } - name <- S4_find_union(x, S4_env) + name <- S4_find_union(members, S4_env) if (!is.null(name)) { return(name) } @@ -160,10 +160,15 @@ S4_union_name <- function(x, S4_env) { paste0(vcapply(x$classes, S4_class, S4_env = S4_env), collapse = "_OR_") } -S4_find_union <- function(x, S4_env) { - members <- vcapply(x$classes, S4_class, S4_env = S4_env) +S4_union_member_classes <- function(x, S4_env) { + lapply(x$classes, S4_class, S4_env = S4_env) +} + +S4_find_union <- function(members, S4_env) { supers <- lapply(members, S4_direct_superclasses, S4_env = S4_env) - candidates <- base::Reduce(base::intersect, supers) + super_keys <- lapply(supers, S4_class_keys) + candidate_keys <- base::Reduce(base::intersect, super_keys) + candidates <- supers[[1L]][match(candidate_keys, super_keys[[1L]])] matches <- base::Filter( function(candidate) S4_union_matches(candidate, members, S4_env), candidates @@ -172,14 +177,14 @@ S4_find_union <- function(x, S4_env) { return(NULL) } - matches[1L] + matches[[1L]] } S4_direct_superclasses <- function(class, S4_env) { class <- methods::getClass(class, where = S4_env) contains <- class@contains contains <- base::Filter(function(x) x@distance == 1, contains) - names(contains) + lapply(contains, function(x) x@superClass) } S4_union_matches <- function(class, members, S4_env) { @@ -188,12 +193,33 @@ S4_union_matches <- function(class, members, S4_env) { return(FALSE) } - setequal(S4_union_members(class), members) + setequal(S4_class_keys(S4_union_members(class)), S4_class_keys(members)) } S4_union_members <- function(class) { subclasses <- base::Filter(function(x) x@distance == 1, class@subclasses) - vcapply(subclasses, function(x) as.character(x@subClass)) + lapply(subclasses, function(x) x@subClass) +} + +S4_class_keys <- function(classes) { + vcapply(classes, S4_class_key) +} + +S4_class_key <- function(class) { + class <- as.character(class) + package <- attr(class, "package", exact = TRUE) + if (is.null(package) && class %in% S4_methods_class_names()) { + package <- "methods" + } + if (is.null(package)) { + class + } else { + paste0(package, "::", class) + } +} + +S4_methods_class_names <- function() { + c("NULL", "missing", "ANY", names(S4_basic_classes())) } S4_ancestor <- function(class) { @@ -360,6 +386,7 @@ S4_register_class <- function(class, env = parent.frame()) { if (!is.null(parent_class_name)) { parent_slot_names <- S4_slot_names(parent_class_name, where) } + parent_needs_identity <- S4_class_needs_identity(parent_class_name, where) properties <- class@properties stored_properties <- properties[!vlapply(properties, prop_is_dynamic)] @@ -367,20 +394,24 @@ S4_register_class <- function(class, env = parent.frame()) { names(stored_properties), ".Data" )] - slot_properties <- stored_properties[ - !prop_storage_rename(names(stored_properties)) %in% parent_slot_names - ] + slot_properties <- stored_properties + if (!parent_needs_identity) { + slot_properties <- slot_properties[ + !prop_storage_rename(names(slot_properties)) %in% parent_slot_names + ] + } slots <- lapply(slot_properties, S4_property_class, S4_env = where) names(slots) <- prop_storage_rename(names(slot_properties)) needs_S7_class_slot <- !"_S7_class" %in% parent_slot_names if (needs_S7_class_slot) { slots$`_S7_class` <- "S7_class" } + contains <- S4_contains_classes(parent_class_name, where) methods::setClass( Class = class_name, slots = slots, - contains = c(parent_class_name, "VIRTUAL"), + contains = contains, prototype = S4_properties_prototype( prototype_properties, class, @@ -412,6 +443,23 @@ S4_register_class <- function(class, env = parent.frame()) { class_name } +S4_class_needs_identity <- function(class, where) { + if (is.null(class)) { + return(FALSE) + } + + package <- attr(class, "package", exact = TRUE) + !is.null(package) && !identical(package, methods::getPackageName(where)) +} + +S4_contains_classes <- function(parent_class_name, where) { + if (S4_class_needs_identity(parent_class_name, where)) { + list(parent_class_name, "VIRTUAL") + } else { + c(parent_class_name, "VIRTUAL") + } +} + S4_check_slot_storage <- function(class, call = sys.call(-1L)) { nms <- names(class@slots) renamed <- nms[prop_storage_rename(nms) != nms & nms != ".Data"] @@ -713,13 +761,13 @@ S4_slot_property <- function(class, name, owner) { S4_slot_prototype_default <- function(class, name) { if (identical(name, ".Data")) { return(bquote( - methods::getClass(.(as.character(class@className)))@prototype@.Data + methods::getClass(.(class@className))@prototype@.Data )) } bquote( attr( - methods::getClass(.(as.character(class@className)))@prototype, + methods::getClass(.(class@className))@prototype, .(name), exact = TRUE ) diff --git a/R/constructor.R b/R/constructor.R index 0322e8ecf..b69e77268 100644 --- a/R/constructor.R +++ b/R/constructor.R @@ -218,7 +218,10 @@ S4_initialize_parent <- function(class) { return(.Object) } + object_class <- class(.Object) + class(.Object) <- class out <- method(.Object, ...) + class(out) <- object_class validate(out) out } diff --git a/tests/testthat/test-S4.R b/tests/testthat/test-S4.R index 2d406fb2c..226b57fb0 100644 --- a/tests/testthat/test-S4.R +++ b/tests/testthat/test-S4.R @@ -126,6 +126,52 @@ test_that("S4_register registers an S7 union so it can be used with S4 methods", expect_equal(S4regUnionGeneric("x"), "union") }) +test_that("S4_register preserves package-qualified S4 classes", { + pkg_env <- local_package("s4regpkgclasses") + defer({ + if (methods::isGeneric("S4regPackageClassGeneric")) { + methods::removeGeneric("S4regPackageClassGeneric") + } + suppressMessages({ + S4_remove_classes(c( + "S4regPackageClassHolder", + "S4regPackageClassFoo_OR_character", + "S4regPackageClassFoo" + )) + S4_remove_classes("S4regPackageClassFoo", pkg_env) + }) + }) + + setClass("S4regPackageClassFoo", slots = list(x = "character")) + pkg_foo <- methods::setClass( + "S4regPackageClassFoo", + slots = list(x = "numeric"), + where = pkg_env + ) + S4regPackageClassHolder := new_class( + properties = list(x = pkg_foo), + package = NULL + ) + + S4_register(S4regPackageClassHolder) + expect_identical( + methods::getClass("S4regPackageClassHolder")@slots$x, + pkg_foo@className + ) + + union_name <- S4_register(pkg_foo | class_character) + pkg_object <- methods::new(pkg_foo@className, x = 1) + expect_equal(methods::is(pkg_object, union_name), TRUE) + + methods::setGeneric( + "S4regPackageClassGeneric", + function(x) standardGeneric("S4regPackageClassGeneric") + ) + method(S4regPackageClassGeneric, pkg_foo) <- function(x) "package" + + expect_equal(S4regPackageClassGeneric(pkg_object), "package") +}) + test_that("S4_register can reify S7 properties as slots for S4 subclasses", { on.exit({ if (methods::isGeneric("S4regContainsGeneric")) { @@ -682,6 +728,47 @@ test_that("S4 parents preserve slot prototypes in S7 constructors", { expect_equal(prop(object, "x"), 10) }) +test_that("S4 parent prototype defaults preserve package-qualified classes", { + pkg_env <- local_package("s4regpkgdefaults") + defer({ + suppressMessages({ + S4_remove_classes(c( + "S4regPackageDefaultParent", + "S4regPackageDefaultChild" + )) + S4_remove_classes("S4regPackageDefaultParent", pkg_env) + }) + }) + + setClass( + "S4regPackageDefaultParent", + slots = list(x = "character"), + contains = "VIRTUAL", + prototype = list(x = "wrong") + ) + pkg_parent <- methods::setClass( + "S4regPackageDefaultParent", + slots = list(x = "numeric"), + contains = "VIRTUAL", + prototype = list(x = 10), + where = pkg_env + ) + S4regPackageDefaultChild := new_class( + parent = pkg_parent, + package = NULL + ) + + child_def <- methods::getClass("S4regPackageDefaultChild") + expect_identical( + child_def@contains$S4regPackageDefaultParent@superClass, + pkg_parent@className + ) + + suppressMessages(object <- S4regPackageDefaultChild()) + expect_equal(prop(object, "x"), 10) + expect_equal(methods::slot(object, "x"), 10) +}) + test_that("S7 constructors delegate to S4 parent initialize methods", { defer(S4_remove_classes(c( "S4regInitializeParent", @@ -754,6 +841,40 @@ test_that("S7 constructors delegate to virtual S4 parent initialize methods", { expect_equal(prop(object, "y"), "b") }) +test_that("S7 constructors support callNextMethod in virtual S4 parents", { + defer(S4_remove_classes(c( + "S4regVirtualNextParent", + "S4regVirtualNextChild" + ))) + + setClass( + "S4regVirtualNextParent", + slots = list(x = "numeric"), + contains = "VIRTUAL", + prototype = list(x = -1) + ) + methods::setMethod( + "initialize", + "S4regVirtualNextParent", + function(.Object, x = 1, ...) { + .Object <- callNextMethod() + .Object@x <- x * 10 + .Object + } + ) + S4regVirtualNextChild := new_class( + parent = getClass("S4regVirtualNextParent"), + properties = list(y = class_character), + package = NULL + ) + + object <- S4regVirtualNextChild(x = 2, y = "a") + + expect_equal(prop(object, "x"), 20) + expect_equal(methods::slot(object, "x"), 20) + expect_equal(prop(object, "y"), "a") +}) + test_that("S4 prototypes use overridden inherited S7 property defaults", { defer(S4_remove_classes(c( "S4regOverrideParent", From 4acdd30524987c6eaa1e6d1ebff2295194774aa2 Mon Sep 17 00:00:00 2001 From: Tomasz Kalinowski Date: Wed, 24 Jun 2026 14:33:48 -0400 Subject: [PATCH 092/132] Fix S4 initialization metadata handling MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit [P2] Strip S7 metadata from incoming data parts — /Users/tomasz/github/RConsortium/S7/R/S4.R:688-689: When `.Data` is supplied as another S7 vector, `incoming` still contains `_S7_class`/`S7_class`. The merge below can replace the target object's S7 class metadata during `methods::initialize(obj, .Data = other_s7)`, causing initialization to fail with `Property not found` or return an object with the wrong S7 class; strip S7 internal attrs along with `class` before merging. [P2] Avoid introducing an R CMD check NOTE — /Users/tomasz/github/RConsortium/S7/R/S4.R:253-253: This internal `methods:::` call introduces a new R CMD check NOTE (`':::' call which should be '::': methods:::assignClassDef`). For a package checked under CRAN settings, this leaves the patch with a new check NOTE; use a supported methods API or another approach that does not require calling the internal function directly. --- R/S4.R | 4 ++-- tests/testthat/test-S4.R | 30 ++++++++++++++++++++++++++++++ 2 files changed, 32 insertions(+), 2 deletions(-) diff --git a/R/S4.R b/R/S4.R index e53d4cd02..3a50a4d5d 100644 --- a/R/S4.R +++ b/R/S4.R @@ -250,7 +250,7 @@ S4_register_subclass <- function(class, env) { S4_set_S3_class_prototype <- function(class, S3_class, env) { class_def <- methods::getClass(class, where = env) attr(class_def@prototype, ".S3Class") <- S3_class - methods:::assignClassDef(class, class_def, env) + methods::setClass(Class = class, representation = class_def, where = env) invisible(class) } @@ -686,7 +686,7 @@ S4_initialize_values <- function(object) { S4_initialize_data_part <- function(value, object) { incoming <- attributes(value) %||% list() - incoming$class <- NULL + incoming[c("class", "_S7_class", "S7_class")] <- NULL if (isS4(object)) { methods::slot(object, ".Data") <- unclass(value) attributes(object) <- modify_list(attributes(object), incoming) diff --git a/tests/testthat/test-S4.R b/tests/testthat/test-S4.R index 226b57fb0..6e15d07c4 100644 --- a/tests/testthat/test-S4.R +++ b/tests/testthat/test-S4.R @@ -1425,6 +1425,36 @@ test_that("S4 initialize supports S3 data parts", { expect_true(methods::validObject(child)) }) +test_that("S4 initialize strips S7 metadata from data parts", { + defer(S4_remove_classes(c( + "S4regDataPartSource", + "S4regDataPartTarget", + "S4regDataPartParent" + ))) + + setClass("S4regDataPartParent", contains = "numeric") + S4regDataPartTarget := new_class( + parent = getClass("S4regDataPartParent"), + properties = list(y = class_character), + package = NULL + ) + S4regDataPartSource := new_class( + parent = class_double, + properties = list(z = class_character), + package = NULL + ) + + target <- S4regDataPartTarget(.Data = 1, y = "target") + source <- S4regDataPartSource(.data = 2, z = "source") + + out <- methods::initialize(target, .Data = source) + + expect_equal(S7_class(out), S4regDataPartTarget) + expect_equal(as.vector(out), 2) + expect_equal(prop(out, "y"), "target") + expect_identical(methods::validObject(out), TRUE) +}) + test_that("S4 data part constructors use the .Data argument", { defer(S4_remove_classes(c( "S4regDataPartParent", From 299f71571a0f741aa7a8cf9f016089feaec8752d Mon Sep 17 00:00:00 2001 From: Tomasz Kalinowski Date: Wed, 24 Jun 2026 14:54:19 -0400 Subject: [PATCH 093/132] Fix S4 subclass default initialization MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit [P2] Preserve NULL defaults in S4 prototypes — /Users/tomasz/github/RConsortium/S7/R/S4.R:313. When a property default resolves to `NULL`, assigning it with `args[[slot_name]] <- value[[1L]]` removes that element from `args` instead of storing a NULL prototype. For an S7 class that overrides an inherited S4 slot default to `NULL`, S4 subclasses created with `methods::new()` then keep the parent slot prototype while the direct S7 constructor returns `NULL`. [P2] Apply S7 `.Data` defaults to S4 subclasses — /Users/tomasz/github/RConsortium/S7/R/S4.R:668. For S4 vector parents, the prototype `.Data` slot carries the `_S7_class`/`.S3Class` attributes while the newly created object's data part does not, so this `identical()` check is false and deferred `.Data` defaults are skipped. If an S7 child overrides `.Data` (for example parent prototype `1`, child default `quote(2)`), `methods::new()` for an S4 subclass keeps `1` even though `Child()` returns `2`. --- R/S4.R | 43 ++++++++++++++++++++++++---- tests/testthat/test-S4.R | 62 ++++++++++++++++++++++++++++++++++++++++ 2 files changed, 100 insertions(+), 5 deletions(-) diff --git a/R/S4.R b/R/S4.R index 3a50a4d5d..2512111d7 100644 --- a/R/S4.R +++ b/R/S4.R @@ -310,7 +310,7 @@ S4_properties_prototype <- function( value <- S4_property_prototype(properties[[name]], env, class@package) if (length(value) != 0L) { slot_name <- prop_storage_rename(name) - args[[slot_name]] <- value[[1L]] + args[slot_name] <- value } } if (include_S7_class) { @@ -338,12 +338,20 @@ S4_property_prototype <- function(prop, env, package) { ) } -S4_property_deferred_default <- function(prop, env, package) { +S4_property_deferred_default <- function( + prop, + env, + package, + allow_simple = FALSE +) { tryCatch( { value <- prop_default(prop, env, package) value <- S4_decode_pseudo_null(value) if (!is.call(value) && !is.symbol(value)) { + if (allow_simple) { + return(list(value)) + } return(list()) } value <- eval(value, env) @@ -614,6 +622,10 @@ S4_initialize <- function(.Object, ..., .S4_default_env = parent.frame()) { S4_initialize_default_values(.Object, names(vals), .S4_default_env), vals ) + if (".Data" %in% names(vals)) { + .Object <- S4_initialize_data_part(vals$.Data, .Object) + vals$.Data <- NULL + } if (length(vals) > 0L) { props(.Object) <- vals } @@ -651,10 +663,12 @@ S4_initialize_default_values <- function(object, supplied, env) { next } + prop <- properties[[name]] value <- S4_property_deferred_default( - properties[[name]], + prop, env, - class@package + class@package, + allow_simple = identical(name, ".Data") ) if (length(value) != 0L) { values[name] <- value @@ -665,7 +679,26 @@ S4_initialize_default_values <- function(object, supplied, env) { S4_slot_has_prototype_value <- function(object, name) { prototype <- methods::getClass(class(object)[1L])@prototype - identical(methods::slot(object, name), methods::slot(prototype, name)) + value <- methods::slot(object, name) + prototype_value <- methods::slot(prototype, name) + if (identical(value, prototype_value)) { + return(TRUE) + } + if (!identical(name, ".Data")) { + return(FALSE) + } + + identical( + S4_strip_data_part_identity(value), + S4_strip_data_part_identity(prototype_value) + ) +} + +S4_strip_data_part_identity <- function(x) { + attrs <- attributes(x) + attrs[S4_internal_slot_names()] <- NULL + attributes(x) <- attrs + x } S4_initialize_values <- function(object) { diff --git a/tests/testthat/test-S4.R b/tests/testthat/test-S4.R index 6e15d07c4..91f64cde7 100644 --- a/tests/testthat/test-S4.R +++ b/tests/testthat/test-S4.R @@ -903,6 +903,38 @@ test_that("S4 prototypes use overridden inherited S7 property defaults", { expect_equal(prop(object, "x"), 2) }) +test_that("S4 prototypes preserve overridden NULL S7 property defaults", { + defer(S4_remove_classes(c( + "S4regNullOverrideParent", + "S4regNullOverrideChild", + "S4regNullOverrideShim", + "S4regNullOverrideSlot" + ))) + + setClassUnion("S4regNullOverrideSlot", c("character", "NULL")) + setClass( + "S4regNullOverrideParent", + slots = list(x = "S4regNullOverrideSlot"), + prototype = list(x = "parent") + ) + S4regNullOverrideChild <- new_class( + "S4regNullOverrideChild", + parent = getClass("S4regNullOverrideParent"), + properties = list( + x = new_property(NULL | class_character, default = NULL) + ), + package = NULL + ) + S4regNullOverrideChild_S4 <- S4_contains(S4regNullOverrideChild) + setClass("S4regNullOverrideShim", contains = S4regNullOverrideChild_S4) + + expect_equal(prop(S4regNullOverrideChild(), "x"), NULL) + + object <- methods::new("S4regNullOverrideShim") + expect_equal(methods::slot(object, "x"), NULL) + expect_equal(prop(object, "x"), NULL) +}) + test_that("S4_register treats S4 NULL slot sentinels as NULL-valued S7 properties", { on.exit(S4_remove_classes(c( "S4regNullable", @@ -1489,6 +1521,36 @@ test_that("S4 data part constructors use the .Data argument", { expect_true(methods::validObject(object)) }) +test_that("S4 data part constructors use overridden .Data defaults", { + defer(S4_remove_classes(c( + "S4regDataDefaultParent", + "S4regDataDefaultChild", + "S4regDataDefaultShim" + ))) + + setClass( + "S4regDataDefaultParent", + contains = "numeric", + prototype = 1 + ) + S4regDataDefaultChild <- new_class( + "S4regDataDefaultChild", + parent = getClass("S4regDataDefaultParent"), + properties = list( + .Data = new_property(class_numeric, default = quote(2)) + ), + package = NULL + ) + S4regDataDefaultChild_S4 <- S4_contains(S4regDataDefaultChild) + setClass("S4regDataDefaultShim", contains = S4regDataDefaultChild_S4) + + expect_equal(as.vector(S4regDataDefaultChild()), 2) + + object <- methods::new("S4regDataDefaultShim") + expect_equal(as.vector(object), 2) + expect_equal(prop(object, ".Data"), 2) +}) + test_that("S4 data part initialization preserves S4 subclasses", { defer(S4_remove_classes(c( "S4regDataPartGrandChild", From 54bf928236e30d5f57c0f0bc6af730151aec034d Mon Sep 17 00:00:00 2001 From: Tomasz Kalinowski Date: Wed, 24 Jun 2026 15:18:07 -0400 Subject: [PATCH 094/132] Fix S4 initialization review findings Finding 1: [P2] Resolve the prototype from the object's S4 package at R/S4.R:681. `methods::getClass(class(object)[1L])` can fetch the wrong class definition when an S4 subclass is defined in a package namespace and another S4 class with the same name exists earlier in the methods cache, causing `S4_slot_has_prototype_value()` to compare against the wrong prototype and skip or misapply deferred S7 defaults for `methods::new()`. Use the object's package-qualified class definition or the registration environment. Finding 2: [P2] Map renamed S7 property slots before applying named S4 args at R/S4.R:612. For S7 properties whose S4 storage slot is renamed, such as `names` becoming `_names`, calls like `methods::new("Child", `_names` = "x")` pass `_names` through `named_args` to `props<-`, which errors with `Property not found`. Translate named storage slots back to property names before updating `vals`. Finding 3: [P3] Ignore S4 signature widening when no S4 signature exists at R/method-register.R:236-238. For ordinary single-dispatch generics, `S3_generic_S4_signature()` returns `NULL`; if the user passes `signature = list()`, the current condition treats the generic as zero-dispatch and lets the empty signature through until `flatten_signature()` fails with `subscript out of bounds`. Gate the `n` override on a non-NULL S4 signature so invalid empty signatures keep the normal public API error. --- R/S4.R | 29 +++++++++-- R/method-register.R | 2 +- tests/testthat/_snaps/method-register.md | 10 ++++ tests/testthat/test-S4.R | 61 ++++++++++++++++++++++++ tests/testthat/test-method-register.R | 1 + 5 files changed, 98 insertions(+), 5 deletions(-) diff --git a/R/S4.R b/R/S4.R index 2512111d7..0af8ea582 100644 --- a/R/S4.R +++ b/R/S4.R @@ -609,6 +609,9 @@ S4_initialize <- function(.Object, ..., .S4_default_env = parent.frame()) { ) named_args <- named_args[!names(named_args) %in% s4_slot_nms] } + prop_storage_idx <- match(names(named_args), prop_storage_rename(prop_nms)) + names(named_args)[!is.na(prop_storage_idx)] <- + prop_nms[prop_storage_idx[!is.na(prop_storage_idx)]] vals <- modify_list(vals, named_args) if (".Data" %in% names(named_args)) { data_part <- vals$.Data @@ -647,7 +650,7 @@ S4_initialize_prop_values <- function(values, properties, storage = FALSE) { values } -S4_initialize_default_values <- function(object, supplied, env) { +S4_initialize_default_values <- function(object, supplied, S4_env) { class <- S7_class(object) env <- environment(class) properties <- class@properties @@ -659,7 +662,7 @@ S4_initialize_default_values <- function(object, supplied, env) { values <- list() for (name in names(properties)) { slot_name <- prop_storage_rename(name) - if (!S4_slot_has_prototype_value(object, slot_name)) { + if (!S4_slot_has_prototype_value(object, slot_name, S4_env)) { next } @@ -677,8 +680,8 @@ S4_initialize_default_values <- function(object, supplied, env) { values } -S4_slot_has_prototype_value <- function(object, name) { - prototype <- methods::getClass(class(object)[1L])@prototype +S4_slot_has_prototype_value <- function(object, name, S4_env) { + prototype <- S4_object_class(object, S4_env)@prototype value <- methods::slot(object, name) prototype_value <- methods::slot(prototype, name) if (identical(value, prototype_value)) { @@ -694,6 +697,24 @@ S4_slot_has_prototype_value <- function(object, name) { ) } +S4_object_class <- function(object, S4_env) { + class <- class(object) + name <- class[[1L]] + package <- attr(class, "package", exact = TRUE) + if (!is.null(package)) { + class_def <- methods::getClassDef( + name, + package = package, + inherits = FALSE + ) + if (!is.null(class_def)) { + return(class_def) + } + } + + methods::getClass(name, where = S4_env) +} + S4_strip_data_part_identity <- function(x) { attrs <- attributes(x) attrs[S4_internal_slot_names()] <- NULL diff --git a/R/method-register.R b/R/method-register.R index b0ebc5cc5..1ae0fb280 100644 --- a/R/method-register.R +++ b/R/method-register.R @@ -234,7 +234,7 @@ as_signature <- function(signature, generic, call = sys.call(-1L)) { if (is_plain_list(signature)) { S4_signature <- S3_generic_S4_signature(generic) - if (length(signature) == length(S4_signature)) { + if (!is.null(S4_signature) && length(signature) == length(S4_signature)) { n <- length(S4_signature) } } diff --git a/tests/testthat/_snaps/method-register.md b/tests/testthat/_snaps/method-register.md index 3873f0ea7..6f9377671 100644 --- a/tests/testthat/_snaps/method-register.md +++ b/tests/testthat/_snaps/method-register.md @@ -24,6 +24,16 @@ * An S3 class object (from `new_S3_class()`) * An S4 class object * A base class + Code + method(foo, list()) <- (function(x) ...) + Condition + Error in `as_class()`: + ! Can't convert `signature` to a valid class. + Class specification must be one of the following, not a : + * An S7 class object + * An S3 class object (from `new_S3_class()`) + * An S4 class object + * A base class # method unregistration removes an S7 method via NULL assignment diff --git a/tests/testthat/test-S4.R b/tests/testthat/test-S4.R index 91f64cde7..0816c2844 100644 --- a/tests/testthat/test-S4.R +++ b/tests/testthat/test-S4.R @@ -769,6 +769,57 @@ test_that("S4 parent prototype defaults preserve package-qualified classes", { expect_equal(methods::slot(object, "x"), 10) }) +test_that("S4_register resolves S4 prototypes from object class package", { + pkg_env <- local_package("s4regprototypepkg") + defer({ + suppressMessages({ + S4_remove_classes("S4regPkgPrototypeChild") + S4_remove_classes( + c( + "S4regPkgPrototype", + "S4regPkgPrototypeChild" + ), + pkg_env + ) + }) + }) + + setClass( + "S4regPkgPrototypeChild", + slots = list(x = "numeric"), + prototype = list(x = 1) + ) + evalq( + { + S4regPkgPrototype <- new_class( + "S4regPkgPrototype", + properties = list( + x = new_property( + class_numeric, + default = quote({ + 10 + }) + ) + ), + package = NULL + ) + S4_register(S4regPkgPrototype) + S4regPkgPrototype_S4 <- S4_contains(S4regPkgPrototype) + methods::setClass( + "S4regPkgPrototypeChild", + contains = S4regPkgPrototype_S4 + ) + }, + pkg_env + ) + + child_def <- methods::getClass("S4regPkgPrototypeChild", where = pkg_env) + suppressWarnings(object <- methods::new(child_def@className)) + + expect_equal(prop(object, "x"), 10) + expect_equal(methods::slot(object, "x"), 10) +}) + test_that("S7 constructors delegate to S4 parent initialize methods", { defer(S4_remove_classes(c( "S4regInitializeParent", @@ -1619,6 +1670,16 @@ test_that("S4 subclasses read and write special-named S7 property storage slots" expect_equal(prop(object, "names"), "n") expect_true(methods::validObject(object)) + storage_object <- methods::new( + "S4regSpecialSlotsChild", + `_names` = "storage", + `_dim` = 3L + ) + + expect_equal(methods::slot(storage_object, "_names"), "storage") + expect_equal(methods::slot(storage_object, "_dim"), 3L) + expect_equal(prop(storage_object, "names"), "storage") + prop(object, "names") <- "updated" expect_equal(methods::slot(object, "_names"), "updated") expect_equal(methods::slot(object, "names"), "s4-only") diff --git a/tests/testthat/test-method-register.R b/tests/testthat/test-method-register.R index d198c1d3e..45943e30c 100644 --- a/tests/testthat/test-method-register.R +++ b/tests/testthat/test-method-register.R @@ -51,6 +51,7 @@ test_that("method registration checks argument types", { x <- 10 method(x, class_character) <- function(x) ... method(foo, 1) <- function(x) ... + method(foo, list()) <- function(x) ... }) }) From 99fe5a863895e1d099020cc0e37e33c5b232cf26 Mon Sep 17 00:00:00 2001 From: Tomasz Kalinowski Date: Wed, 24 Jun 2026 15:37:22 -0400 Subject: [PATCH 095/132] Fix S4 inheritance matching and dispatch markers MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Finding 1: [P2] Restrict S4 matches to real S4/S7 objects — /Users/tomasz/github/RConsortium/S7/R/class-spec.R:372-372: `S7_inherits(x, getClass("Foo"))` and S4-typed properties can accept plain S3 objects whose class vector contains `Foo`, because `methods::is()` returns true even when `isS4(x)` is false. If the S4 class has no slots or matching attribute-backed slots, `validObject()` can also succeed, so spoofed S3 objects can pass as formal S4 values. Limit the relaxed path to real S4 objects or S7 objects that extend S4. Finding 2: [P2] Avoid duplicating the S7_object dispatch marker — /Users/tomasz/github/RConsortium/S7/R/class-spec.R:325-325: When an S7 class extends an S4 class that already extends an S7 class via `S4_contains()`, `class_dispatch(x@parent)` already ends with `S7_object`. Appending another copy makes `class_dispatch_extends()` drop only one marker and then fail valid inheritance checks, so a later S7 child is not considered to extend its original S7 ancestor, for example when overriding a property typed as that ancestor. --- R/class-spec.R | 20 ++++++++++++++------ tests/testthat/_snaps/inherits.md | 9 +++++++++ tests/testthat/test-class.R | 29 +++++++++++++++++++++++++++++ tests/testthat/test-inherits.R | 11 +++++++++++ 4 files changed, 63 insertions(+), 6 deletions(-) diff --git a/R/class-spec.R b/R/class-spec.R index d80fe4db0..b5d6634ad 100644 --- a/R/class-spec.R +++ b/R/class-spec.R @@ -319,11 +319,19 @@ class_dispatch <- function(x) { missing = "MISSING", any = character(), S4 = S4_class_dispatch(methods::extends(x)), - S7 = c( - S7_class_name(x), - class_dispatch(x@parent), - if (is_S4_class(x@parent)) "S7_object" - ), + S7 = { + parent <- class_dispatch(x@parent) + c( + S7_class_name(x), + parent, + if ( + is_S4_class(x@parent) && + !identical(tail(parent, 1), "S7_object") + ) { + "S7_object" + } + ) + }, S7_base = c(x$class, "S7_object"), S7_S3 = c(x$class, "S7_object"), stop2("Unsupported class type.", call = NULL) @@ -369,7 +377,7 @@ class_inherits <- function(x, what) { "NULL" = is.null(x), missing = FALSE, any = TRUE, - S4 = methods::is(x, what), + S4 = inherits_S4(x) && methods::is(x, what), S7 = has_S7_class(x) && inherits(x, S7_class_name(what)), S7_base = what$class == base_class(x), S7_union = any(vlapply(what$classes, class_inherits, x = x)), diff --git a/tests/testthat/_snaps/inherits.md b/tests/testthat/_snaps/inherits.md index 354d4fd81..2f9c0dd9e 100644 --- a/tests/testthat/_snaps/inherits.md +++ b/tests/testthat/_snaps/inherits.md @@ -1,3 +1,12 @@ +# S4 class checks reject spoofed S3 objects + + Code + holder(x = spoof) + Condition + Error in `holder()`: + ! object properties are invalid: + - @x must be S4, not S3 + # checks that input is a class Code diff --git a/tests/testthat/test-class.R b/tests/testthat/test-class.R index e7f0aaa5b..c1e41eb7c 100644 --- a/tests/testthat/test-class.R +++ b/tests/testthat/test-class.R @@ -171,6 +171,35 @@ test_that("inheritance lets child properties narrow to S4 subclasses of S7 class expect_s4_class(S4PropertyChild(x = x)@x, "S4PropertyS7Child") }) +test_that("inheritance lets S7-over-S4 children narrow to original S7 parents", { + defer(S4_remove_classes(c( + "S4PropertyS7Bridge", + "S4PropertyS7Descendant", + "S4PropertyS7Ancestor" + ))) + + S4PropertyS7Ancestor := new_class(package = NULL) + S4_register(S4PropertyS7Ancestor) + setClass("S4PropertyS7Bridge", contains = S4_contains(S4PropertyS7Ancestor)) + S4PropertyS7Descendant := new_class( + parent = getClass("S4PropertyS7Bridge"), + package = NULL + ) + + Parent := new_class( + properties = list(x = S4PropertyS7Ancestor), + package = NULL + ) + + expect_no_error({ + Child := new_class( + parent = Parent, + properties = list(x = S4PropertyS7Descendant), + package = NULL + ) + }) +}) + test_that("inheritance doesn't let child properties narrow S7_object with base or S3 classes", { Parent <- new_class( "Parent", diff --git a/tests/testthat/test-inherits.R b/tests/testthat/test-inherits.R index 1b155dfaf..7250c53e1 100644 --- a/tests/testthat/test-inherits.R +++ b/tests/testthat/test-inherits.R @@ -26,6 +26,17 @@ test_that("accepts any class specification (#556)", { expect_true(S7_inherits("anything", class_any)) }) +test_that("S4 class checks reject spoofed S3 objects", { + Foo := local_S4_class() + Child := new_class(parent = Foo, package = NULL) + holder := new_class(properties = list(x = Foo), package = NULL) + spoof <- structure(list(), class = "Foo") + + expect_true(S7_inherits(Child(), Foo)) + expect_false(S7_inherits(spoof, Foo)) + expect_snapshot(error = TRUE, holder(x = spoof)) +}) + test_that("checks that input is a class", { expect_snapshot(S7_inherits(1:10, "x"), error = TRUE) }) From c318a5a9fbe60c585c5dce003c62f251e3fd39fa Mon Sep 17 00:00:00 2001 From: Tomasz Kalinowski Date: Wed, 24 Jun 2026 15:53:14 -0400 Subject: [PATCH 096/132] Fix S4 slot validation and local generic registration MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit [P1] Allow valid non-S4 values for S4 slot properties — /Users/tomasz/github/RConsortium/S7/R/class-spec.R:380. When an S4 parent has slots such as `x = "ANY"` or `x = "matrix"`, those slots become S7 properties whose class is an S4 class, but this guard rejects ordinary values before `methods::is()` can accept them. For example, `new_class(parent = getClass("ParentWithAnySlot"))(x = 1)` fails even though S4 slot validation accepts `1` for `ANY`, and matrix slots similarly reject matrices, making common S4 parents unusable. [P2] Avoid leaking S4 methods for local S3 generics — /Users/tomasz/github/RConsortium/S7/R/method-register-S3.R:33-34. For a local S3 generic whose name matches an internal generic, e.g. `dim <- function(x) UseMethod("dim")`, registering an S7/S4-backed method now also calls `setMethod("dim", ...)` because the check only looks at the name. That installs a global S4 method for base `dim`, so a method intended only for the local generic can change unrelated base/S4 dispatch. --- R/class-spec.R | 13 +++++++++- R/method-register-S4.R | 20 +++++++++++---- tests/testthat/test-class.R | 11 ++++++++ tests/testthat/test-method-register-S3.R | 32 ++++++++++++++++++++++++ 4 files changed, 70 insertions(+), 6 deletions(-) diff --git a/R/class-spec.R b/R/class-spec.R index b5d6634ad..2aafbf6dc 100644 --- a/R/class-spec.R +++ b/R/class-spec.R @@ -377,7 +377,7 @@ class_inherits <- function(x, what) { "NULL" = is.null(x), missing = FALSE, any = TRUE, - S4 = inherits_S4(x) && methods::is(x, what), + S4 = inherits_S4_class(x, what), S7 = has_S7_class(x) && inherits(x, S7_class_name(what)), S7_base = what$class == base_class(x), S7_union = any(vlapply(what$classes, class_inherits, x = x)), @@ -481,5 +481,16 @@ union_contains_any <- function(x) { is_union(x) && any(vlapply(x$classes, is_class_any)) } +inherits_S4_class <- function(x, what) { + if (identical(as.character(what@className), "ANY")) { + return(TRUE) + } + if (!inherits_S4(x) && is.object(x)) { + return(FALSE) + } + + methods::is(x, what) +} + # Suppress direct S4 representation slot false positives globalVariables(c("className", "contains", "simple")) diff --git a/R/method-register-S4.R b/R/method-register-S4.R index 170e20da8..2417eaef2 100644 --- a/R/method-register-S4.R +++ b/R/method-register-S4.R @@ -11,7 +11,7 @@ register_S4_method <- function( } should_register_S4_method <- function(generic, signature) { - is_internal_generic(generic$name) && signature_has_S4_ancestor(signature) + is_internal_S3_generic(generic) && signature_has_S4_ancestor(signature) } signature_has_S4_ancestor <- function(signature) { @@ -28,10 +28,7 @@ class_has_S4_ancestor <- function(class) { } S3_generic_S4_signature <- function(generic) { - if ( - !(is_S3_generic(generic) || is_external_S3_generic(generic)) || - !is_internal_generic(generic$name) - ) { + if (!is_internal_S3_generic(generic)) { return(NULL) } @@ -47,3 +44,16 @@ is_external_S3_generic <- function(generic) { is_external_generic(generic) && identical(generic$dispatch_args, "__S3__") } + +is_internal_S3_generic <- function(generic) { + if (is_S3_generic(generic)) { + return( + is_internal_generic(generic$name) && + identical(find_base_name(generic$generic), generic$name) + ) + } + + is_external_S3_generic(generic) && + identical(generic$package, "base") && + is_internal_generic(generic$name) +} diff --git a/tests/testthat/test-class.R b/tests/testthat/test-class.R index c1e41eb7c..5deae97e0 100644 --- a/tests/testthat/test-class.R +++ b/tests/testthat/test-class.R @@ -73,6 +73,17 @@ test_that("S7 classes can inherit from S4 but not class unions", { ) }) +test_that("S7 classes accept ordinary values for S4 parent slots", { + Parent := local_S4_class(slots = list(x = "ANY", y = "matrix")) + Child := new_class(parent = Parent, package = NULL) + + y <- matrix(1, nrow = 1) + obj <- Child(x = 1, y = y) + + expect_equal(obj@x, 1) + expect_equal(obj@y, y) +}) + test_that("S7_class can be used as a property name", { foo <- new_class( "foo", diff --git a/tests/testthat/test-method-register-S3.R b/tests/testthat/test-method-register-S3.R index 77ba65a5d..c92eb4030 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("local S3 generics named like internal generics don't register S4 methods", { + defer({ + suppressWarnings(try( + methods::removeMethod("dim", "S4LocalDimChild"), + silent = TRUE + )) + S4_remove_classes(c( + "S4LocalDimParent", + "S4LocalDimChild" + )) + }) + + setClass("S4LocalDimParent", contains = "VIRTUAL") + S4LocalDimChild := new_class( + parent = getClass("S4LocalDimParent"), + properties = list(x = class_integer), + package = NULL + ) + dim <- local(function(x) UseMethod("dim")) + defer(unregister_s3_methods(topenv(environment(dim)), "dim")) + + method(dim, S4LocalDimChild) <- function(x) c(x@x, 2L) + + expect_equal(dim(S4LocalDimChild(x = 1L)), c(1L, 2L)) + expect_null(methods::selectMethod( + "dim", + "S4LocalDimChild", + optional = TRUE, + useInherited = FALSE + )) +}) + test_that("internal replacement generics can register full S4 signatures", { on.exit({ try( From e76182cb510d0acf9dd9a29b7d74549ca506ae7d Mon Sep 17 00:00:00 2001 From: Tomasz Kalinowski Date: Wed, 24 Jun 2026 16:13:09 -0400 Subject: [PATCH 097/132] Fix S4 bridge validation regressions MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit [P2] Avoid skipping S4 parent validity — /Users/tomasz/github/RConsortium/S7/R/valid.R:84: When an S4 subclass is created with `contains = S4_contains()`, the S4 ancestor is treated as already validated, so `validate()` never reaches `class_validate()` for that S4 parent. S7 mutation paths such as `prop<-`, `props<-`, and `methods::initialize()` can then accept values that satisfy the slot type but violate the S4 validity method until `methods::validObject()` is called separately. [P2] Initialize virtual S4 parents before validation — /Users/tomasz/github/RConsortium/S7/R/constructor.R:189: For a virtual S4 parent, the generated constructor calls `.S7_new_object` before `.S4_initialize_parent`, and `.S7_new_object` validates the child immediately. If the virtual parent has an intentionally invalid prototype that its `initialize()` method repairs, `Child()` can fail before initialization produces a valid object. [P2] Qualify the new tail call — /Users/tomasz/github/RConsortium/S7/R/class-spec.R:329: `tail()` is newly referenced from package code but is not imported or namespace-qualified, causing `R CMD check` to report `class_dispatch: no visible global function definition for 'tail'`. Qualify this call or import `utils::tail` to avoid a new check NOTE. --- R/class-spec.R | 4 +- R/constructor.R | 17 +++++++- R/valid.R | 6 ++- tests/testthat/_snaps/S4.md | 27 +++++++++++++ tests/testthat/test-S4.R | 80 +++++++++++++++++++++++++++++++++++++ 5 files changed, 128 insertions(+), 6 deletions(-) diff --git a/R/class-spec.R b/R/class-spec.R index 2aafbf6dc..3bec4b979 100644 --- a/R/class-spec.R +++ b/R/class-spec.R @@ -200,7 +200,7 @@ class_constructor <- function(.x) { class_validate <- function(class, object) { if (is_S4_class(class)) { - if (!isS4(object) && has_S7_class(object)) { + if (has_S7_class(object)) { return(S4_validate_old_class(class, object)) } @@ -326,7 +326,7 @@ class_dispatch <- function(x) { parent, if ( is_S4_class(x@parent) && - !identical(tail(parent, 1), "S7_object") + !identical(utils::tail(parent, 1), "S7_object") ) { "S7_object" } diff --git a/R/constructor.R b/R/constructor.R index b69e77268..252aa35f2 100644 --- a/R/constructor.R +++ b/R/constructor.R @@ -162,8 +162,15 @@ new_S4_constructor <- function(parent, properties, envir, package) { names(parent_value_args) <- parent_value_nms self_value_args <- as_names(names2(self_args)) - parent_seed <- if (".Data" %in% parent_nms) { - if (parent@virtual) quote(.Data) else quote(.parent_values[[".Data"]]) + parent_seed <- if (parent@virtual) { + quote(.parent_seed) + } else if (".Data" %in% parent_nms) { + quote(.parent_values[[".Data"]]) + } else { + quote(.S7_object()) + } + virtual_parent_seed <- if (".Data" %in% parent_nms) { + quote(.Data) } else { quote(.S7_object()) } @@ -186,7 +193,10 @@ new_S4_constructor <- function(parent, properties, envir, package) { quote(.parent_args <- list()), parent_arg_exprs, list( + bquote(.parent_seed <- .(virtual_parent_seed)), + quote(attr(.parent_seed, ".should_validate") <- FALSE), bquote(.object <- .(new_object_call)), + quote(attr(.object, ".should_validate") <- NULL), quote(do.call(.S4_initialize_parent, c(list(.object), .parent_args))) ) )) @@ -215,6 +225,8 @@ S4_initialize_parent <- function(class) { function(.Object, ...) { method <- methods::selectMethod("initialize", class) if (methods::is(method, "derivedDefaultMethod")) { + attr(.Object, ".should_validate") <- NULL + validate(.Object) return(.Object) } @@ -222,6 +234,7 @@ S4_initialize_parent <- function(class) { class(.Object) <- class out <- method(.Object, ...) class(out) <- object_class + attr(out, ".should_validate") <- NULL validate(out) out } diff --git a/R/valid.R b/R/valid.R index 71d62ba43..f812623a1 100644 --- a/R/valid.R +++ b/R/valid.R @@ -80,8 +80,10 @@ validate_parent <- function(object, recursive) { return(S7_class(object)@parent) } - if (isS4(object) && has_S7_class(object)) { - return(S4_ancestor(S7_class(object)) %||% S7_object) + if ( + isS4(object) && has_S7_class(object) && !S7_extends_S4(S7_class(object)) + ) { + return(S7_object) } NULL diff --git a/tests/testthat/_snaps/S4.md b/tests/testthat/_snaps/S4.md index 3633b89a1..2e7e12eeb 100644 --- a/tests/testthat/_snaps/S4.md +++ b/tests/testthat/_snaps/S4.md @@ -44,6 +44,33 @@ Error: ! Unsupported S4 object: must be a class generator or a class definition, not a . +# S4 subclasses of S7-over-S4 classes run S4 parent validity + + Code + prop(object, "x") <- numeric() + Condition + Error: + ! S4 object is invalid: + - x must have length 1 + +--- + + Code + props(object) <- list(x = numeric()) + Condition + Error in `validate()`: + ! S4 object is invalid: + - x must have length 1 + +--- + + Code + methods::initialize(object, x = numeric()) + Condition + Error in `validate()`: + ! S4 object is invalid: + - x must have length 1 + # S4 parents reject slots that need renamed S7 storage Code diff --git a/tests/testthat/test-S4.R b/tests/testthat/test-S4.R index 0816c2844..c43c0823d 100644 --- a/tests/testthat/test-S4.R +++ b/tests/testthat/test-S4.R @@ -892,6 +892,47 @@ test_that("S7 constructors delegate to virtual S4 parent initialize methods", { expect_equal(prop(object, "y"), "b") }) +test_that("S7 constructors validate virtual S4 parents after initialize", { + defer(S4_remove_classes(c( + "S4regVirtualRepairParent", + "S4regVirtualRepairChild" + ))) + + setClass( + "S4regVirtualRepairParent", + slots = list(x = "numeric"), + contains = "VIRTUAL", + prototype = list(x = numeric()) + ) + methods::setValidity("S4regVirtualRepairParent", function(object) { + if (length(methods::slot(object, "x")) != 1) { + "x must have length 1" + } else { + TRUE + } + }) + methods::setMethod( + "initialize", + "S4regVirtualRepairParent", + function(.Object, x = 1, ...) { + .Object <- callNextMethod(.Object, ...) + .Object@x <- x + .Object + } + ) + S4regVirtualRepairChild := new_class( + parent = getClass("S4regVirtualRepairParent"), + properties = list(y = class_character), + package = NULL + ) + + object <- S4regVirtualRepairChild(y = "a") + + expect_equal(prop(object, "x"), 1) + expect_equal(prop(object, "y"), "a") + expect_true(methods::validObject(object)) +}) + test_that("S7 constructors support callNextMethod in virtual S4 parents", { defer(S4_remove_classes(c( "S4regVirtualNextParent", @@ -1417,6 +1458,45 @@ test_that("S7 classes run S4 parent validity", { expect_error(validate(object), "x must have length 1") }) +test_that("S4 subclasses of S7-over-S4 classes run S4 parent validity", { + defer(S4_remove_classes(c( + "S4regSubValidityParent", + "S4regSubValidityChild", + "S4regSubValidityShim" + ))) + + setClass("S4regSubValidityParent", slots = list(x = "numeric")) + methods::setValidity("S4regSubValidityParent", function(object) { + if (length(methods::slot(object, "x")) != 1) { + "x must have length 1" + } else { + TRUE + } + }) + S4regSubValidityChild := new_class( + parent = getClass("S4regSubValidityParent"), + properties = list(y = class_character), + package = NULL + ) + S4regSubValidityChild_S4 <- S4_contains(S4regSubValidityChild) + setClass("S4regSubValidityShim", contains = S4regSubValidityChild_S4) + + object <- methods::new("S4regSubValidityShim", x = 1, y = "a") + expect_snapshot(error = TRUE, { + prop(object, "x") <- numeric() + }) + + object <- methods::new("S4regSubValidityShim", x = 1, y = "a") + expect_snapshot(error = TRUE, { + props(object) <- list(x = numeric()) + }) + + object <- methods::new("S4regSubValidityShim", x = 1, y = "a") + expect_snapshot(error = TRUE, { + methods::initialize(object, x = numeric()) + }) +}) + test_that("S4 initialization sets S4 slots on subclasses of S7 classes", { on.exit(S4_remove_classes(c( "ParentForSlots", From 52a9ba758c626c591871a1915052687713fada4c Mon Sep 17 00:00:00 2001 From: Tomasz Kalinowski Date: Wed, 24 Jun 2026 16:40:39 -0400 Subject: [PATCH 098/132] Fix S4 registration and data-part collisions [P2] /Users/tomasz/github/RConsortium/S7/R/S4.R:745: Strip colliding data-part attributes before slot assignment. When `.Data` is a vector or S4 object carrying an attribute named like an S7 property/S4 slot, assigning `unclass(value)` to the `.Data` slot copies that attribute onto the S4 object and overwrites the slot before S7 validation runs. Strip formal slot/S7/internal attributes from the data value before assigning or merging them. [P2] /Users/tomasz/github/RConsortium/S7/R/S4.R:120: Verify the S4 class belongs to the S7 class. If an unrelated S4 class with the same `class_register()` name already exists, `S4_contains(Foo)` can return the unrelated class name even though `S4_register()` was never called for the S7 class. Check that the returned class carries the matching `_S7_class`/old-class registration before treating it as registered. --- R/S4.R | 43 ++++++++++++++++++++++++++++++++++--- tests/testthat/_snaps/S4.md | 8 +++++++ tests/testthat/test-S4.R | 40 ++++++++++++++++++++++++++++++++++ 3 files changed, 88 insertions(+), 3 deletions(-) diff --git a/R/S4.R b/R/S4.R index 0af8ea582..f562e9935 100644 --- a/R/S4.R +++ b/R/S4.R @@ -120,7 +120,7 @@ S4_registered_class <- function(x, S4_env, call = sys.call(-1L)) { methods::getClass(class_register(x), where = S4_env), error = function(err) NULL ) - if (is.null(class)) { + if (is.null(class) || !S4_registered_class_matches(class, x)) { msg <- sprintf( "Class has not been registered with S4; please call S4_register(%s).", class_deparse(x) @@ -130,6 +130,29 @@ S4_registered_class <- function(x, S4_env, call = sys.call(-1L)) { class } +S4_registered_class_matches <- function(class, x) { + S4_registered_S7_class_matches(class, x) || + S4_registered_old_class_matches(class, x) +} + +S4_registered_S7_class_matches <- function(class, x) { + if (!"_S7_class" %in% names(class@slots)) { + return(FALSE) + } + registered <- methods::slot(class@prototype, "_S7_class") + is_class(registered) && identical(S7_class_name(registered), S7_class_name(x)) +} + +S4_registered_old_class_matches <- function(class, x) { + if (!".S3Class" %in% names(class@slots)) { + return(FALSE) + } + identical( + methods::slot(class@prototype, ".S3Class"), + S4_reified_old_classes(x) + ) +} + S4_union_class <- function(x, S4_env) { if (identical(x, class_numeric)) { return("numeric") @@ -739,18 +762,32 @@ S4_initialize_values <- function(object) { } S4_initialize_data_part <- function(value, object) { + protected <- S4_data_part_protected_attributes(object) incoming <- attributes(value) %||% list() - incoming[c("class", "_S7_class", "S7_class")] <- NULL + incoming[protected] <- NULL if (isS4(object)) { - methods::slot(object, ".Data") <- unclass(value) + data <- zap_attr(unclass(value), protected) + methods::slot(object, ".Data") <- data attributes(object) <- modify_list(attributes(object), incoming) return(object) } + value <- zap_attr(value, protected) attributes(value) <- modify_list(attributes(object), incoming) value } +S4_data_part_protected_attributes <- function(object) { + c( + methods::slotNames(object), + prop_storage_names(object), + prop_names(object), + "class", + "_S7_class", + "S7_class" + ) +} + is_S4_class <- function(x) inherits(x, "classRepresentation") S4_to_S7_class <- function(x, error_base = "", call = sys.call(-1L)) { diff --git a/tests/testthat/_snaps/S4.md b/tests/testthat/_snaps/S4.md index 2e7e12eeb..60207189b 100644 --- a/tests/testthat/_snaps/S4.md +++ b/tests/testthat/_snaps/S4.md @@ -1,3 +1,11 @@ +# S4_contains rejects unrelated S4 classes with the same name + + Code + S4_contains(S4regContainsCollision) + Condition + Error in `S4_contains()`: + ! Class has not been registered with S4; please call S4_register(S4regContainsCollision). + # S4 subclasses reject internal S7/S4 slots during initialization Code diff --git a/tests/testthat/test-S4.R b/tests/testthat/test-S4.R index c43c0823d..f758cb4a8 100644 --- a/tests/testthat/test-S4.R +++ b/tests/testthat/test-S4.R @@ -70,6 +70,17 @@ test_that("S4_contains requires prior S4 registration", { ) }) +test_that("S4_contains rejects unrelated S4 classes with the same name", { + defer(S4_remove_classes("S4regContainsCollision")) + setClass("S4regContainsCollision", slots = list(x = "numeric")) + S4regContainsCollision := new_class(package = NULL) + + expect_snapshot( + S4_contains(S4regContainsCollision), + error = TRUE + ) +}) + test_that("S4_register registers S4 old classes as virtual S7_object descendants", { on.exit(S4_remove_classes(c("S4regParent", "S4regS7New"))) setClass("S4regParent", slots = list(x = "numeric")) @@ -1618,6 +1629,35 @@ test_that("S4 initialize strips S7 metadata from data parts", { expect_identical(methods::validObject(out), TRUE) }) +test_that("S4 initialize ignores data-part attributes that collide with slots", { + defer(S4_remove_classes(c( + "S4regDataAttrParent", + "S4regDataAttrChild" + ))) + + setClass( + "S4regDataAttrParent", + contains = "numeric", + slots = list(z = "character") + ) + S4regDataAttrChild := new_class( + parent = getClass("S4regDataAttrParent"), + properties = list(y = class_character), + package = NULL + ) + + target <- S4regDataAttrChild(.Data = 1, y = "target", z = "slot") + source <- structure(2, y = "source", z = "source-slot", other = "keep") + + out <- methods::initialize(target, .Data = source) + + expect_equal(as.vector(out), 2) + expect_equal(prop(out, "y"), "target") + expect_equal(prop(out, "z"), "slot") + expect_equal(attr(out, "other", exact = TRUE), "keep") + expect_identical(methods::validObject(out), TRUE) +}) + test_that("S4 data part constructors use the .Data argument", { defer(S4_remove_classes(c( "S4regDataPartParent", From 4aad829433c358a31491b131e18be245fc8a34ff Mon Sep 17 00:00:00 2001 From: Tomasz Kalinowski Date: Wed, 24 Jun 2026 16:59:10 -0400 Subject: [PATCH 099/132] Fix S4 registration and validation review findings [P1] Handle base-backed S7 classes in S4_register: When `S4_register()` is called for an S7 class whose parent is a base type like `class_integer`, it falls through to `NULL`, so `setClass()` creates a virtual S4 class with no integer data part and the later `setOldClass(c("Int", "integer", "S7_object"), S4Class = "Int")` fails. This regresses the documented S4 registration path for base-backed S7 classes; the S4 representation needs to include the base parent before calling `setOldClass()` (`R/S4.R:522-526`). [P2] Validate concrete S4 subclasses after property updates: When an object is an S4 subclass created via `S4_contains()`, `prop<-`/`props<-` call `validate()`, which only runs S7 validators and never calls `methods::validObject()` for the concrete S4 class. If the S4 subclass has a validity method that depends on an S7 property, updating that property can return an object for which `validObject()` fails, despite S7 property replacement normally validating before returning (`R/valid.R:69-75`). [P2] Map S4 ANY slots to class_any: When an S4 parent has a slot declared as `ANY`, the current map leaves `getClass("ANY")` as an S4 class instead of converting it to `class_any`. A child cannot narrow that slot with a normal S7 class, e.g. `new_class(parent = getClass("P"), properties = list(x = class_numeric))` errors, although S4 allows `numeric` to narrow `ANY`; this blocks common S4 parents that use `ANY` slots (`R/S4.R:869-875`). --- R/S4.R | 3 ++ R/valid.R | 21 ++++++++++++ tests/testthat/_snaps/S4.md | 18 ++++++++++ tests/testthat/test-S4.R | 68 +++++++++++++++++++++++++++++++++++++ 4 files changed, 110 insertions(+) diff --git a/R/S4.R b/R/S4.R index f562e9935..449740103 100644 --- a/R/S4.R +++ b/R/S4.R @@ -519,6 +519,8 @@ S4_reified_parent_class <- function(class, env) { return(NULL) } return(S4_register(parent_class, env)) + } else if (is_base_class(parent_class)) { + return(S4_class(parent_class, env)) } else if (is_S4_class(parent_class)) { return(S4_class(parent_class, env)) } @@ -868,6 +870,7 @@ S4_slot_prototype_default <- function(class, name) { S4_basic_classes <- function() { list( NULL = NULL, + ANY = class_any, logical = class_logical, integer = class_integer, double = class_double, diff --git a/R/valid.R b/R/valid.R index f812623a1..706533bef 100644 --- a/R/valid.R +++ b/R/valid.R @@ -139,6 +139,8 @@ validate_from <- function( class <- class@parent } + errors <- c(errors, validate_S4_subclass(object)) + # If needed, report errors if (length(errors) > 0) { bullets <- paste0("- ", errors, collapse = "\n") @@ -149,6 +151,25 @@ validate_from <- function( invisible(object) } +validate_S4_subclass <- function(object) { + if (!isS4(object) || !has_S7_class(object)) { + return(NULL) + } + + class <- methods::getClass(class(object)[[1L]]) + if (S4_is_reified_S7_class(class)) { + return(NULL) + } + + validity <- class@validity + if (!is.function(validity)) { + return(NULL) + } + + check <- validity(object) + if (isTRUE(check)) NULL else check +} + validate_properties <- function(object, class, parent_class = NULL) { errors <- character() parent_props <- if (is_class(parent_class)) parent_class@properties diff --git a/tests/testthat/_snaps/S4.md b/tests/testthat/_snaps/S4.md index 60207189b..f465f6e2e 100644 --- a/tests/testthat/_snaps/S4.md +++ b/tests/testthat/_snaps/S4.md @@ -79,6 +79,24 @@ ! S4 object is invalid: - x must have length 1 +# S4 subclasses of S7 classes run concrete S4 validity + + Code + prop(object, "x") <- numeric() + Condition + Error: + ! S4 object is invalid: + - x must have length 1 + +--- + + Code + props(object) <- list(x = numeric()) + Condition + Error in `validate()`: + ! S4 object is invalid: + - x must have length 1 + # S4 parents reject slots that need renamed S7 storage Code diff --git a/tests/testthat/test-S4.R b/tests/testthat/test-S4.R index f758cb4a8..48530b9c4 100644 --- a/tests/testthat/test-S4.R +++ b/tests/testthat/test-S4.R @@ -11,6 +11,21 @@ test_that("S4_register registers an S7 class so it can be used with S4 methods", expect_contains(methods::extends("S4regS7"), c("S4regS7", "S7_object")) }) +test_that("S4_register registers S7 classes with base parents", { + defer(S4_remove_classes("S4regS7Integer")) + + S4regS7Integer := new_class(parent = class_integer, package = NULL) + + expect_equal(S4_register(S4regS7Integer), "S4regS7Integer") + expect_contains(methods::extends("S4regS7Integer"), "integer") + + object <- S4regS7Integer(.data = 1L) + expect_equal(class(object), c("S4regS7Integer", "integer", "S7_object")) + expect_true(methods::is(object, "integer")) + expect_true(methods::is(object, "S7_object")) + expect_true(methods::validObject(object)) +}) + test_that("S4_register registers S7 property classes", { defer(S4_remove_classes(c( "S4regS7PropParent", @@ -1256,9 +1271,28 @@ test_that("S4_register errors on unsupported inputs", { test_that("converts S4 base classes to S7 base classes", { expect_equal(S4_to_S7_class(getClass("NULL")), NULL) + expect_equal(S4_to_S7_class(getClass("ANY")), class_any) expect_equal(S4_to_S7_class(getClass("character")), class_character) }) +test_that("S4 ANY slots can be narrowed by S7 children", { + defer(S4_remove_classes(c( + "S4regAnySlotChild", + "S4regAnySlotParent" + ))) + + setClass("S4regAnySlotParent", slots = list(x = "ANY")) + S4regAnySlotChild := new_class( + parent = getClass("S4regAnySlotParent"), + properties = list(x = class_numeric), + package = NULL + ) + + object <- S4regAnySlotChild(x = 1) + expect_equal(prop(object, "x"), 1) + expect_true(methods::validObject(object)) +}) + test_that("converts S4 unions to S7 unions", { Foo1 := local_S4_class(slots = "x") Foo2 := local_S4_class(slots = "x") @@ -1508,6 +1542,40 @@ test_that("S4 subclasses of S7-over-S4 classes run S4 parent validity", { }) }) +test_that("S4 subclasses of S7 classes run concrete S4 validity", { + defer(S4_remove_classes(c( + "S4regConcreteValidityParent", + "S4regConcreteValidityChild" + ))) + + S4regConcreteValidityParent := new_class( + properties = list(x = class_numeric), + package = NULL + ) + S4_register(S4regConcreteValidityParent) + setClass( + "S4regConcreteValidityChild", + contains = S4_contains(S4regConcreteValidityParent) + ) + methods::setValidity("S4regConcreteValidityChild", function(object) { + if (length(prop(object, "x")) != 1) { + "x must have length 1" + } else { + TRUE + } + }) + + object <- methods::new("S4regConcreteValidityChild", x = 1) + expect_snapshot(error = TRUE, { + prop(object, "x") <- numeric() + }) + + object <- methods::new("S4regConcreteValidityChild", x = 1) + expect_snapshot(error = TRUE, { + props(object) <- list(x = numeric()) + }) +}) + test_that("S4 initialization sets S4 slots on subclasses of S7 classes", { on.exit(S4_remove_classes(c( "ParentForSlots", From 2ead8808be3a8e6caaa930d8bf551df8953d0562 Mon Sep 17 00:00:00 2001 From: Tomasz Kalinowski Date: Wed, 24 Jun 2026 17:24:46 -0400 Subject: [PATCH 100/132] Fix S4-backed registration and validation MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit [P2] Preserve the caller env when adding S4 methods — /Users/tomasz/github/RConsortium/S7/R/method-register-S3.R:34-34: When the internal S3 generic is a base closure such as `unlist()` or `as.vector()`, line 29 replaces `envir` with the locked base namespace for `registerS3method()`. The new S4 registration then calls `setMethod(..., where = baseenv())`, so `method(unlist, S4BackedS7) <- ...` errors instead of registering; keep using the caller/package env for the S4 method. [P2] Run inherited S4 validity methods during S7 validation — /Users/tomasz/github/RConsortium/S7/R/valid.R:159-164: For an S4 class that extends an S7 class and also contains another S4 superclass with a validity method, `prop<-`/`methods::initialize()` reach `validate()` but this helper only calls the concrete class's `@validity`. Superclass validity that `methods::validObject()` would reject is skipped, so public S7 property updates can return S4 objects that are invalid. --- R/class-spec.R | 13 +++++-- R/method-register-S3.R | 3 +- R/valid.R | 12 +++--- tests/testthat/_snaps/S4.md | 27 +++++++++++++ tests/testthat/test-S4.R | 48 ++++++++++++++++++++++++ tests/testthat/test-method-register-S3.R | 35 +++++++++++++++++ 6 files changed, 127 insertions(+), 11 deletions(-) diff --git a/R/class-spec.R b/R/class-spec.R index 3bec4b979..6c74abd20 100644 --- a/R/class-spec.R +++ b/R/class-spec.R @@ -223,7 +223,7 @@ class_validate <- function(class, object) { } } -S4_validate_old_class <- function(class, object) { +S4_validate_old_class <- function(class, object, skip = character()) { any_strings <- function(x) { if (isTRUE(x)) character() else x } @@ -232,6 +232,9 @@ S4_validate_old_class <- function(class, object) { extends <- rev(class@contains) for (ext in extends) { super_class <- ext@superClass + if (super_class %in% skip) { + next + } if (!ext@simple && !methods::is(object, super_class)) { next } @@ -263,9 +266,11 @@ S4_validate_old_class <- function(class, object) { } } - validity <- methods::getValidity(class) - if (length(errors) == 0L && is.function(validity)) { - errors <- c(errors, any_strings(validity(object))) + if (!as.character(class@className) %in% skip) { + validity <- methods::getValidity(class) + if (length(errors) == 0L && is.function(validity)) { + errors <- c(errors, any_strings(validity(object))) + } } if (length(errors) == 0L) { diff --git a/R/method-register-S3.R b/R/method-register-S3.R index 2c9f0a5c3..c9d81dfe8 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/R/valid.R b/R/valid.R index 706533bef..f6a3c5a25 100644 --- a/R/valid.R +++ b/R/valid.R @@ -161,13 +161,13 @@ validate_S4_subclass <- function(object) { return(NULL) } - validity <- class@validity - if (!is.function(validity)) { - return(NULL) - } + ancestor <- S4_ancestor(S7_class(object)) + skip <- if (is.null(ancestor)) character() else S4_validity_classes(ancestor) + S4_validate_old_class(class, object, skip = skip) +} - check <- validity(object) - if (isTRUE(check)) NULL else check +S4_validity_classes <- function(class) { + c(vcapply(class@contains, slot, "superClass"), as.character(class@className)) } validate_properties <- function(object, class, parent_class = NULL) { diff --git a/tests/testthat/_snaps/S4.md b/tests/testthat/_snaps/S4.md index f465f6e2e..03e2a7356 100644 --- a/tests/testthat/_snaps/S4.md +++ b/tests/testthat/_snaps/S4.md @@ -97,6 +97,33 @@ ! S4 object is invalid: - x must have length 1 +# S4 subclasses of S7 classes run inherited S4 validity + + Code + prop(object, "x") <- "b" + Condition + Error: + ! S4 object is invalid: + - y must be non-negative + +--- + + Code + props(object) <- list(x = "b") + Condition + Error in `validate()`: + ! S4 object is invalid: + - y must be non-negative + +--- + + Code + methods::initialize(object, x = "b") + Condition + Error in `validate()`: + ! S4 object is invalid: + - y must be non-negative + # S4 parents reject slots that need renamed S7 storage Code diff --git a/tests/testthat/test-S4.R b/tests/testthat/test-S4.R index 48530b9c4..2e7386357 100644 --- a/tests/testthat/test-S4.R +++ b/tests/testthat/test-S4.R @@ -1576,6 +1576,54 @@ test_that("S4 subclasses of S7 classes run concrete S4 validity", { }) }) +test_that("S4 subclasses of S7 classes run inherited S4 validity", { + defer(S4_remove_classes(c( + "S4regInheritedValidityParent", + "S4regInheritedValidityS7", + "S4regInheritedValidityChild" + ))) + + setClass("S4regInheritedValidityParent", slots = list(y = "numeric")) + methods::setValidity("S4regInheritedValidityParent", function(object) { + y <- methods::slot(object, "y") + if (length(y) > 0 && any(y < 0)) { + "y must be non-negative" + } else { + TRUE + } + }) + S4regInheritedValidityS7 := new_class( + properties = list(x = class_character), + package = NULL + ) + S4_register(S4regInheritedValidityS7) + setClass( + "S4regInheritedValidityChild", + contains = c( + S4_contains(S4regInheritedValidityS7), + "S4regInheritedValidityParent" + ) + ) + + object <- methods::new("S4regInheritedValidityChild", x = "a", y = 1) + methods::slot(object, "y") <- -1 + expect_snapshot(error = TRUE, { + prop(object, "x") <- "b" + }) + + object <- methods::new("S4regInheritedValidityChild", x = "a", y = 1) + methods::slot(object, "y") <- -1 + expect_snapshot(error = TRUE, { + props(object) <- list(x = "b") + }) + + object <- methods::new("S4regInheritedValidityChild", x = "a", y = 1) + methods::slot(object, "y") <- -1 + expect_snapshot(error = TRUE, { + methods::initialize(object, x = "b") + }) +}) + test_that("S4 initialization sets S4 slots on subclasses of S7 classes", { on.exit(S4_remove_classes(c( "ParentForSlots", diff --git a/tests/testthat/test-method-register-S3.R b/tests/testthat/test-method-register-S3.R index c92eb4030..45fecdb62 100644 --- a/tests/testthat/test-method-register-S3.R +++ b/tests/testthat/test-method-register-S3.R @@ -86,6 +86,41 @@ 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({ + suppressWarnings(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("local S3 generics named like internal generics don't register S4 methods", { defer({ suppressWarnings(try( From 01b4b4e258f1a2d410afc616e745200fc9e0c3a6 Mon Sep 17 00:00:00 2001 From: Tomasz Kalinowski Date: Wed, 24 Jun 2026 17:48:15 -0400 Subject: [PATCH 101/132] Fix S4 registration review findings MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit [P2] Preserve registered S7 classes from S4 slot types — /Users/tomasz/github/RConsortium/S7/R/S4.R:819-823: When an S4 parent has a slot declared as a registered S7 class, this branch falls through to returning the S4 class representation instead of recovering the `_S7_class` stored on the reified S4 class. The generated S7 child then validates the slot as an S4 class, so `Child(foo = Foo())` fails even though `methods::new('Holder', foo = Foo())` and `methods::is(Foo(), 'Foo')` both succeed. [P2] Require the registered S7 class object to match — /Users/tomasz/github/RConsortium/S7/R/S4.R:143: If an S7 class is redefined with the same package/name but different properties, this name-only comparison lets `S4_contains(new_Foo)` reuse the stale S4 registration from the old `Foo`. S4 subclasses created after that get the old slots and `_S7_class`, so construction, dispatch, and validation use the wrong S7 class unless `S4_register()` is called again. [P3] Qualify slot in the validity helper — /Users/tomasz/github/RConsortium/S7/R/valid.R:170: With this unqualified `slot` call, `R CMD check` reports `S4_validity_classes: no visible binding for global variable 'slot'` on this patch. Qualify it as `methods::slot` or otherwise register/import it so package checks stay clean. --- R/S4.R | 17 +++++++++-- R/valid.R | 5 +++- tests/testthat/_snaps/S4.md | 8 +++++ tests/testthat/test-S4.R | 59 +++++++++++++++++++++++++++++++++++++ 4 files changed, 86 insertions(+), 3 deletions(-) diff --git a/R/S4.R b/R/S4.R index 449740103..ba41c8199 100644 --- a/R/S4.R +++ b/R/S4.R @@ -131,8 +131,13 @@ S4_registered_class <- function(x, S4_env, call = sys.call(-1L)) { } S4_registered_class_matches <- function(class, x) { - S4_registered_S7_class_matches(class, x) || + if (S4_registered_S7_class_matches(class, x)) { + TRUE + } else if (!"_S7_class" %in% names(class@slots)) { S4_registered_old_class_matches(class, x) + } else { + FALSE + } } S4_registered_S7_class_matches <- function(class, x) { @@ -140,7 +145,11 @@ S4_registered_S7_class_matches <- function(class, x) { return(FALSE) } registered <- methods::slot(class@prototype, "_S7_class") - is_class(registered) && identical(S7_class_name(registered), S7_class_name(x)) + is_class(registered) && S4_registered_S7_class_object_matches(registered, x) +} + +S4_registered_S7_class_object_matches <- function(registered, x) { + identical(registered, x) || isTRUE(all.equal(registered, x)) } S4_registered_old_class_matches <- function(class, x) { @@ -816,6 +825,10 @@ S4_to_S7_class <- function(x, error_base = "", call = sys.call(-1L)) { return(basic_classes[[x@className]]) } } + if (S4_is_reified_S7_class(x)) { + class <- methods::slot(x@prototype, "_S7_class") + return(class) + } if (is_S3_oldClass(x)) { new_S3_class(S3_oldClass_classes(x)) } else { diff --git a/R/valid.R b/R/valid.R index f6a3c5a25..c9cd80c25 100644 --- a/R/valid.R +++ b/R/valid.R @@ -167,7 +167,10 @@ validate_S4_subclass <- function(object) { } S4_validity_classes <- function(class) { - c(vcapply(class@contains, slot, "superClass"), as.character(class@className)) + c( + vcapply(class@contains, methods::slot, "superClass"), + as.character(class@className) + ) } validate_properties <- function(object, class, parent_class = NULL) { diff --git a/tests/testthat/_snaps/S4.md b/tests/testthat/_snaps/S4.md index 03e2a7356..3a0ae7bda 100644 --- a/tests/testthat/_snaps/S4.md +++ b/tests/testthat/_snaps/S4.md @@ -6,6 +6,14 @@ Error in `S4_contains()`: ! Class has not been registered with S4; please call S4_register(S4regContainsCollision). +# S4_contains rejects stale S4 registrations + + Code + S4_contains(S4regStale) + Condition + Error in `S4_contains()`: + ! Class has not been registered with S4; please call S4_register(S4regStale). + # S4 subclasses reject internal S7/S4 slots during initialization Code diff --git a/tests/testthat/test-S4.R b/tests/testthat/test-S4.R index 2e7386357..d5c3b8e1c 100644 --- a/tests/testthat/test-S4.R +++ b/tests/testthat/test-S4.R @@ -68,6 +68,31 @@ test_that("S4_register registers S7 property classes", { expect_true(methods::validObject(object)) }) +test_that("S4 parent slots declared as registered S7 classes use S7 classes", { + defer(S4_remove_classes(c( + "S4regSlotS7Child", + "S4regSlotS7Holder", + "S4regSlotS7Foo" + ))) + + S4regSlotS7Foo := new_class(package = NULL) + S4_register(S4regSlotS7Foo) + methods::setClass( + Class = "S4regSlotS7Holder", + slots = list(foo = "S4regSlotS7Foo") + ) + S4regSlotS7Child := new_class( + parent = methods::getClass("S4regSlotS7Holder"), + package = NULL + ) + + object <- S4regSlotS7Child(foo = S4regSlotS7Foo()) + + expect_equal(S4regSlotS7Child@properties$foo$class, S4regSlotS7Foo) + expect_equal(S7_inherits(prop(object, "foo"), S4regSlotS7Foo), TRUE) + expect_equal(methods::validObject(object), TRUE) +}) + test_that("S4_contains requires prior S4 registration", { on.exit(S4_remove_classes("S4regContainsUnregistered")) S4regContainsUnregistered := new_class(package = NULL) @@ -96,6 +121,40 @@ test_that("S4_contains rejects unrelated S4 classes with the same name", { ) }) +test_that("S4_contains rejects stale S4 registrations", { + defer(S4_remove_classes(c( + "S4regStaleChild", + "S4regStale" + ))) + + S4regStale := new_class( + properties = list(x = class_numeric), + package = NULL + ) + S4_register(S4regStale) + + S4regStale := new_class( + properties = list(y = class_character), + package = NULL + ) + expect_snapshot(error = TRUE, { + S4_contains(S4regStale) + }) + + S4_register(S4regStale) + methods::setClass( + Class = "S4regStaleChild", + contains = S4_contains(S4regStale) + ) + object <- methods::new("S4regStaleChild", y = "new") + + expect_equal(prop(object, "y"), "new") + expect_equal( + intersect("x", methods::slotNames("S4regStaleChild")), + character() + ) +}) + test_that("S4_register registers S4 old classes as virtual S7_object descendants", { on.exit(S4_remove_classes(c("S4regParent", "S4regS7New"))) setClass("S4regParent", slots = list(x = "numeric")) From 6cbb08abfb2c3ff283ef70191e4b4c611f5e9cb7 Mon Sep 17 00:00:00 2001 From: Tomasz Kalinowski Date: Wed, 24 Jun 2026 18:29:36 -0400 Subject: [PATCH 102/132] Defer S4 validation during initialization --- R/S4.R | 5 ++--- tests/testthat/_snaps/S4.md | 9 +++++++++ tests/testthat/test-S4.R | 40 +++++++++++++++++++++++++++++++++++++ 3 files changed, 51 insertions(+), 3 deletions(-) diff --git a/R/S4.R b/R/S4.R index ba41c8199..698c7675a 100644 --- a/R/S4.R +++ b/R/S4.R @@ -663,12 +663,11 @@ S4_initialize <- function(.Object, ..., .S4_default_env = parent.frame()) { .Object <- S4_initialize_data_part(vals$.Data, .Object) vals$.Data <- NULL } - if (length(vals) > 0L) { - props(.Object) <- vals - } + props(.Object, check = FALSE) <- vals for (name in names(s4_vals)) { methods::slot(.Object, name) <- s4_vals[[name]] } + validate(.Object) .Object } diff --git a/tests/testthat/_snaps/S4.md b/tests/testthat/_snaps/S4.md index 3a0ae7bda..b71021518 100644 --- a/tests/testthat/_snaps/S4.md +++ b/tests/testthat/_snaps/S4.md @@ -105,6 +105,15 @@ ! S4 object is invalid: - x must have length 1 +# S4 initialization validates after S4-only slots are set + + Code + methods::new("S4regInitValidityChild", z = -1) + Condition + Error in `validate()`: + ! S4 object is invalid: + - z must be non-negative + # S4 subclasses of S7 classes run inherited S4 validity Code diff --git a/tests/testthat/test-S4.R b/tests/testthat/test-S4.R index d5c3b8e1c..431f53360 100644 --- a/tests/testthat/test-S4.R +++ b/tests/testthat/test-S4.R @@ -1635,6 +1635,46 @@ test_that("S4 subclasses of S7 classes run concrete S4 validity", { }) }) +test_that("S4 initialization validates after S4-only slots are set", { + defer(S4_remove_classes(c( + "S4regInitValidityParent", + "S4regInitValidityChild" + ))) + + S4regInitValidityParent := new_class( + properties = list(x = class_numeric), + package = NULL + ) + S4_register(S4regInitValidityParent) + setClass( + "S4regInitValidityChild", + contains = S4_contains(S4regInitValidityParent), + slots = list(z = "numeric"), + prototype = list(z = NA_real_) + ) + methods::setValidity("S4regInitValidityChild", function(object) { + z <- methods::slot(object, "z") + if (is.na(z) || z < 0) { + "z must be non-negative" + } else { + TRUE + } + }) + + object <- methods::new("S4regInitValidityChild", x = 1, z = 2) + expect_equal(prop(object, "x"), 1) + expect_equal(methods::slot(object, "z"), 2) + expect_true(methods::validObject(object)) + + object <- methods::new("S4regInitValidityChild", z = 2) + expect_equal(methods::slot(object, "z"), 2) + expect_true(methods::validObject(object)) + + expect_snapshot(error = TRUE, { + methods::new("S4regInitValidityChild", z = -1) + }) +}) + test_that("S4 subclasses of S7 classes run inherited S4 validity", { defer(S4_remove_classes(c( "S4regInheritedValidityParent", From 3ebcc35d247a6738c1fa09c70f285bb537103ab7 Mon Sep 17 00:00:00 2001 From: Tomasz Kalinowski Date: Wed, 24 Jun 2026 18:41:15 -0400 Subject: [PATCH 103/132] Preserve S4 class package during validation MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit [P2] Preserve the S4 class package during validation — /Users/tomasz/github/RConsortium/S7/R/valid.R:159-159: When validating an S4 subclass of an S7 class whose concrete S4 class is defined in a package, class(object)[[1L]] drops the package attribute before getClass(). If another loaded class has the same name, this can look up the wrong class and skip the package class's validity method, so validate() can pass objects that methods::validObject() rejects. Use the package-qualified class information from class(object) when resolving the S4 definition. --- R/valid.R | 2 +- tests/testthat/_snaps/S4.md | 9 +++++++ tests/testthat/test-S4.R | 47 +++++++++++++++++++++++++++++++++++++ 3 files changed, 57 insertions(+), 1 deletion(-) diff --git a/R/valid.R b/R/valid.R index c9cd80c25..e08f27990 100644 --- a/R/valid.R +++ b/R/valid.R @@ -156,7 +156,7 @@ validate_S4_subclass <- function(object) { return(NULL) } - class <- methods::getClass(class(object)[[1L]]) + class <- methods::getClass(class(object)) if (S4_is_reified_S7_class(class)) { return(NULL) } diff --git a/tests/testthat/_snaps/S4.md b/tests/testthat/_snaps/S4.md index b71021518..606ec4da4 100644 --- a/tests/testthat/_snaps/S4.md +++ b/tests/testthat/_snaps/S4.md @@ -105,6 +105,15 @@ ! S4 object is invalid: - x must have length 1 +# S4 subclass validation preserves concrete class package + + Code + validate(object) + Condition + Error in `validate()`: + ! S4 object is invalid: + - x must have length 1 + # S4 initialization validates after S4-only slots are set Code diff --git a/tests/testthat/test-S4.R b/tests/testthat/test-S4.R index 431f53360..4e08f0ab8 100644 --- a/tests/testthat/test-S4.R +++ b/tests/testthat/test-S4.R @@ -1635,6 +1635,53 @@ test_that("S4 subclasses of S7 classes run concrete S4 validity", { }) }) +test_that("S4 subclass validation preserves concrete class package", { + pkg_env <- local_package("s4regvalidpkg") + defer({ + suppressMessages({ + S4_remove_classes(c( + "S4regPackageValidityParent", + "S4regPackageValidityChild" + )) + S4_remove_classes("S4regPackageValidityChild", pkg_env) + }) + }) + + S4regPackageValidityParent := new_class( + properties = list(x = class_numeric), + package = NULL + ) + S4_register(S4regPackageValidityParent) + setClass("S4regPackageValidityChild") + pkg_child <- methods::setClass( + "S4regPackageValidityChild", + contains = S4_contains(S4regPackageValidityParent), + where = pkg_env + ) + methods::setValidity( + pkg_child@className, + function(object) { + if (length(prop(object, "x")) != 1) { + "x must have length 1" + } else { + TRUE + } + }, + where = pkg_env + ) + + object <- methods::new(pkg_child@className, x = 1) + methods::slot(object, "x") <- numeric() + + expect_match( + methods::validObject(object, test = TRUE), + "x must have length 1" + ) + expect_snapshot(error = TRUE, { + validate(object) + }) +}) + test_that("S4 initialization validates after S4-only slots are set", { defer(S4_remove_classes(c( "S4regInitValidityParent", From 5b5e917e2d093eab3d6d26fd434e29aeb5ff6793 Mon Sep 17 00:00:00 2001 From: Tomasz Kalinowski Date: Wed, 24 Jun 2026 19:01:31 -0400 Subject: [PATCH 104/132] Fix S3 S4 registration matching MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit [P2] Do not append S7_object when matching S3 registrations — /Users/tomasz/github/RConsortium/S7/R/S4.R:159-162. When `x` is `new_S3_class("foo")`, `S4_register()` registers only `class$class` with `setOldClass()`, so the S4 prototype's `.S3Class` is just `"foo"`. This comparison uses `S4_reified_old_classes(x)`, which appends `"S7_object"` for S3 class specs, so a class that was just registered is treated as unregistered; `method(g, new_S3_class("foo")) <- ...` for an S4 generic still errors. --- R/S4.R | 3 ++- tests/testthat/test-method-register-S4.R | 16 ++++++++++++++++ 2 files changed, 18 insertions(+), 1 deletion(-) diff --git a/R/S4.R b/R/S4.R index 698c7675a..6954cbadc 100644 --- a/R/S4.R +++ b/R/S4.R @@ -156,9 +156,10 @@ S4_registered_old_class_matches <- function(class, x) { if (!".S3Class" %in% names(class@slots)) { return(FALSE) } + classes <- if (is_S3_class(x)) x$class else S4_reified_old_classes(x) identical( methods::slot(class@prototype, ".S3Class"), - S4_reified_old_classes(x) + classes ) } diff --git a/tests/testthat/test-method-register-S4.R b/tests/testthat/test-method-register-S4.R index 7bc10c977..0dc48d52d 100644 --- a/tests/testthat/test-method-register-S4.R +++ b/tests/testthat/test-method-register-S4.R @@ -11,6 +11,22 @@ test_that("can register S7 method for S4 generic", { expect_equal(bar(S4foo()), "foo") }) +test_that("can register S3 method for S4 generic", { + methods::setGeneric("s4_s3", function(x) standardGeneric("s4_s3")) + defer({ + suppressMessages(methods::removeGeneric("s4_s3")) + S4_remove_classes("S4regS3Method") + }) + + S4regS3Method <- new_S3_class("S4regS3Method") + S4_register(S4regS3Method) + + method(s4_s3, S4regS3Method) <- function(x) "s3" + + object <- structure(list(), class = "S4regS3Method") + expect_equal(s4_s3(object), "s3") +}) + test_that("can register S4 methods for base types, class_any, class_missing, and NULL", { methods::setGeneric("s4_gen", function(x) standardGeneric("s4_gen")) method(s4_gen, class_character) <- function(x) "char" From b1969ae3ee14a77fbe99cc8832c352cae8dc9625 Mon Sep 17 00:00:00 2001 From: Tomasz Kalinowski Date: Wed, 24 Jun 2026 19:29:41 -0400 Subject: [PATCH 105/132] Fix S4 name identity checks MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit [P2] Verify S7 targets before S4 coercion — /Users/tomasz/github/RConsortium/S7/R/convert.R:275. When `to` is an S7 class, this asks S4 about only `class_register(to)`. If an unrelated S4 class with the same name has a `setAs()` path from an S4 `from`, `convert()` returns that S4 object instead of an instance of the requested S7 class. Restrict this fallback to S4 targets, or first verify that the S4 class name is the registered representation of `to`. [P2] Reject unrelated S4 name matches for S7 parents — /Users/tomasz/github/RConsortium/S7/R/class-spec.R:416-417. If an S7 parent shares its name with an unrelated S4 class, this treats any S4 subclass of that S4 class as a valid narrowing of the S7 property. `new_class()` then accepts an override that cannot satisfy the parent property validation. Check that the S4 class is the S4 registration for `parent` before accepting `extends()`. [P2] Preserve S4 member packages in unions — /Users/tomasz/github/RConsortium/S7/R/S4.R:87-90. When a union member is an S4 class from another package and a same-named S4 class exists elsewhere, `setClassUnion()` ends up registering the union against the bare class name. For example, registering `pkg::Foo | class_character` also makes a global `Foo` satisfy the union. Preserve the member package identity when creating the S4 union. --- R/S4.R | 100 ++++++++++++++++++++++++++++--- R/class-spec.R | 6 +- R/convert.R | 15 ++++- tests/testthat/_snaps/S4.md | 11 ++++ tests/testthat/_snaps/convert.md | 10 ++++ tests/testthat/test-S4.R | 34 +++++++++++ tests/testthat/test-convert.R | 24 ++++++++ 7 files changed, 186 insertions(+), 14 deletions(-) diff --git a/R/S4.R b/R/S4.R index 6954cbadc..840f0808e 100644 --- a/R/S4.R +++ b/R/S4.R @@ -84,11 +84,13 @@ S4_contains <- function(class, env = parent.frame()) { S4_register_union <- function(class, env) { name <- S4_union_name(class, env) + members <- S4_union_member_classes(class, env, register = TRUE) methods::setClassUnion( name, - lapply(class$classes, S4_class, S4_env = env), + members, where = env ) + S4_register_union_member_extensions(class$classes, members, env) name } @@ -116,16 +118,25 @@ base_to_S4 <- function(class) { } S4_registered_class <- function(x, S4_env, call = sys.call(-1L)) { + class <- S4_registered_class_or_null(x, S4_env) + if (!is.null(class)) { + return(class) + } + + msg <- sprintf( + "Class has not been registered with S4; please call S4_register(%s).", + class_deparse(x) + ) + stop2(msg, call = call) +} + +S4_registered_class_or_null <- function(x, S4_env) { class <- tryCatch( methods::getClass(class_register(x), where = S4_env), error = function(err) NULL ) if (is.null(class) || !S4_registered_class_matches(class, x)) { - msg <- sprintf( - "Class has not been registered with S4; please call S4_register(%s).", - class_deparse(x) - ) - stop2(msg, call = call) + return(NULL) } class } @@ -193,11 +204,78 @@ S4_union_name <- function(x, S4_env) { paste0(vcapply(x$classes, S4_class, S4_env = S4_env), collapse = "_OR_") } -S4_union_member_classes <- function(x, S4_env) { - lapply(x$classes, S4_class, S4_env = S4_env) +S4_union_member_classes <- function(x, S4_env, register = FALSE) { + lapply( + x$classes, + S4_union_member_class, + S4_env = S4_env, + register = register + ) +} + +S4_union_member_class <- function(x, S4_env, register = FALSE) { + if (!is_S4_class(x)) { + return(S4_class(x, S4_env)) + } + + if (!S4_class_needs_identity(x@className, S4_env)) { + return(x@className) + } + + name <- S4_class_name(x) + if (register && !methods::isClass(name, where = S4_env)) { + methods::setClass(name, contains = "VIRTUAL", where = S4_env) + } + name +} + +S4_register_union_member_extensions <- function(classes, members, S4_env) { + for (i in seq_along(classes)) { + S4_register_union_member_extension(classes[[i]], members[[i]], S4_env) + } + invisible() +} + +S4_register_union_member_extension <- function(class, member, S4_env) { + if ( + !is_S4_class(class) || !S4_class_needs_identity(class@className, S4_env) + ) { + return(invisible()) + } + + member_def <- methods::getClass(member, where = S4_env) + subclasses <- base::Filter(function(x) x@distance == 1, member_def@subclasses) + if ( + S4_class_key(class@className) %in% + S4_class_keys(S4_extension_subclasses(subclasses)) + ) { + return(invisible()) + } + + package <- attr(class@className, "package", exact = TRUE) + suppressWarnings(methods::setIs( + class@className, + member, + where = S4_env, + classDef = class, + test = S4_class_package_test(package) + )) + invisible() +} + +S4_class_package_test <- function(package) { + new_function( + alist(object = ), + bquote(identical(attr(class(object), "package", exact = TRUE), .(package))), + baseenv() + ) } S4_find_union <- function(members, S4_env) { + if (!all(vlapply(members, methods::isClass, where = S4_env))) { + return(NULL) + } + supers <- lapply(members, S4_direct_superclasses, S4_env = S4_env) super_keys <- lapply(supers, S4_class_keys) candidate_keys <- base::Reduce(base::intersect, super_keys) @@ -231,7 +309,11 @@ S4_union_matches <- function(class, members, S4_env) { S4_union_members <- function(class) { subclasses <- base::Filter(function(x) x@distance == 1, class@subclasses) - lapply(subclasses, function(x) x@subClass) + S4_extension_subclasses(subclasses) +} + +S4_extension_subclasses <- function(x) { + lapply(x, function(x) x@subClass) } S4_class_keys <- function(classes) { diff --git a/R/class-spec.R b/R/class-spec.R index 6c74abd20..5a973d725 100644 --- a/R/class-spec.R +++ b/R/class-spec.R @@ -412,9 +412,9 @@ class_extends <- function(child, parent) { # as a parent, NULL only accepts NULL is.null(child) } else if (is_S4_class(child) && is_class(parent)) { - parent_class <- S7_class_name(parent) - methods::isClass(parent_class) && - methods::extends(child@className, parent_class) + parent_class <- S4_registered_class_or_null(parent, environment(parent)) + !is.null(parent_class) && + methods::extends(child@className, parent_class@className) } else if (is_S4_class(child) || is_S4_class(parent)) { if (!is_S4_class(parent)) { FALSE diff --git a/R/convert.R b/R/convert.R index 405a92760..a44ba493d 100644 --- a/R/convert.R +++ b/R/convert.R @@ -264,7 +264,16 @@ convert_down <- function(from, to, user_args = list()) { } s4_to_name <- function(x) { - if (is_S4_class(x)) x@className else class_register(x) + if (is_S4_class(x)) { + return(x@className) + } + + class <- S4_registered_class_or_null(x, environment(x)) + if (is.null(class)) { + NULL + } else { + class@className + } } is_S4_coerce <- function(from, to) { @@ -272,7 +281,9 @@ is_S4_coerce <- function(from, to) { if (!inherits_S4(from) && !is_S4_class(to)) { return(FALSE) } - methods::canCoerce(from, s4_to_name(to)) + + to_name <- s4_to_name(to) + !is.null(to_name) && methods::canCoerce(from, to_name) } convert_S4 <- function(from, to, ...) { diff --git a/tests/testthat/_snaps/S4.md b/tests/testthat/_snaps/S4.md index 606ec4da4..bbccac005 100644 --- a/tests/testthat/_snaps/S4.md +++ b/tests/testthat/_snaps/S4.md @@ -160,6 +160,17 @@ ! Can't extend S4 class S4 because slot "names" would need renamed S7 storage. These S4 slots can not be represented safely on direct S7 child objects. +# S7 property narrowing rejects unrelated S4 name matches + + Code + new_class("S4regPropertyNameCollisionOverride", parent = Parent, properties = list( + x = getClass("S4regPropertyNameCollisionChild")), package = NULL) + Condition + Error in `new_class()`: + ! @x must narrow @x. + - @x is . + - @x is S4. + # S4_package_name errors if originating package can't be found Code diff --git a/tests/testthat/_snaps/convert.md b/tests/testthat/_snaps/convert.md index 20714db1c..20d2bb399 100644 --- a/tests/testthat/_snaps/convert.md +++ b/tests/testthat/_snaps/convert.md @@ -6,6 +6,16 @@ Error in `as.double()`: ! cannot coerce type 'object' to vector of type 'double' +# fallback convert rejects unrelated S4 name matches for S7 targets + + Code + convert(from, to = ConvertS4NameCollisionTo) + Condition + Error in `convert()`: + ! Can't find method with dispatch classes: + - from: S4 + - to : + # convert() errors when upcasting to an abstract class (#680) Code diff --git a/tests/testthat/test-S4.R b/tests/testthat/test-S4.R index 4e08f0ab8..0171cec96 100644 --- a/tests/testthat/test-S4.R +++ b/tests/testthat/test-S4.R @@ -220,6 +220,7 @@ test_that("S4_register preserves package-qualified S4 classes", { suppressMessages({ S4_remove_classes(c( "S4regPackageClassHolder", + "S4/s4regpkgclasses::S4regPackageClassFoo", "S4regPackageClassFoo_OR_character", "S4regPackageClassFoo" )) @@ -246,7 +247,12 @@ test_that("S4_register preserves package-qualified S4 classes", { union_name <- S4_register(pkg_foo | class_character) pkg_object <- methods::new(pkg_foo@className, x = 1) + global_object <- methods::new( + methods::getClass("S4regPackageClassFoo"), + x = "wrong" + ) expect_equal(methods::is(pkg_object, union_name), TRUE) + expect_equal(methods::is(global_object, union_name), FALSE) methods::setGeneric( "S4regPackageClassGeneric", @@ -2168,6 +2174,34 @@ test_that("S4 parents reject slots that need renamed S7 storage", { }) }) +test_that("S7 property narrowing rejects unrelated S4 name matches", { + defer(S4_remove_classes(c( + "S4regPropertyNameCollisionChild", + "S4regPropertyNameCollisionParent" + ))) + + setClass("S4regPropertyNameCollisionParent") + setClass( + "S4regPropertyNameCollisionChild", + contains = "S4regPropertyNameCollisionParent" + ) + + S4regPropertyNameCollisionParent := new_class(package = NULL) + Parent := new_class( + properties = list(x = S4regPropertyNameCollisionParent), + package = NULL + ) + + expect_snapshot(error = TRUE, { + new_class( + "S4regPropertyNameCollisionOverride", + parent = Parent, + properties = list(x = getClass("S4regPropertyNameCollisionChild")), + package = NULL + ) + }) +}) + test_that("S4_class_dispatch returns name of base class", { Foo1 := local_S4_class(slots = list("x" = "numeric")) diff --git a/tests/testthat/test-convert.R b/tests/testthat/test-convert.R index 1812b6b28..9a79f8b49 100644 --- a/tests/testthat/test-convert.R +++ b/tests/testthat/test-convert.R @@ -257,6 +257,30 @@ test_that("fallback convert can use explicit S4 coercion via methods::as", { expect_equal(methods::slot(res, "z"), "42") }) +test_that("fallback convert rejects unrelated S4 name matches for S7 targets", { + defer(S4_remove_classes(c( + "ConvertS4NameCollisionFrom", + "ConvertS4NameCollisionTo" + ))) + + setClass("ConvertS4NameCollisionFrom", slots = list(x = "numeric")) + setClass("ConvertS4NameCollisionTo", slots = list(y = "numeric")) + ConvertS4NameCollisionTo := new_class(package = NULL) + + setAs( + "ConvertS4NameCollisionFrom", + "ConvertS4NameCollisionTo", + function(from) { + new("ConvertS4NameCollisionTo", y = methods::slot(from, "x")) + } + ) + + from <- methods::new("ConvertS4NameCollisionFrom", x = 1) + expect_snapshot(error = TRUE, { + convert(from, to = ConvertS4NameCollisionTo) + }) +}) + test_that("is_down_cast() is TRUE only when `to` descends from `from` (#509)", { Base := new_class(package = NULL) A := new_class( From bab78abad22083b8bb2157bd36808049ee21d46c Mon Sep 17 00:00:00 2001 From: Tomasz Kalinowski Date: Wed, 24 Jun 2026 19:59:08 -0400 Subject: [PATCH 106/132] Preserve package-qualified S4 class identities MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Finding 1: [P2] Preserve package-qualified S4 parents in dispatch — /Users/tomasz/github/RConsortium/S7/R/class-spec.R:328. When an S7 class extends an S4 class from another package and a different S4 class with the same name is visible, the S4 branch uses methods::extends(x), which drops the package attribute. The constructed S7 object can get a class vector like S4/Foo instead of S4/pkg::Foo, so S4 dispatch can select methods for the wrong class. Finding 2: [P2] Read package attributes before coercing S4 class keys — /Users/tomasz/github/RConsortium/S7/R/S4.R:324-325. as.character() removes the package attribute from className objects, so S4_class_key() currently keys pkgA::Foo, pkgB::Foo, and global Foo all as Foo. Union matching paths using these keys can treat distinct S4 classes as the same under name collisions; capture the package before coercing so package-qualified union members remain distinct. --- R/S4.R | 4 +- R/class-spec.R | 2 +- tests/testthat/_snaps/S4.md | 8 ++++ tests/testthat/test-S4.R | 74 +++++++++++++++++++++++++++++++++++++ 4 files changed, 85 insertions(+), 3 deletions(-) diff --git a/R/S4.R b/R/S4.R index 840f0808e..cd4d90592 100644 --- a/R/S4.R +++ b/R/S4.R @@ -321,12 +321,12 @@ S4_class_keys <- function(classes) { } S4_class_key <- function(class) { - class <- as.character(class) package <- attr(class, "package", exact = TRUE) + class <- as.character(class) if (is.null(package) && class %in% S4_methods_class_names()) { package <- "methods" } - if (is.null(package)) { + if (is.null(package) || identical(package, ".GlobalEnv")) { class } else { paste0(package, "::", class) diff --git a/R/class-spec.R b/R/class-spec.R index 5a973d725..94055c78f 100644 --- a/R/class-spec.R +++ b/R/class-spec.R @@ -323,7 +323,7 @@ class_dispatch <- function(x) { NULL = "NULL", missing = "MISSING", any = character(), - S4 = S4_class_dispatch(methods::extends(x)), + S4 = S4_class_dispatch(x), S7 = { parent <- class_dispatch(x@parent) c( diff --git a/tests/testthat/_snaps/S4.md b/tests/testthat/_snaps/S4.md index bbccac005..dc46ee744 100644 --- a/tests/testthat/_snaps/S4.md +++ b/tests/testthat/_snaps/S4.md @@ -14,6 +14,14 @@ Error in `S4_contains()`: ! Class has not been registered with S4; please call S4_register(S4regStale). +# S4 union matching preserves package-qualified class keys + + Code + S4_register(S4regUnionKeyHolder, env = pkg_env) + Condition + Error: + ! Class union has not been registered with S4; please call S4_register(new_union(S4regUnionKeyFoo, class_character)). + # S4 subclasses reject internal S7/S4 slots during initialization Code diff --git a/tests/testthat/test-S4.R b/tests/testthat/test-S4.R index 0171cec96..a0933ec70 100644 --- a/tests/testthat/test-S4.R +++ b/tests/testthat/test-S4.R @@ -263,6 +263,80 @@ test_that("S4_register preserves package-qualified S4 classes", { expect_equal(S4regPackageClassGeneric(pkg_object), "package") }) +test_that("S7 dispatch preserves package-qualified S4 parents", { + pkg_env <- local_package("s4regdispatchpkg") + defer({ + S4_remove_classes(c( + "S4regDispatchChild", + "S4regDispatchParent" + )) + S4_remove_classes("S4regDispatchParent", pkg_env) + }) + + methods::setClass("S4regDispatchParent", slots = list(x = "character")) + pkg_parent <- methods::setClass( + "S4regDispatchParent", + slots = list(x = "numeric"), + where = pkg_env + ) + S4regDispatchChild := new_class( + parent = pkg_parent, + properties = list(y = class_character), + package = NULL + ) + S4regDispatchGeneric := new_generic("x") + method(S4regDispatchGeneric, methods::getClass("S4regDispatchParent")) <- + function(x) "global" + method(S4regDispatchGeneric, pkg_parent) <- function(x) "package" + + object <- S4regDispatchChild(x = 1, y = "child") + + expect_contains( + class(object), + "S4/s4regdispatchpkg::S4regDispatchParent" + ) + expect_equal(S4regDispatchGeneric(object), "package") +}) + +test_that("S4 union matching preserves package-qualified class keys", { + pkg_env <- local_package("s4regunionkeypkg") + defer({ + S4_remove_classes( + c( + "S4regUnionKeyHolder", + "S4regUnionKeyFoo_OR_character" + ), + pkg_env + ) + S4_remove_classes("S4regUnionKeyFoo") + S4_remove_classes("S4regUnionKeyFoo", pkg_env) + }) + + methods::setClass( + "S4regUnionKeyFoo", + slots = list(x = "character") + ) + pkg_foo <- methods::setClass( + "S4regUnionKeyFoo", + slots = list(x = "numeric"), + where = pkg_env + ) + global_foo <- methods::getClass("S4regUnionKeyFoo") + suppressWarnings(methods::setClassUnion( + "S4regUnionKeyFoo_OR_character", + list(global_foo@className, "character"), + where = pkg_env + )) + S4regUnionKeyHolder := new_class( + properties = list(x = pkg_foo | class_character), + package = NULL + ) + + expect_snapshot(error = TRUE, { + S4_register(S4regUnionKeyHolder, env = pkg_env) + }) +}) + test_that("S4_register can reify S7 properties as slots for S4 subclasses", { on.exit({ if (methods::isGeneric("S4regContainsGeneric")) { From bf1cf5ac7b6caadbb92d1c1ee7c738d3236030e2 Mon Sep 17 00:00:00 2001 From: Tomasz Kalinowski Date: Wed, 24 Jun 2026 20:19:36 -0400 Subject: [PATCH 107/132] Reject S4 slot accessor overrides MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit [P2] Reject accessor overrides of inherited S4 slots — /Users/tomasz/github/RConsortium/S7/R/constructor.R:127-128: When an S4 parent has a slot and the S7 child defines a property with the same name and a custom getter or setter, the class is allowed even though S7 property access can diverge from the inherited S4 slot or produce instances invalid to S4. Accessor overrides of inherited S4 slots should be rejected. --- R/class.R | 13 +++++++++++++ tests/testthat/_snaps/S4.md | 20 ++++++++++++++++++++ tests/testthat/test-S4.R | 32 ++++++++++++++++++++++++++++++++ 3 files changed, 65 insertions(+) diff --git a/R/class.R b/R/class.R index 04d79ef43..691e7e4f4 100644 --- a/R/class.R +++ b/R/class.R @@ -492,6 +492,19 @@ check_prop_overrides <- function( for (prop in overridden) { child_prop <- child_props[[prop]] + if ( + is_S4_class(parent) && + (prop_is_dynamic(child_prop) || prop_has_setter(child_prop)) + ) { + msg <- sprintf( + "Can't override inherited S4 slot %s@%s with a custom %s.", + class_desc(parent), + prop, + if (prop_is_dynamic(child_prop)) "getter" else "setter" + ) + stop2(msg, call = call) + } + # Dynamic properties are computed, not stored, so they're never validated # against the parent's type if (prop_is_dynamic(child_prop)) { diff --git a/tests/testthat/_snaps/S4.md b/tests/testthat/_snaps/S4.md index dc46ee744..ac3195ee1 100644 --- a/tests/testthat/_snaps/S4.md +++ b/tests/testthat/_snaps/S4.md @@ -168,6 +168,26 @@ ! Can't extend S4 class S4 because slot "names" would need renamed S7 storage. These S4 slots can not be represented safely on direct S7 child objects. +# S4 parents reject accessor overrides of inherited slots + + Code + new_class("S4regAccessorSlotGetterChild", parent = getClass( + "S4regAccessorSlotParent"), properties = list(x = new_property(class_numeric, + getter = function(self) 1)), package = NULL) + Condition + Error in `new_class()`: + ! Can't override inherited S4 slot S4@x with a custom getter. + +--- + + Code + new_class("S4regAccessorSlotSetterChild", parent = getClass( + "S4regAccessorSlotParent"), properties = list(x = new_property(class_numeric, + setter = function(self, value) self)), package = NULL) + Condition + Error in `new_class()`: + ! Can't override inherited S4 slot S4@x with a custom setter. + # S7 property narrowing rejects unrelated S4 name matches Code diff --git a/tests/testthat/test-S4.R b/tests/testthat/test-S4.R index a0933ec70..d5117f30d 100644 --- a/tests/testthat/test-S4.R +++ b/tests/testthat/test-S4.R @@ -2248,6 +2248,38 @@ test_that("S4 parents reject slots that need renamed S7 storage", { }) }) +test_that("S4 parents reject accessor overrides of inherited slots", { + defer(S4_remove_classes(c( + "S4regAccessorSlotGetterChild", + "S4regAccessorSlotParent", + "S4regAccessorSlotSetterChild" + ))) + + setClass("S4regAccessorSlotParent", slots = list(x = "numeric")) + + expect_snapshot(error = TRUE, { + new_class( + "S4regAccessorSlotGetterChild", + parent = getClass("S4regAccessorSlotParent"), + properties = list( + x = new_property(class_numeric, getter = function(self) 1) + ), + package = NULL + ) + }) + + expect_snapshot(error = TRUE, { + new_class( + "S4regAccessorSlotSetterChild", + parent = getClass("S4regAccessorSlotParent"), + properties = list( + x = new_property(class_numeric, setter = function(self, value) self) + ), + package = NULL + ) + }) +}) + test_that("S7 property narrowing rejects unrelated S4 name matches", { defer(S4_remove_classes(c( "S4regPropertyNameCollisionChild", From 6201d77bcf4c467d098e3d7e6239332257074aa1 Mon Sep 17 00:00:00 2001 From: Tomasz Kalinowski Date: Wed, 24 Jun 2026 20:45:58 -0400 Subject: [PATCH 108/132] Fix S4-backed S7 validation and data parts MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit [P2] Coerce S7 children before S4 validity — /Users/tomasz/github/RConsortium/S7/R/class-spec.R:272-272: When an S7 class extends an S4 parent, the parent class's own validity method is now called on the S7 child object rather than on `methods::as(object, parent)`, unlike `validObject()` for a normal S4 subclass. S4 validity methods that inspect `class(object)` or rely on the concrete S4 representation reject otherwise valid S7 children. [P2] Handle S7_data for S4-backed S7 objects — /Users/tomasz/github/RConsortium/S7/R/inherits.R:49-53: Because S4 subclasses now satisfy `has_S7_class()`, helpers like `S7_data()` accept them even though `S7_data()` still assumes an attribute-backed S7 object. For an S4 subclass of an S7 data-part class, `S7_data(x)` returns an S4 shell and `S7_data(x) <- value` errors after reattaching the S4 class to a plain value. --- R/class-spec.R | 5 +++- R/data.R | 24 ++++++++++++++++ tests/testthat/test-S4.R | 59 ++++++++++++++++++++++++++++++++++++++++ 3 files changed, 87 insertions(+), 1 deletion(-) diff --git a/R/class-spec.R b/R/class-spec.R index 94055c78f..d1e354295 100644 --- a/R/class-spec.R +++ b/R/class-spec.R @@ -269,7 +269,10 @@ S4_validate_old_class <- function(class, object, skip = character()) { if (!as.character(class@className) %in% skip) { validity <- methods::getValidity(class) if (length(errors) == 0L && is.function(validity)) { - errors <- c(errors, any_strings(validity(object))) + errors <- c( + errors, + any_strings(validity(methods::as(object, class@className))) + ) } } diff --git a/R/data.R b/R/data.R index 59945feb9..c9893a212 100644 --- a/R/data.R +++ b/R/data.R @@ -28,6 +28,10 @@ S7_data <- function(object) { check_is_S7(object) check_not_environment(object, "S7_data()") + if (is_S4_data_part_object(object)) { + return(S4_data_part(object)) + } + out <- zap_attr( object, c(prop_storage_names(object), "class", "_S7_class", "S7_class") @@ -54,6 +58,14 @@ base_parent <- function(class) { check_is_S7(object) check_not_environment(object, "S7_data<-") + if (is_S4_data_part_object(object)) { + object <- S4_initialize_data_part(value, object) + if (isTRUE(check)) { + validate(object) + } + return(invisible(object)) + } + s7_attrs <- c(prop_storage_names(object), "class", "_S7_class", "S7_class") for (name in s7_attrs) { attr(value, name) <- attr(object, name, exact = TRUE) @@ -64,6 +76,18 @@ base_parent <- function(class) { return(invisible(value)) } +is_S4_data_part_object <- function(object) { + isS4(object) && ".Data" %in% methods::slotNames(object) +} + +S4_data_part <- function(object) { + data <- methods::slot(object, ".Data") + attrs <- attributes(object) %||% list() + attrs[c(S4_data_part_protected_attributes(object), ".S3Class")] <- NULL + attributes(data) <- modify_list(attributes(data), attrs) + data +} + zap_attr <- function(x, names) { for (name in names) { attr(x, name) <- NULL diff --git a/tests/testthat/test-S4.R b/tests/testthat/test-S4.R index d5117f30d..6864d2bb1 100644 --- a/tests/testthat/test-S4.R +++ b/tests/testthat/test-S4.R @@ -2034,6 +2034,28 @@ test_that("S4 data part constructors use the .Data argument", { expect_true(methods::validObject(object)) }) +test_that("S7 subclasses validate S4 parents as the parent representation", { + defer(S4_remove_classes(c( + "S4regValidityConcreteParent", + "S4regValidityConcreteChild" + ))) + + setClass("S4regValidityConcreteParent", contains = "numeric") + methods::setValidity("S4regValidityConcreteParent", function(object) { + if (identical(as.character(class(object)), "S4regValidityConcreteParent")) { + TRUE + } else { + "parent validity must see parent class" + } + }) + S4regValidityConcreteChild := new_class( + parent = getClass("S4regValidityConcreteParent"), + package = NULL + ) + + expect_no_error(S4regValidityConcreteChild(.Data = 1)) +}) + test_that("S4 data part constructors use overridden .Data defaults", { defer(S4_remove_classes(c( "S4regDataDefaultParent", @@ -2097,6 +2119,43 @@ test_that("S4 data part initialization preserves S4 subclasses", { expect_true(methods::validObject(object)) }) +test_that("S7_data() reads and writes S4 subclass data parts", { + defer(S4_remove_classes(c( + "S4regS7DataPartGrandChild", + "S4regS7DataPartChild", + "S4regS7DataPartParent" + ))) + + setClass("S4regS7DataPartParent", contains = "numeric") + S4regS7DataPartChild := new_class( + parent = getClass("S4regS7DataPartParent"), + properties = list(y = class_character), + package = NULL + ) + setClass( + "S4regS7DataPartGrandChild", + slots = list(z = "logical"), + contains = "S4regS7DataPartChild" + ) + + object <- methods::new( + "S4regS7DataPartGrandChild", + .Data = c(a = 1), + y = "a", + z = TRUE + ) + + expect_equal(S7_data(object), c(a = 1)) + + S7_data(object) <- c(b = 2) + + expect_s4_class(object, "S4regS7DataPartGrandChild") + expect_equal(S7_data(object), c(b = 2)) + expect_equal(prop(object, "y"), "a") + expect_equal(methods::slot(object, "z"), TRUE) + expect_identical(methods::validObject(object), TRUE) +}) + test_that("S4 subclasses read and write special-named S7 property storage slots", { defer(S4_remove_classes(c( "S4regSpecialSlotsChild", From 46b4c4faa029f1fe54846831a9b8e498dfa0e7dd Mon Sep 17 00:00:00 2001 From: Tomasz Kalinowski Date: Wed, 24 Jun 2026 21:09:23 -0400 Subject: [PATCH 109/132] Fix S4 data-part and validity edge cases MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit [P2] Preserve S4 data-part attributes — /Users/tomasz/github/RConsortium/S7/R/S4.R:842-844: When `object` is an S4 data-part object, collecting only formal slots drops attributes that S4 stores on the object rather than in the `.Data` slot. For example, a child of an S4 `contains = "numeric"` class constructed from `.Data = c(a = 1)` loses the vector names, and the same happens when initializing from an S4 source object. [P2] Seed abstract S4 data-part descendants with .Data — /Users/tomasz/github/RConsortium/S7/R/constructor.R:33-37: For a concrete S7 class whose abstract S7 parent extends a virtual S4 data-part class, this direct-parent check is false, so the generated constructor seeds `new_object()` with `S7_object()` and stores `.Data` as an ignored attribute. Such constructors fail validation for inputs like `.Data = 1` because `prop(x, ".Data")` reads the underlying data object instead of the supplied value. [P2] Preserve S4 package identity during validity coercion — /Users/tomasz/github/RConsortium/S7/R/class-spec.R:270-275: When an S7 class extends an S4 class from another package and another S4 class with the same name is visible, validating by coercing the old-class S7 object with `methods::as(object, class@className)` can resolve through the wrong class definition. In that package-collision case, constructing the S7 child can fail slot assignment or run the wrong validity method even though the package-qualified S4 parent works on its own. [P3] Keep data attributes that share S7 property names — /Users/tomasz/github/RConsortium/S7/R/S4.R:873-881: Including logical property names here strips data-part attributes even when the property is stored under a renamed slot. For an S4-backed numeric class with an S7 property named `names`, `S7_data()` and `S7_data<-` drop the vector names; S4-only slot collisions are already covered by `slotNames()` and S7 storage collisions by `prop_storage_names()`. --- R/S4.R | 12 +++-- R/class-spec.R | 24 ++++++++- R/constructor.R | 3 +- tests/testthat/test-S4.R | 108 +++++++++++++++++++++++++++++++++++++++ 4 files changed, 141 insertions(+), 6 deletions(-) diff --git a/R/S4.R b/R/S4.R index cd4d90592..3fccbd1e7 100644 --- a/R/S4.R +++ b/R/S4.R @@ -841,7 +841,14 @@ S4_strip_data_part_identity <- function(x) { S4_initialize_values <- function(object) { if (isS4(object)) { slots <- methods::slotNames(object) - stats::setNames(lapply(slots, methods::slot, object = object), slots) + values <- stats::setNames( + lapply(slots, methods::slot, object = object), + slots + ) + if (is_S4_data_part_object(object)) { + values$.Data <- S4_data_part(object) + } + values } else if (S7_inherits(object)) { props(object) } else { @@ -873,8 +880,7 @@ S4_initialize_data_part <- function(value, object) { S4_data_part_protected_attributes <- function(object) { c( methods::slotNames(object), - prop_storage_names(object), - prop_names(object), + if (has_S7_class(object)) prop_storage_names(object), "class", "_S7_class", "S7_class" diff --git a/R/class-spec.R b/R/class-spec.R index d1e354295..b2d46e253 100644 --- a/R/class-spec.R +++ b/R/class-spec.R @@ -258,7 +258,7 @@ S4_validate_old_class <- function(class, object, skip = character()) { if (is.function(validity)) { errors <- c( errors, - any_strings(validity(methods::as(object, super_class))) + any_strings(validity(S4_as_validity_class(object, super_def))) ) if (length(errors)) { break @@ -271,7 +271,7 @@ S4_validate_old_class <- function(class, object, skip = character()) { if (length(errors) == 0L && is.function(validity)) { errors <- c( errors, - any_strings(validity(methods::as(object, class@className))) + any_strings(validity(S4_as_validity_class(object, class))) ) } } @@ -283,6 +283,26 @@ S4_validate_old_class <- function(class, object, skip = character()) { } } +S4_as_validity_class <- function(object, class) { + if (isS4(object) || !has_S7_class(object) || class@virtual) { + return(methods::as(object, S4_class_coerce_name(class))) + } + + value <- methods::new(class) + values <- S4_initialize_values(object) + slots <- intersect(names(values), methods::slotNames(value)) + for (name in slots) { + methods::slot(value, name) <- values[[name]] + } + value +} + +S4_class_coerce_name <- function(class) { + name <- class@className + attr(name, "package") <- class@package + name +} + #' Format a class specification as a string #' #' `S7_class_desc()` turns any [class specification][as_class] into a short, diff --git a/R/constructor.R b/R/constructor.R index 252aa35f2..5110cc4cf 100644 --- a/R/constructor.R +++ b/R/constructor.R @@ -30,7 +30,8 @@ new_constructor <- function( arg_info <- constructor_args(parent, all_props, envir, package) force_args <- as_names(names(arg_info$self)) - s4_data_part <- is_S4_class(parent) && ".Data" %in% names(parent@slots) + s4_parent <- if (is_S4_class(parent)) parent else S4_ancestor(parent) + s4_data_part <- !is.null(s4_parent) && ".Data" %in% names(s4_parent@slots) self_arg_names <- names(arg_info$self) parent_call <- if (s4_data_part) { self_arg_names <- setdiff(self_arg_names, ".Data") diff --git a/tests/testthat/test-S4.R b/tests/testthat/test-S4.R index 6864d2bb1..f329204df 100644 --- a/tests/testthat/test-S4.R +++ b/tests/testthat/test-S4.R @@ -1762,6 +1762,43 @@ test_that("S4 subclass validation preserves concrete class package", { }) }) +test_that("S7 validation preserves S4 parent package during coercion", { + pkg_env <- local_package("s4regvalidcoercepkg") + defer({ + suppressMessages({ + S4_remove_classes(c( + "S4regValidityCoerceParent", + "S4regValidityCoerceChild" + )) + S4_remove_classes("S4regValidityCoerceParent", pkg_env) + }) + }) + + setClass("S4regValidityCoerceParent", slots = list(x = "character")) + pkg_parent <- methods::setClass( + "S4regValidityCoerceParent", + contains = "numeric", + where = pkg_env + ) + methods::setValidity( + pkg_parent@className, + function(object) { + if (!identical(as.vector(object), 1)) { + "package parent saw wrong data" + } else { + TRUE + } + }, + where = pkg_env + ) + S4regValidityCoerceChild := new_class( + parent = pkg_parent, + package = NULL + ) + + expect_no_error(S4regValidityCoerceChild(.Data = 1)) +}) + test_that("S4 initialization validates after S4-only slots are set", { defer(S4_remove_classes(c( "S4regInitValidityParent", @@ -1971,6 +2008,26 @@ test_that("S4 initialize strips S7 metadata from data parts", { expect_identical(methods::validObject(out), TRUE) }) +test_that("S4 data-part initialization preserves data attributes", { + defer(S4_remove_classes(c( + "S4regDataPartAttrsChild", + "S4regDataPartAttrsParent" + ))) + + setClass("S4regDataPartAttrsParent", contains = "numeric") + S4regDataPartAttrsChild := new_class( + parent = getClass("S4regDataPartAttrsParent"), + package = NULL + ) + + object <- S4regDataPartAttrsChild(.Data = c(a = 1)) + expect_equal(S7_data(object), c(a = 1)) + + source <- methods::new("S4regDataPartAttrsParent", .Data = c(b = 2)) + out <- methods::initialize(object, source) + expect_equal(S7_data(out), c(b = 2)) +}) + test_that("S4 initialize ignores data-part attributes that collide with slots", { defer(S4_remove_classes(c( "S4regDataAttrParent", @@ -2034,6 +2091,32 @@ test_that("S4 data part constructors use the .Data argument", { expect_true(methods::validObject(object)) }) +test_that("S4 data part constructors seed abstract descendants with .Data", { + defer(S4_remove_classes(c( + "S4regAbstractDataPartChild", + "S4regAbstractDataPart", + "S4regAbstractDataPartParent" + ))) + + setClass("S4regAbstractDataPartParent", contains = c("numeric", "VIRTUAL")) + S4regAbstractDataPart := new_class( + parent = getClass("S4regAbstractDataPartParent"), + abstract = TRUE, + package = NULL + ) + S4regAbstractDataPartChild := new_class( + parent = S4regAbstractDataPart, + package = NULL + ) + + object <- S4regAbstractDataPartChild(.Data = 1) + + expect_equal(as.vector(object), 1) + expect_equal(prop(object, ".Data"), 1) + expect_null(attr(object, ".Data", exact = TRUE)) + expect_true(methods::validObject(object)) +}) + test_that("S7 subclasses validate S4 parents as the parent representation", { defer(S4_remove_classes(c( "S4regValidityConcreteParent", @@ -2156,6 +2239,31 @@ test_that("S7_data() reads and writes S4 subclass data parts", { expect_identical(methods::validObject(object), TRUE) }) +test_that("S7_data() keeps data attributes that match renamed S7 properties", { + defer(S4_remove_classes(c( + "S4regS7DataNameAttrChild", + "S4regS7DataNameAttrParent" + ))) + + setClass("S4regS7DataNameAttrParent", contains = "numeric") + S4regS7DataNameAttrChild := new_class( + parent = getClass("S4regS7DataNameAttrParent"), + properties = list(names = class_character), + package = NULL + ) + + object <- S4regS7DataNameAttrChild(.Data = c(a = 1), names = "prop") + + expect_equal(S7_data(object), c(a = 1)) + expect_equal(prop(object, "names"), "prop") + + S7_data(object) <- c(b = 2) + + expect_equal(S7_data(object), c(b = 2)) + expect_equal(prop(object, "names"), "prop") + expect_identical(methods::validObject(object), TRUE) +}) + test_that("S4 subclasses read and write special-named S7 property storage slots", { defer(S4_remove_classes(c( "S4regSpecialSlotsChild", From 569b0df3b5d2d9a69b4de49df2a9c920acddf69c Mon Sep 17 00:00:00 2001 From: Tomasz Kalinowski Date: Wed, 24 Jun 2026 21:30:34 -0400 Subject: [PATCH 110/132] Fix S4 union package identity MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit [P2] Preserve package identity in generated union names — /Users/tomasz/github/RConsortium/S7/R/S4.R:203-205: When a union contains an S4 class from a package, `S4_class()` returns `x@className` with the package only as an attribute, and `paste0()` drops that attribute. This makes `pkgA::Foo | class_character` and `pkgB::Foo | class_character` both register as `Foo_OR_character`; registering the second union redefines the first, so a name returned by `S4_register()` can start matching the wrong package's class. [P2] Use identity shims for package-local S4 union members — /Users/tomasz/github/RConsortium/S7/R/S4.R:221-223: When the S4 member is defined in the same namespace as `S4_env`, `S4_class_needs_identity()` is false and this returns the bare class name. `setClassUnion()` then creates an unconditional extension for that name, and `methods::is()` also accepts same-named classes from `.GlobalEnv`; a package union like `Foo | character` will match a user's global `Foo` object. --- R/S4.R | 73 ++++++++++++++++++++++++++++------ tests/testthat/test-S4.R | 86 ++++++++++++++++++++++++++++++++++++++++ 2 files changed, 147 insertions(+), 12 deletions(-) diff --git a/R/S4.R b/R/S4.R index 3fccbd1e7..8f5572633 100644 --- a/R/S4.R +++ b/R/S4.R @@ -90,7 +90,7 @@ S4_register_union <- function(class, env) { members, where = env ) - S4_register_union_member_extensions(class$classes, members, env) + S4_register_union_member_extensions(class$classes, members, name, env) name } @@ -201,7 +201,18 @@ S4_union_class <- function(x, S4_env) { } S4_union_name <- function(x, S4_env) { - paste0(vcapply(x$classes, S4_class, S4_env = S4_env), collapse = "_OR_") + paste0( + vcapply(x$classes, S4_union_name_member, S4_env = S4_env), + collapse = "_OR_" + ) +} + +S4_union_name_member <- function(x, S4_env) { + if (is_S4_class(x)) { + return(S4_class_key(x@className)) + } + + S4_class(x, S4_env) } S4_union_member_classes <- function(x, S4_env, register = FALSE) { @@ -218,28 +229,43 @@ S4_union_member_class <- function(x, S4_env, register = FALSE) { return(S4_class(x, S4_env)) } - if (!S4_class_needs_identity(x@className, S4_env)) { + if (!S4_union_member_needs_identity(x@className)) { return(x@className) } name <- S4_class_name(x) - if (register && !methods::isClass(name, where = S4_env)) { - methods::setClass(name, contains = "VIRTUAL", where = S4_env) + if (register) { + if (!methods::isClass(name, where = S4_env)) { + methods::setClass(name, contains = "VIRTUAL", where = S4_env) + } + return(name) } - name + if (methods::isClass(name, where = S4_env)) { + return(name) + } + + x@className } -S4_register_union_member_extensions <- function(classes, members, S4_env) { +S4_register_union_member_extensions <- function( + classes, + members, + union, + S4_env +) { for (i in seq_along(classes)) { - S4_register_union_member_extension(classes[[i]], members[[i]], S4_env) + S4_register_union_member_extension( + classes[[i]], + members[[i]], + union, + S4_env + ) } invisible() } -S4_register_union_member_extension <- function(class, member, S4_env) { - if ( - !is_S4_class(class) || !S4_class_needs_identity(class@className, S4_env) - ) { +S4_register_union_member_extension <- function(class, member, union, S4_env) { + if (!is_S4_class(class) || !S4_union_member_needs_identity(class@className)) { return(invisible()) } @@ -260,6 +286,29 @@ S4_register_union_member_extension <- function(class, member, S4_env) { classDef = class, test = S4_class_package_test(package) )) + S4_prune_union_subclass(union, class@className, S4_env) + invisible() +} + +S4_union_member_needs_identity <- function(class) { + package <- attr(class, "package", exact = TRUE) + !is.null(package) && + !identical(package, ".GlobalEnv") && + !(identical(package, "methods") && class %in% S4_methods_class_names()) +} + +# setIs() adds a transitive bare-class subclass entry to the union. Class +# unions match those names without respecting the conditional package test, so +# remove it and let objects reach the union through the identity shim. +S4_prune_union_subclass <- function(union, class, S4_env) { + class <- as.character(class) + union_def <- methods::getClass(union, where = S4_env) + if (!class %in% names(union_def@subclasses)) { + return(invisible()) + } + + union_def@subclasses[[class]] <- NULL + methods::setClass(Class = union, representation = union_def, where = S4_env) invisible() } diff --git a/tests/testthat/test-S4.R b/tests/testthat/test-S4.R index f329204df..655336635 100644 --- a/tests/testthat/test-S4.R +++ b/tests/testthat/test-S4.R @@ -263,6 +263,92 @@ test_that("S4_register preserves package-qualified S4 classes", { expect_equal(S4regPackageClassGeneric(pkg_object), "package") }) +test_that("S4_register gives package S4 unions distinct names", { + pkg_a_env <- local_package("s4regunionnamea") + pkg_b_env <- local_package("s4regunionnameb") + defer({ + suppressMessages({ + S4_remove_classes(c( + "s4regunionnamea::S4regUnionNameFoo_OR_character", + "s4regunionnameb::S4regUnionNameFoo_OR_character", + "S4/s4regunionnamea::S4regUnionNameFoo", + "S4/s4regunionnameb::S4regUnionNameFoo", + "S4regUnionNameFoo_OR_character" + )) + S4_remove_classes("S4regUnionNameFoo", pkg_a_env) + S4_remove_classes("S4regUnionNameFoo", pkg_b_env) + }) + }) + + pkg_a_foo <- methods::setClass( + "S4regUnionNameFoo", + slots = list(x = "numeric"), + where = pkg_a_env + ) + pkg_b_foo <- methods::setClass( + "S4regUnionNameFoo", + slots = list(x = "character"), + where = pkg_b_env + ) + + union_a <- S4_register(pkg_a_foo | class_character) + union_b <- S4_register(pkg_b_foo | class_character) + pkg_a_object <- pkg_a_foo(x = 1) + pkg_b_object <- pkg_b_foo(x = "x") + + expect_equal( + union_a, + "s4regunionnamea::S4regUnionNameFoo_OR_character" + ) + expect_equal( + union_b, + "s4regunionnameb::S4regUnionNameFoo_OR_character" + ) + expect_equal(methods::is(pkg_a_object, union_a), TRUE) + expect_equal(methods::is(pkg_b_object, union_a), FALSE) + expect_equal(methods::is(pkg_b_object, union_b), TRUE) + expect_equal(methods::is(pkg_a_object, union_b), FALSE) +}) + +test_that("S4_register keeps package-local S4 union members distinct", { + pkg_env <- local_package("s4regunionlocalpkg") + defer({ + suppressMessages({ + S4_remove_classes("S4regUnionLocalFoo") + S4_remove_classes( + c( + "s4regunionlocalpkg::S4regUnionLocalFoo_OR_character", + "S4/s4regunionlocalpkg::S4regUnionLocalFoo", + "S4regUnionLocalFoo_OR_character" + ), + pkg_env + ) + S4_remove_classes("S4regUnionLocalFoo", pkg_env) + }) + }) + + global_foo <- methods::setClass( + "S4regUnionLocalFoo", + slots = list(x = "character") + ) + pkg_foo <- methods::setClass( + "S4regUnionLocalFoo", + slots = list(x = "numeric"), + where = pkg_env + ) + + union_name <- S4_register(pkg_foo | class_character, env = pkg_env) + pkg_object <- pkg_foo(x = 1) + global_object <- global_foo(x = "x") + + expect_equal( + union_name, + "s4regunionlocalpkg::S4regUnionLocalFoo_OR_character" + ) + expect_equal(methods::is(pkg_object, union_name), TRUE) + expect_equal(methods::is(global_object, union_name), FALSE) +}) + test_that("S7 dispatch preserves package-qualified S4 parents", { pkg_env <- local_package("s4regdispatchpkg") defer({ From 9482eb5b30efd4664dc4533bcc09124e70b15738 Mon Sep 17 00:00:00 2001 From: Tomasz Kalinowski Date: Wed, 24 Jun 2026 21:55:21 -0400 Subject: [PATCH 111/132] Fix S4 constructor review findings MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit [P2] Reject S4 parent objects in custom constructors — /Users/tomasz/github/RConsortium/S7/R/class.R:327-328: When an S7 class has an S4 parent and a custom constructor passes an actual S4 parent instance to `new_object()` (for example `new_object(methods::new("Parent", ...))`), this branch returns without normalizing or rejecting it; `new_object()` then installs S7 attributes on the S4 object and the constructor never returns. The generated constructor avoids S4 `_parent` values, but custom constructors are public API, so this path should fail fast or convert the S4 parent before validation. [P3] Add subclasses to global variables — /Users/tomasz/github/RConsortium/S7/R/S4.R:310-310: Running `devtools::check()` now reports `S4_prune_union_subclass: no visible binding for global variable 'subclasses'` because this `@subclasses` subassignment is parsed by R's code checker as a global variable reference. Add `"subclasses"` to `globalVariables()` or avoid the direct slot subassignment so the patch does not introduce a new check NOTE. --- R/S4.R | 1 + R/class.R | 6 ++++++ tests/testthat/_snaps/class.md | 8 ++++++++ tests/testthat/test-class.R | 13 +++++++++++++ 4 files changed, 28 insertions(+) diff --git a/R/S4.R b/R/S4.R index 8f5572633..75231cab5 100644 --- a/R/S4.R +++ b/R/S4.R @@ -1188,6 +1188,7 @@ globalVariables(c( "package", "prototype", "slots", + "subclasses", "subClass", "superClass", "virtual" diff --git a/R/class.R b/R/class.R index 691e7e4f4..5ab348b03 100644 --- a/R/class.R +++ b/R/class.R @@ -325,6 +325,12 @@ check_parent <- function(parent, class, call = sys.call(-1L)) { # class attributes, at which point methods::validObject() can see the # registered oldClass structure. if (is_S4_class(parent_class)) { + if (isS4(parent)) { + stop2( + "`_parent` must not be an S4 object when class has an S4 parent.", + call = call + ) + } return() } diff --git a/tests/testthat/_snaps/class.md b/tests/testthat/_snaps/class.md index 755048acb..526cbd0de 100644 --- a/tests/testthat/_snaps/class.md +++ b/tests/testthat/_snaps/class.md @@ -179,6 +179,14 @@ Error in `new_object()`: ! `_parent` must be an instance of , not . +# new_object() rejects S4 parent objects in custom constructors + + Code + Child() + Condition + Error in `new_object()`: + ! `_parent` must not be an S4 object when class has an S4 parent. + # new_object() errors if `_parent` is supplied but class has no parent Code diff --git a/tests/testthat/test-class.R b/tests/testthat/test-class.R index 5deae97e0..8d0c12cbe 100644 --- a/tests/testthat/test-class.R +++ b/tests/testthat/test-class.R @@ -355,6 +355,19 @@ test_that("new_object() errors if `_parent` doesn't inherit from the parent clas }) }) +test_that("new_object() rejects S4 parent objects in custom constructors", { + Parent := local_S4_class(slots = list(x = "numeric")) + Child := new_class( + parent = Parent, + package = NULL, + constructor = function() { + new_object(methods::new("Parent", x = 1)) + } + ) + + expect_snapshot(Child(), error = TRUE) +}) + test_that("new_object() allows S7_object placeholder for abstract parents", { Abstract := new_class( package = NULL, From 4d986537bb1722f48ef2b7602da451e603c31c63 Mon Sep 17 00:00:00 2001 From: Tomasz Kalinowski Date: Wed, 24 Jun 2026 22:21:02 -0400 Subject: [PATCH 112/132] Preserve S7_object inheritance for data-part S4 shims MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit [P2] Preserve S7_object inheritance for data-part parents — /Users/tomasz/github/RConsortium/S7/R/S4.R:627-632. When an S7 class has a base/S3 data-part parent such as `class_integer` or `class_factor`, the S4 compatibility class is registered as containing only that data-part class plus `VIRTUAL`; `setOldClass(c(Foo, integer, S7_object), S4Class = Foo)` does not make the S4 class extend `S7_object` in that case. As a result, `setClass("Child", contains = S4_contains(Foo)); new("Child", ...)` fails in `S4_initialize()` because the child prototype is not recognized as an S7 object, so S4 subclasses cannot be constructed for these advertised S7 classes. --- R/S4.R | 34 ++++++++++++++++++++++++++++++++- tests/testthat/test-S4.R | 41 +++++++++++++++++++++++++++++++++++++++- 2 files changed, 73 insertions(+), 2 deletions(-) diff --git a/R/S4.R b/R/S4.R index 75231cab5..291b0a285 100644 --- a/R/S4.R +++ b/R/S4.R @@ -554,6 +554,7 @@ S4_register_class <- function(class, env = parent.frame()) { where <- topenv(env) class_name <- S7_class_name(class) parent_class_name <- S4_reified_parent_class(class, where) + old_classes <- S4_reified_old_classes(class) parent_slot_names <- character() if (!is.null(parent_class_name)) { parent_slot_names <- S4_slot_names(parent_class_name, where) @@ -578,6 +579,9 @@ S4_register_class <- function(class, env = parent.frame()) { if (needs_S7_class_slot) { slots$`_S7_class` <- "S7_class" } + if (S4_needs_S3_class_slot(class, parent_slot_names, old_classes)) { + slots$.S3Class <- "character" + } contains <- S4_contains_classes(parent_class_name, where) methods::setClass( @@ -593,16 +597,17 @@ S4_register_class <- function(class, env = parent.frame()) { where = where ) - old_classes <- S4_reified_old_classes(class) if (class@abstract) { if (!S7_extends_S4(class)) { methods::setOldClass(old_classes, S4Class = class_name, where = where) + S4_set_S7_object_extension(class_name, old_classes, where) S4_set_S3_class_prototype(class_name, old_classes, where) } return(class_name) } methods::setOldClass(old_classes, S4Class = class_name, where = where) + S4_set_S7_object_extension(class_name, old_classes, where) S4_set_S3_class_prototype(class_name, old_classes, where) methods::setValidity(class_name, S4_validate_class, where = where) methods::setMethod( @@ -615,6 +620,33 @@ S4_register_class <- function(class, env = parent.frame()) { class_name } +S4_needs_S3_class_slot <- function(class, parent_slot_names, old_classes) { + if (!"S7_object" %in% old_classes || ".S3Class" %in% parent_slot_names) { + return(FALSE) + } + + is_base_class(base_parent(class)) || ".Data" %in% parent_slot_names +} + +S4_set_S7_object_extension <- function(class_name, old_classes, where) { + if (!"S7_object" %in% old_classes) { + return(invisible()) + } + + class <- methods::getClass(class_name, where = where) + if (methods::extends(class, "S7_object")) { + return(invisible()) + } + + methods::setIs( + class_name, + "S7_object", + where = where, + classDef = class + ) + invisible() +} + S4_class_needs_identity <- function(class, where) { if (is.null(class)) { return(FALSE) diff --git a/tests/testthat/test-S4.R b/tests/testthat/test-S4.R index 655336635..8821443b8 100644 --- a/tests/testthat/test-S4.R +++ b/tests/testthat/test-S4.R @@ -12,7 +12,7 @@ test_that("S4_register registers an S7 class so it can be used with S4 methods", }) test_that("S4_register registers S7 classes with base parents", { - defer(S4_remove_classes("S4regS7Integer")) + defer(S4_remove_classes(c("S4regS7IntegerChild", "S4regS7Integer"))) S4regS7Integer := new_class(parent = class_integer, package = NULL) @@ -24,6 +24,45 @@ test_that("S4_register registers S7 classes with base parents", { expect_true(methods::is(object, "integer")) expect_true(methods::is(object, "S7_object")) expect_true(methods::validObject(object)) + + methods::setClass( + "S4regS7IntegerChild", + contains = S4_contains(S4regS7Integer), + slots = list(y = "character") + ) + child <- methods::new("S4regS7IntegerChild", .Data = 2L, y = "child") + + expect_equal(S7_class(child), S4regS7Integer) + expect_equal(S7_inherits(child, S4regS7Integer), TRUE) + expect_equal(methods::is(child, "S7_object"), TRUE) + expect_equal(S7_data(child), 2L) + expect_equal(methods::slot(child, "y"), "child") + expect_equal(methods::validObject(child), TRUE) +}) + +test_that("S4_register constructs S4 subclasses with S3 data-part parents", { + defer(S4_remove_classes(c("S4regS7FactorChild", "S4regS7Factor"))) + + S4regS7Factor := new_class(parent = class_factor, package = NULL) + S4_register(S4regS7Factor) + methods::setClass( + "S4regS7FactorChild", + contains = S4_contains(S4regS7Factor), + slots = list(y = "character") + ) + child <- methods::new( + "S4regS7FactorChild", + .Data = 1L, + levels = "a", + y = "child" + ) + + expect_equal(S7_class(child), S4regS7Factor) + expect_equal(S7_inherits(child, S4regS7Factor), TRUE) + expect_equal(methods::is(child, "S7_object"), TRUE) + expect_equal(methods::slot(child, ".Data"), 1L) + expect_equal(methods::slot(child, "levels"), "a") + expect_equal(methods::slot(child, "y"), "child") }) test_that("S4_register registers S7 property classes", { From ed6915d6caf3584e8096d108936ab2aa8d008a48 Mon Sep 17 00:00:00 2001 From: Tomasz Kalinowski Date: Wed, 24 Jun 2026 22:44:20 -0400 Subject: [PATCH 113/132] Fix S4 union registration and validity skips MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit [P2] Register S7 union members before naming the union — /Users/tomasz/github/RConsortium/S7/R/S4.R:86-87: When the union contains an S7/S3 member that has not already been registered, this calls `S4_union_name()` and resolves each member through `S4_class()` before the later `register = TRUE` path can run. As a result, `S4_register(Foo | class_character)` fails with “please call S4_register(Foo)” instead of registering the union, so the new public union registration API only works after an undocumented extra registration step. [P2] Preserve package identity when skipping S4 validity — /Users/tomasz/github/RConsortium/S7/R/valid.R:170-173: When validating an S4 subclass that combines an S7-over-S4 ancestor from one package with another S4 superclass of the same bare name from another package, this skip list drops the package from `className`. `S4_validate_old_class()` then skips the unrelated superclass as if it had already been validated, so `validate(obj)` can return successfully even though `methods::validObject(obj, test = TRUE)` reports that superclass's validity error. --- R/S4.R | 9 +++- R/class-spec.R | 4 +- R/valid.R | 7 +-- tests/testthat/_snaps/S4.md | 9 ++++ tests/testthat/test-S4.R | 103 ++++++++++++++++++++++++++++++++++++ 5 files changed, 126 insertions(+), 6 deletions(-) diff --git a/R/S4.R b/R/S4.R index 291b0a285..f27258441 100644 --- a/R/S4.R +++ b/R/S4.R @@ -83,8 +83,8 @@ S4_contains <- function(class, env = parent.frame()) { } S4_register_union <- function(class, env) { - name <- S4_union_name(class, env) members <- S4_union_member_classes(class, env, register = TRUE) + name <- S4_union_name(class, env) methods::setClassUnion( name, members, @@ -226,6 +226,13 @@ S4_union_member_classes <- function(x, S4_env, register = FALSE) { S4_union_member_class <- function(x, S4_env, register = FALSE) { if (!is_S4_class(x)) { + if (register && class_type(x) %in% c("S7", "S7_S3")) { + registered <- S4_registered_class_or_null(x, S4_env) + if (!is.null(registered)) { + return(registered@className) + } + return(S4_register(x, S4_env)) + } return(S4_class(x, S4_env)) } diff --git a/R/class-spec.R b/R/class-spec.R index b2d46e253..5209bb710 100644 --- a/R/class-spec.R +++ b/R/class-spec.R @@ -232,7 +232,7 @@ S4_validate_old_class <- function(class, object, skip = character()) { extends <- rev(class@contains) for (ext in extends) { super_class <- ext@superClass - if (super_class %in% skip) { + if (S4_class_key(super_class) %in% skip) { next } if (!ext@simple && !methods::is(object, super_class)) { @@ -266,7 +266,7 @@ S4_validate_old_class <- function(class, object, skip = character()) { } } - if (!as.character(class@className) %in% skip) { + if (!S4_class_key(class@className) %in% skip) { validity <- methods::getValidity(class) if (length(errors) == 0L && is.function(validity)) { errors <- c( diff --git a/R/valid.R b/R/valid.R index e08f27990..e5f921aad 100644 --- a/R/valid.R +++ b/R/valid.R @@ -167,10 +167,11 @@ validate_S4_subclass <- function(object) { } S4_validity_classes <- function(class) { - c( - vcapply(class@contains, methods::slot, "superClass"), - as.character(class@className) + classes <- c( + lapply(class@contains, methods::slot, "superClass"), + list(class@className) ) + S4_class_keys(classes) } validate_properties <- function(object, class, parent_class = NULL) { diff --git a/tests/testthat/_snaps/S4.md b/tests/testthat/_snaps/S4.md index ac3195ee1..b06a828a9 100644 --- a/tests/testthat/_snaps/S4.md +++ b/tests/testthat/_snaps/S4.md @@ -122,6 +122,15 @@ ! S4 object is invalid: - x must have length 1 +# S4 subclass validation preserves skipped superclass packages + + Code + validate(object) + Condition + Error in `validate()`: + ! S4 object is invalid: + - package B x must have length 1 + # S4 initialization validates after S4-only slots are set Code diff --git a/tests/testthat/test-S4.R b/tests/testthat/test-S4.R index 8821443b8..8bc7dc9a8 100644 --- a/tests/testthat/test-S4.R +++ b/tests/testthat/test-S4.R @@ -250,6 +250,34 @@ test_that("S4_register registers an S7 union so it can be used with S4 methods", expect_equal(S4regUnionGeneric("x"), "union") }) +test_that("S4_register registers unregistered S7 and S3 union members", { + defer(S4_remove_classes(c( + "S4regUnionAutoS7", + "S4regUnionAutoS7_OR_character", + "S4regUnionAutoS3", + "S4regUnionAutoS3_OR_character" + ))) + + S4regUnionAutoS7 := new_class( + package = NULL + ) + S4regUnionAutoS3 <- new_S3_class(class = "S4regUnionAutoS3") + + expect_false(methods::isClass("S4regUnionAutoS7")) + expect_false(methods::isClass("S4regUnionAutoS3")) + + expect_equal( + S4_register(S4regUnionAutoS7 | class_character), + "S4regUnionAutoS7_OR_character" + ) + expect_equal( + S4_register(S4regUnionAutoS3 | class_character), + "S4regUnionAutoS3_OR_character" + ) + expect_true(methods::isClass("S4regUnionAutoS7")) + expect_true(methods::isClass("S4regUnionAutoS3")) +}) + test_that("S4_register preserves package-qualified S4 classes", { pkg_env <- local_package("s4regpkgclasses") defer({ @@ -1887,6 +1915,81 @@ test_that("S4 subclass validation preserves concrete class package", { }) }) +test_that("S4 subclass validation preserves skipped superclass packages", { + pkg_a_env <- local_package("s4regvalidskipa") + pkg_b_env <- local_package("s4regvalidskipb") + defer({ + suppressMessages({ + S4_remove_classes(c( + "S4regValiditySkip", + "S4regValiditySkipS7", + "S4regValiditySkipChild" + )) + S4_remove_classes( + c( + "S4regValiditySkip", + "S4regValiditySkipPkgAChild" + ), + pkg_a_env + ) + S4_remove_classes("S4regValiditySkip", pkg_b_env) + }) + }) + + pkg_a_base <- methods::setClass( + "S4regValiditySkip", + slots = list(x = "numeric"), + prototype = list(x = 1), + where = pkg_a_env + ) + pkg_a_parent <- methods::setClass( + "S4regValiditySkipPkgAChild", + contains = pkg_a_base@className, + where = pkg_a_env + ) + pkg_b_parent <- methods::setClass( + "S4regValiditySkip", + slots = list(x = "numeric"), + prototype = list(x = 1), + where = pkg_b_env + ) + methods::setValidity( + pkg_b_parent@className, + function(object) { + if (length(methods::slot(object, "x")) != 1) { + "package B x must have length 1" + } else { + TRUE + } + }, + where = pkg_b_env + ) + S4regValiditySkipS7 := new_class( + parent = pkg_a_parent, + package = NULL + ) + suppressWarnings(methods::setClass( + "S4regValiditySkipChild", + contains = list( + S4_contains(S4regValiditySkipS7), + pkg_b_parent@className + ), + slots = list(x = "numeric"), + prototype = list(x = 1) + )) + + object <- methods::new("S4regValiditySkipChild") + methods::slot(object, "x") <- numeric() + + expect_match( + methods::validObject(object, test = TRUE), + "package B x must have length 1" + ) + expect_snapshot(error = TRUE, { + validate(object) + }) +}) + test_that("S7 validation preserves S4 parent package during coercion", { pkg_env <- local_package("s4regvalidcoercepkg") defer({ From 67d31f60fbed2b99e2889441315c448705919cbd Mon Sep 17 00:00:00 2001 From: Tomasz Kalinowski Date: Wed, 24 Jun 2026 23:07:45 -0400 Subject: [PATCH 114/132] Fix S4 union identity matching MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit [P2] Allow subclasses in package-qualified S4 unions — /Users/tomasz/github/RConsortium/S7/R/S4.R:325-325: When a registered S7 union contains a package-qualified S4 class and a class in another package extends that S4 class, `methods::is(subclass_obj, union_name)` returns `FALSE`. The conditional extension compares the concrete object's package from `class(object)` with the union member's package, excluding valid subclasses defined in other packages. [P2] Isolate global S4 union members from name collisions — /Users/tomasz/github/RConsortium/S7/R/S4.R:300-304: When the union member is a `.GlobalEnv` S4 class and a package also defines an unrelated class with the same bare name, this returns `FALSE` and the union is registered against the bare class name. Instances of the package class then satisfy the global union, so S4 slots or method signatures using `S4_register(globalFoo | ...)` can accept the wrong class. --- R/S4.R | 66 ++++++++++++++++++++++++++++++++++++---- tests/testthat/test-S4.R | 66 ++++++++++++++++++++++++++++++++++++++++ 2 files changed, 126 insertions(+), 6 deletions(-) diff --git a/R/S4.R b/R/S4.R index f27258441..ca9988d83 100644 --- a/R/S4.R +++ b/R/S4.R @@ -285,13 +285,12 @@ S4_register_union_member_extension <- function(class, member, union, S4_env) { return(invisible()) } - package <- attr(class@className, "package", exact = TRUE) suppressWarnings(methods::setIs( class@className, member, where = S4_env, classDef = class, - test = S4_class_package_test(package) + test = S4_class_identity_test(class@className) )) S4_prune_union_subclass(union, class@className, S4_env) invisible() @@ -300,7 +299,6 @@ S4_register_union_member_extension <- function(class, member, union, S4_env) { S4_union_member_needs_identity <- function(class) { package <- attr(class, "package", exact = TRUE) !is.null(package) && - !identical(package, ".GlobalEnv") && !(identical(package, "methods") && class %in% S4_methods_class_names()) } @@ -319,14 +317,70 @@ S4_prune_union_subclass <- function(union, class, S4_env) { invisible() } -S4_class_package_test <- function(package) { +S4_class_identity_test <- function(target) { + target <- S4_class_identity_expr(target) new_function( alist(object = ), - bquote(identical(attr(class(object), "package", exact = TRUE), .(package))), - baseenv() + bquote({ + class <- S4_object_class_def(base::class(object)) + if (is.null(class)) { + return(FALSE) + } + + S4_class_extends_identity(class, .(target)) + }) ) } +S4_class_identity_expr <- function(class) { + package <- attr(class, "package", exact = TRUE) + class <- as.character(class) + if (is.null(package)) { + return(class) + } + + bquote(structure(.(class), package = .(package))) +} + +S4_object_class_def <- function(class) { + name <- class[[1L]] + package <- attr(class, "package", exact = TRUE) + if (!is.null(package)) { + where <- if (identical(package, ".GlobalEnv")) { + .GlobalEnv + } else { + asNamespace(package) + } + return(methods::getClass(name, where = where)) + } + + methods::getClassDef(name, inherits = FALSE) +} + +S4_class_extends_identity <- function(class, target) { + if (S4_same_class_identity(class@className, target)) { + return(TRUE) + } + + any(vlapply( + class@contains, + function(extension) S4_same_class_identity(extension@superClass, target) + )) +} + +S4_same_class_identity <- function(x, y) { + identical(S4_class_identity_key(x), S4_class_identity_key(y)) +} + +S4_class_identity_key <- function(class) { + package <- attr(class, "package", exact = TRUE) + if (is.null(package) && class %in% S4_methods_class_names()) { + package <- "methods" + } + + paste0(package %||% "", "::", as.character(class)) +} + S4_find_union <- function(members, S4_env) { if (!all(vlapply(members, methods::isClass, where = S4_env))) { return(NULL) diff --git a/tests/testthat/test-S4.R b/tests/testthat/test-S4.R index 8bc7dc9a8..c17fb0b9a 100644 --- a/tests/testthat/test-S4.R +++ b/tests/testthat/test-S4.R @@ -330,6 +330,72 @@ test_that("S4_register preserves package-qualified S4 classes", { expect_equal(S4regPackageClassGeneric(pkg_object), "package") }) +test_that("S4_register allows S4 subclasses of package union members", { + parent_env <- local_package("s4regunionparentpkg") + child_env <- local_package("s4regunionchildpkg") + defer({ + suppressMessages({ + S4_remove_classes(c( + "s4regunionparentpkg::S4regUnionParent_OR_character", + "S4/s4regunionparentpkg::S4regUnionParent" + )) + S4_remove_classes("S4regUnionParent", parent_env) + S4_remove_classes("S4regUnionChild", child_env) + }) + }) + + parent <- methods::setClass( + "S4regUnionParent", + slots = list(x = "numeric"), + where = parent_env + ) + parent_def <- methods::getClass(parent@className, where = parent_env) + union_name <- S4_register(parent_def | class_character) + child <- methods::setClass( + "S4regUnionChild", + contains = parent_def@className, + where = child_env + ) + + parent_object <- parent(x = 1) + child_object <- child(x = 2) + + expect_equal(methods::is(parent_object, union_name), TRUE) + expect_equal(methods::is(child_object, union_name), TRUE) +}) + +test_that("S4_register keeps global S4 union members distinct", { + pkg_env <- local_package("s4regglobalunionpkg") + defer({ + suppressMessages({ + S4_remove_classes(c( + "S4regGlobalUnionFoo_OR_character", + "S4/S4regGlobalUnionFoo", + "S4regGlobalUnionFoo" + )) + S4_remove_classes("S4regGlobalUnionFoo", pkg_env) + }) + }) + + global_foo <- methods::setClass( + "S4regGlobalUnionFoo", + slots = list(x = "character") + ) + pkg_foo <- methods::setClass( + "S4regGlobalUnionFoo", + slots = list(x = "numeric"), + where = pkg_env + ) + global_def <- methods::getClass(global_foo@className) + + union_name <- S4_register(global_def | class_character) + global_object <- global_foo(x = "x") + pkg_object <- pkg_foo(x = 1) + + expect_equal(methods::is(global_object, union_name), TRUE) + expect_equal(methods::is(pkg_object, union_name), FALSE) +}) + test_that("S4_register gives package S4 unions distinct names", { pkg_a_env <- local_package("s4regunionnamea") pkg_b_env <- local_package("s4regunionnameb") From 2b856fd2c9e2263724083b228dec54fc3de694d3 Mon Sep 17 00:00:00 2001 From: Tomasz Kalinowski Date: Wed, 24 Jun 2026 23:28:38 -0400 Subject: [PATCH 115/132] Fix S4-backed S7 invariants MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Finding 1: [P2] Reject invalid seeds for S4-backed custom constructors — /Users/tomasz/github/RConsortium/S7/R/class.R:327-334: When an S7 class has an S4 parent without a `.Data` slot, this branch accepts any non-S4 `_parent`, so a custom constructor can call `new_object(1, x = ...)` and create an object whose underlying data is `double` rather than the required `S7_object`; both `validate()` and `methods::validObject()` then pass because validation stops at the S4 parent. This breaks the core S7 object invariant for S4-backed classes. Finding 2: [P2] Check S4 slot overrides through S7 ancestors — /Users/tomasz/github/RConsortium/S7/R/class.R:501-503: This guard only rejects custom getters/setters when the immediate parent is S4. If `P` extends an S4 class with slot `x`, then `C <- new_class(parent = P, properties = list(x = new_property(getter = ...)))` is accepted; the registered S4 class still inherits the original `x` slot, so `prop(obj, "x")` and `methods::slot(obj, "x")` can disagree and S4 validity checks the stale slot value. --- R/class.R | 16 +++++++++++++-- tests/testthat/_snaps/S4.md | 19 ++++++++++++++++++ tests/testthat/_snaps/class.md | 8 ++++++++ tests/testthat/test-S4.R | 36 ++++++++++++++++++++++++++++++++++ tests/testthat/test-class.R | 13 ++++++++++++ 5 files changed, 90 insertions(+), 2 deletions(-) diff --git a/R/class.R b/R/class.R index 5ab348b03..a79338a86 100644 --- a/R/class.R +++ b/R/class.R @@ -331,6 +331,15 @@ check_parent <- function(parent, class, call = sys.call(-1L)) { call = call ) } + if ( + !".Data" %in% names(parent_class@slots) && + !is_S7_type(parent) + ) { + stop2( + "`_parent` must be an when class has an S4 parent without a data part.", + call = call + ) + } return() } @@ -494,17 +503,20 @@ check_prop_overrides <- function( call = sys.call(-1L) ) { overridden <- intersect(names(child_props), names(parent_props)) + s4_parent <- if (is_S4_class(parent)) parent else S4_ancestor(parent) + s4_slots <- if (is.null(s4_parent)) character() else names(s4_parent@slots) for (prop in overridden) { child_prop <- child_props[[prop]] if ( - is_S4_class(parent) && + prop %in% + s4_slots && (prop_is_dynamic(child_prop) || prop_has_setter(child_prop)) ) { msg <- sprintf( "Can't override inherited S4 slot %s@%s with a custom %s.", - class_desc(parent), + class_desc(s4_parent), prop, if (prop_is_dynamic(child_prop)) "getter" else "setter" ) diff --git a/tests/testthat/_snaps/S4.md b/tests/testthat/_snaps/S4.md index b06a828a9..5a1c5a8e9 100644 --- a/tests/testthat/_snaps/S4.md +++ b/tests/testthat/_snaps/S4.md @@ -197,6 +197,25 @@ Error in `new_class()`: ! Can't override inherited S4 slot S4@x with a custom setter. +# S7 subclasses reject accessor overrides of inherited S4 slots + + Code + new_class("S4regS7AccessorSlotGetterChild", parent = Parent, properties = list( + x = new_property(class_numeric, getter = function(self) 1)), package = NULL) + Condition + Error in `new_class()`: + ! Can't override inherited S4 slot S4@x with a custom getter. + +--- + + Code + new_class("S4regS7AccessorSlotSetterChild", parent = Parent, properties = list( + x = new_property(class_numeric, setter = function(self, value) self)), + package = NULL) + Condition + Error in `new_class()`: + ! Can't override inherited S4 slot S4@x with a custom setter. + # S7 property narrowing rejects unrelated S4 name matches Code diff --git a/tests/testthat/_snaps/class.md b/tests/testthat/_snaps/class.md index 526cbd0de..a667dd1f1 100644 --- a/tests/testthat/_snaps/class.md +++ b/tests/testthat/_snaps/class.md @@ -187,6 +187,14 @@ Error in `new_object()`: ! `_parent` must not be an S4 object when class has an S4 parent. +# new_object() rejects non-S7 seeds for S4 parents without data parts + + Code + Child() + Condition + Error in `new_object()`: + ! `_parent` must be an when class has an S4 parent without a data part. + # new_object() errors if `_parent` is supplied but class has no parent Code diff --git a/tests/testthat/test-S4.R b/tests/testthat/test-S4.R index c17fb0b9a..50bbb84e6 100644 --- a/tests/testthat/test-S4.R +++ b/tests/testthat/test-S4.R @@ -2741,6 +2741,42 @@ test_that("S4 parents reject accessor overrides of inherited slots", { }) }) +test_that("S7 subclasses reject accessor overrides of inherited S4 slots", { + defer(S4_remove_classes(c( + "S4regS7AccessorSlotGetterChild", + "S4regS7AccessorSlotParent", + "S4regS7AccessorSlotSetterChild" + ))) + + setClass("S4regS7AccessorSlotParent", slots = list(x = "numeric")) + Parent := new_class( + parent = getClass("S4regS7AccessorSlotParent"), + package = NULL + ) + + expect_snapshot(error = TRUE, { + new_class( + "S4regS7AccessorSlotGetterChild", + parent = Parent, + properties = list( + x = new_property(class_numeric, getter = function(self) 1) + ), + package = NULL + ) + }) + + expect_snapshot(error = TRUE, { + new_class( + "S4regS7AccessorSlotSetterChild", + parent = Parent, + properties = list( + x = new_property(class_numeric, setter = function(self, value) self) + ), + package = NULL + ) + }) +}) + test_that("S7 property narrowing rejects unrelated S4 name matches", { defer(S4_remove_classes(c( "S4regPropertyNameCollisionChild", diff --git a/tests/testthat/test-class.R b/tests/testthat/test-class.R index 8d0c12cbe..52bfb113f 100644 --- a/tests/testthat/test-class.R +++ b/tests/testthat/test-class.R @@ -368,6 +368,19 @@ test_that("new_object() rejects S4 parent objects in custom constructors", { expect_snapshot(Child(), error = TRUE) }) +test_that("new_object() rejects non-S7 seeds for S4 parents without data parts", { + Parent := local_S4_class(slots = list(x = "numeric")) + Child := new_class( + parent = Parent, + package = NULL, + constructor = function() { + new_object(1, x = 1) + } + ) + + expect_snapshot(Child(), error = TRUE) +}) + test_that("new_object() allows S7_object placeholder for abstract parents", { Abstract := new_class( package = NULL, From 14afa64129ca661a5e0e13335c82d865b94ee346 Mon Sep 17 00:00:00 2001 From: Tomasz Kalinowski Date: Thu, 25 Jun 2026 00:03:43 -0400 Subject: [PATCH 116/132] Reject S4 parents with implicit data parts MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Reject S4 data parents that inherit a vector data part without exposing an explicit `.Data` slot. Finding addressed: [P2] Reject S4 data parents without explicit slots — /Users/tomasz/github/RConsortium/S7/R/constructor.R:166-172: When `parent` is an S4 data class whose representation is implicit rather than present in `parent@slots` (for example `methods::getClass("matrix")`), `parent_nms` is empty and this fallback seeds the S7 instance with `S7_object()` instead of a matrix. `Child := new_class(parent = methods::getClass("matrix"), package = NULL); methods::validObject(Child(), test = TRUE)` then reports an invalid `.Data` slot, so `new_class()` can create objects that do not satisfy their declared S4 parent. --- R/S4.R | 20 ++++++++++++++++++++ tests/testthat/_snaps/class.md | 9 +++++++++ tests/testthat/test-class.R | 6 ++++++ 3 files changed, 35 insertions(+) diff --git a/R/S4.R b/R/S4.R index ca9988d83..bee3cd8a5 100644 --- a/R/S4.R +++ b/R/S4.R @@ -726,6 +726,17 @@ S4_contains_classes <- function(parent_class_name, where) { } S4_check_slot_storage <- function(class, call = sys.call(-1L)) { + if (S4_has_implicit_data_part(class)) { + msg <- c( + sprintf( + "Can't extend S4 class %s because it has an implicit data part.", + class_desc(class) + ), + "Only S4 classes with data parts stored in an explicit `.Data` slot are supported." + ) + stop2(msg, call = call) + } + nms <- names(class@slots) renamed <- nms[prop_storage_rename(nms) != nms & nms != ".Data"] if (length(renamed) == 0L) { @@ -746,6 +757,15 @@ S4_check_slot_storage <- function(class, call = sys.call(-1L)) { stop2(msg, call = call) } +S4_has_implicit_data_part <- function(class) { + if (".Data" %in% names(class@slots)) { + return(FALSE) + } + + identical(as.character(class@className), "vector") || + "vector" %in% names(class@contains) +} + S4_reified_parent_class <- function(class, env) { parent_class <- class@parent if (is_class(parent_class)) { diff --git a/tests/testthat/_snaps/class.md b/tests/testthat/_snaps/class.md index a667dd1f1..0774265f0 100644 --- a/tests/testthat/_snaps/class.md +++ b/tests/testthat/_snaps/class.md @@ -107,6 +107,15 @@ Error in `new_class()`: ! `validator` must be function(self), not function(). +# S7 classes reject S4 parents with implicit data parts + + Code + new_class("Child", parent = methods::getClass("matrix"), package = NULL) + Condition + Error in `new_class()`: + ! Can't extend S4 class S4 because it has an implicit data part. + Only S4 classes with data parts stored in an explicit `.Data` slot are supported. + # inheritance doesn't let child properties widen or change the parent's type Code diff --git a/tests/testthat/test-class.R b/tests/testthat/test-class.R index 52bfb113f..e3724e790 100644 --- a/tests/testthat/test-class.R +++ b/tests/testthat/test-class.R @@ -84,6 +84,12 @@ test_that("S7 classes accept ordinary values for S4 parent slots", { expect_equal(obj@y, y) }) +test_that("S7 classes reject S4 parents with implicit data parts", { + expect_snapshot(error = TRUE, { + new_class("Child", parent = methods::getClass("matrix"), package = NULL) + }) +}) + test_that("S7_class can be used as a property name", { foo <- new_class( "foo", From 107d3e8b7763768f9e48201c10284f8c76f9b6f3 Mon Sep 17 00:00:00 2001 From: Tomasz Kalinowski Date: Thu, 25 Jun 2026 00:21:43 -0400 Subject: [PATCH 117/132] Avoid reinitializing S4 validity proxies MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit [P2] Avoid calling S4 initialize while preparing validity objects — /Users/tomasz/github/RConsortium/S7/R/class-spec.R:291-291: When a concrete S4 parent has an `initialize` method that requires arguments and a validity method that reads the object, constructing an S7 child fails during validation because `S4_as_validity_class()` calls `methods::new(class)` with no arguments before copying the slots over. The parent's `initialize` method errors even though the S7 constructor already supplied the required slot values, breaking S4 initialization and validity interop for non-virtual parents. --- R/class-spec.R | 7 ++++++- tests/testthat/test-S4.R | 38 ++++++++++++++++++++++++++++++++++++++ 2 files changed, 44 insertions(+), 1 deletion(-) diff --git a/R/class-spec.R b/R/class-spec.R index 5209bb710..48f137725 100644 --- a/R/class-spec.R +++ b/R/class-spec.R @@ -288,7 +288,7 @@ S4_as_validity_class <- function(object, class) { return(methods::as(object, S4_class_coerce_name(class))) } - value <- methods::new(class) + value <- S4_new_object(class) values <- S4_initialize_values(object) slots <- intersect(names(values), methods::slotNames(value)) for (name in slots) { @@ -297,6 +297,11 @@ S4_as_validity_class <- function(object, class) { value } +S4_new_object <- local({ + C_new_object <- get("C_new_object", envir = asNamespace("methods")) + function(class) .Call(C_new_object, class) +}) + S4_class_coerce_name <- function(class) { name <- class@className attr(name, "package") <- class@package diff --git a/tests/testthat/test-S4.R b/tests/testthat/test-S4.R index 50bbb84e6..e344e2c3a 100644 --- a/tests/testthat/test-S4.R +++ b/tests/testthat/test-S4.R @@ -2433,6 +2433,44 @@ test_that("S7 subclasses validate S4 parents as the parent representation", { expect_no_error(S4regValidityConcreteChild(.Data = 1)) }) +test_that("S7 subclasses validate initialized S4 parents without reinitializing", { + defer(S4_remove_classes(c( + "S4regRequiredInitializeParent", + "S4regRequiredInitializeChild" + ))) + + setClass("S4regRequiredInitializeParent", slots = list(x = "numeric")) + methods::setMethod( + "initialize", + "S4regRequiredInitializeParent", + function(.Object, x, ...) { + .Object <- callNextMethod(.Object, ...) + .Object@x <- x + .Object + } + ) + methods::setValidity("S4regRequiredInitializeParent", function(object) { + if ( + identical(as.character(class(object)), "S4regRequiredInitializeParent") + ) { + if (identical(methods::slot(object, "x"), 1)) { + return(TRUE) + } + return("parent validity must see initialized slot value") + } else { + "parent validity must see parent class" + } + }) + S4regRequiredInitializeChild := new_class( + parent = getClass("S4regRequiredInitializeParent"), + package = NULL + ) + + object <- S4regRequiredInitializeChild(x = 1) + + expect_equal(prop(object, "x"), 1) +}) + test_that("S4 data part constructors use overridden .Data defaults", { defer(S4_remove_classes(c( "S4regDataDefaultParent", From 90a664a0b4f6547795b43c305eeba8416f8166d8 Mon Sep 17 00:00:00 2001 From: Tomasz Kalinowski Date: Thu, 25 Jun 2026 00:47:53 -0400 Subject: [PATCH 118/132] Fix S4 registration review findings MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit [P2] Preserve union membership for same-package subclasses — /Users/tomasz/github/RConsortium/S7/R/S4.R:295. When `S4_register()` is called from a package namespace for a union that includes one of that package's S4 classes, this pruning removes the real class edge from the union. Same-package S4 subclasses then no longer satisfy the union, so S4 slots or methods declared with the registered union reject valid subclasses. [P2] Don't treat ordinary .Data properties as data parts — /Users/tomasz/github/RConsortium/S7/R/S4.R:631. `slot_properties` includes every stored property, including `.Data`, even when the S7 class has no base/S4 data-part parent. For `new_class("Foo", properties = list(.Data = class_numeric), package = NULL)`, `S4_register(Foo)` creates a special S4 `.Data` data-part slot, and `methods::validObject(Foo(.Data = 1), test = TRUE)` reports the data part has class "object" rather than "numeric"; either reject this case or only reify `.Data` when the class actually has a data part. --- R/S4.R | 23 +++++++++---- tests/testthat/test-S4.R | 73 ++++++++++++++++++++++++++++++++++++++++ 2 files changed, 90 insertions(+), 6 deletions(-) diff --git a/R/S4.R b/R/S4.R index bee3cd8a5..b58a7ab69 100644 --- a/R/S4.R +++ b/R/S4.R @@ -285,13 +285,16 @@ S4_register_union_member_extension <- function(class, member, union, S4_env) { return(invisible()) } - suppressWarnings(methods::setIs( + setIs_args <- list( class@className, member, where = S4_env, - classDef = class, - test = S4_class_identity_test(class@className) - )) + classDef = class + ) + if (!S4_union_member_same_package(class@className, S4_env)) { + setIs_args$test <- S4_class_identity_test(class@className) + } + suppressWarnings(do.call(methods::setIs, setIs_args)) S4_prune_union_subclass(union, class@className, S4_env) invisible() } @@ -302,9 +305,14 @@ S4_union_member_needs_identity <- function(class) { !(identical(package, "methods") && class %in% S4_methods_class_names()) } +S4_union_member_same_package <- function(class, S4_env) { + package <- attr(class, "package", exact = TRUE) + !is.null(package) && identical(package, methods::getPackageName(S4_env)) +} + # setIs() adds a transitive bare-class subclass entry to the union. Class -# unions match those names without respecting the conditional package test, so -# remove it and let objects reach the union through the identity shim. +# unions match those names without respecting package identity, so remove it +# and let objects reach the union through the package-qualified shim. S4_prune_union_subclass <- function(union, class, S4_env) { class <- as.character(class) union_def <- methods::getClass(union, where = S4_env) @@ -629,6 +637,9 @@ S4_register_class <- function(class, env = parent.frame()) { ".Data" )] slot_properties <- stored_properties + if (!".Data" %in% parent_slot_names) { + slot_properties <- slot_properties[setdiff(names(slot_properties), ".Data")] + } if (!parent_needs_identity) { slot_properties <- slot_properties[ !prop_storage_rename(names(slot_properties)) %in% parent_slot_names diff --git a/tests/testthat/test-S4.R b/tests/testthat/test-S4.R index e344e2c3a..be7efd4f3 100644 --- a/tests/testthat/test-S4.R +++ b/tests/testthat/test-S4.R @@ -482,6 +482,63 @@ test_that("S4_register keeps package-local S4 union members distinct", { expect_equal(methods::is(global_object, union_name), FALSE) }) +test_that("S4_register dispatches union methods for same-package S4 subclasses", { + pkg_env <- local_package("s4regunionlocalsubpkg") + defer({ + if (methods::isGeneric("S4regUnionLocalSubGeneric", where = pkg_env)) { + methods::removeGeneric("S4regUnionLocalSubGeneric", where = pkg_env) + } + suppressMessages({ + S4_remove_classes("S4regUnionLocalSubFoo") + S4_remove_classes( + c( + "s4regunionlocalsubpkg::S4regUnionLocalSubFoo_OR_character", + "S4/s4regunionlocalsubpkg::S4regUnionLocalSubFoo", + "S4regUnionLocalSubChild", + "S4regUnionLocalSubFoo_OR_character" + ), + pkg_env + ) + S4_remove_classes("S4regUnionLocalSubFoo", pkg_env) + }) + }) + + global_foo <- methods::setClass( + "S4regUnionLocalSubFoo", + slots = list(x = "character") + ) + pkg_foo <- methods::setClass( + "S4regUnionLocalSubFoo", + slots = list(x = "numeric"), + where = pkg_env + ) + + union_name <- S4_register(pkg_foo | class_character, env = pkg_env) + child <- methods::setClass( + "S4regUnionLocalSubChild", + contains = "S4regUnionLocalSubFoo", + where = pkg_env + ) + methods::setGeneric( + "S4regUnionLocalSubGeneric", + function(x) standardGeneric("S4regUnionLocalSubGeneric"), + where = pkg_env + ) + methods::setMethod( + "S4regUnionLocalSubGeneric", + union_name, + function(x) "union", + where = pkg_env + ) + + generic <- get("S4regUnionLocalSubGeneric", envir = pkg_env) + pkg_object <- child(x = 1) + global_object <- global_foo(x = "x") + + expect_equal(generic(pkg_object), "union") + expect_equal(methods::is(global_object, union_name), FALSE) +}) + test_that("S7 dispatch preserves package-qualified S4 parents", { pkg_env <- local_package("s4regdispatchpkg") defer({ @@ -2351,6 +2408,22 @@ test_that("S4 initialize ignores data-part attributes that collide with slots", expect_identical(methods::validObject(out), TRUE) }) +test_that("S4_register keeps direct .Data properties as ordinary properties", { + defer(S4_remove_classes("S4regDirectDataProperty")) + + S4regDirectDataProperty := new_class( + properties = list(.Data = class_numeric), + package = NULL + ) + S4_register(S4regDirectDataProperty) + + object <- S4regDirectDataProperty(.Data = 1) + + expect_equal(intersect(methods::slotNames(object), ".Data"), character()) + expect_equal(prop(object, ".Data"), 1) + expect_identical(methods::validObject(object, test = TRUE), TRUE) +}) + test_that("S4 data part constructors use the .Data argument", { defer(S4_remove_classes(c( "S4regDataPartParent", From b365755e36fd7921f674b78c004daeccd737d2fc Mon Sep 17 00:00:00 2001 From: Tomasz Kalinowski Date: Thu, 25 Jun 2026 01:04:21 -0400 Subject: [PATCH 119/132] Fix installed S4 compatibility checks MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit [P1] Resolve the native symbol at call time — /Users/tomasz/github/RConsortium/S7/R/class-spec.R:300-302: When the package is installed, the captured `NativeSymbolInfo` is serialized into the lazy-load database with a null pointer, causing `S4_new_object()` to fail with `NULL value passed as symbol address` whenever S7 validates an S7 object against an S4 parent. Look up `methods`' native routine inside the function instead of capturing the pointer. [P1] Make S4 identity tests self-contained — /Users/tomasz/github/RConsortium/S7/R/S4.R:333-338: For unions containing an S4 class from another package, `methods::setIs()` propagates this test onto the transitive union extension with `namespace:methods` as its environment, so unqualified S7-internal helper calls are not found in an installed package. `methods::is(pkg_object, union_name)` after `S4_register(pkg_s4 | class_character)` then errors during validity checks, even though it works under `load_all()`. --- R/S4.R | 11 +++++- R/class-spec.R | 6 +-- tests/testthat/t5parent/DESCRIPTION | 9 +++++ tests/testthat/t5parent/NAMESPACE | 4 ++ tests/testthat/t5parent/R/t5parent.R | 12 ++++++ tests/testthat/test-S4.R | 56 ++++++++++++++++++++++++++++ 6 files changed, 93 insertions(+), 5 deletions(-) create mode 100644 tests/testthat/t5parent/DESCRIPTION create mode 100644 tests/testthat/t5parent/NAMESPACE create mode 100644 tests/testthat/t5parent/R/t5parent.R diff --git a/R/S4.R b/R/S4.R index b58a7ab69..8cd5ca969 100644 --- a/R/S4.R +++ b/R/S4.R @@ -330,12 +330,19 @@ S4_class_identity_test <- function(target) { new_function( alist(object = ), bquote({ - class <- S4_object_class_def(base::class(object)) + S7_namespace <- base::asNamespace("S7") + class <- base::get( + "S4_object_class_def", + envir = S7_namespace + )(base::class(object)) if (is.null(class)) { return(FALSE) } - S4_class_extends_identity(class, .(target)) + base::get( + "S4_class_extends_identity", + envir = S7_namespace + )(class, .(target)) }) ) } diff --git a/R/class-spec.R b/R/class-spec.R index 48f137725..90574da76 100644 --- a/R/class-spec.R +++ b/R/class-spec.R @@ -297,10 +297,10 @@ S4_as_validity_class <- function(object, class) { value } -S4_new_object <- local({ +S4_new_object <- function(class) { C_new_object <- get("C_new_object", envir = asNamespace("methods")) - function(class) .Call(C_new_object, class) -}) + .Call(C_new_object, class) +} S4_class_coerce_name <- function(class) { name <- class@className diff --git a/tests/testthat/t5parent/DESCRIPTION b/tests/testthat/t5parent/DESCRIPTION new file mode 100644 index 000000000..7400e3d49 --- /dev/null +++ b/tests/testthat/t5parent/DESCRIPTION @@ -0,0 +1,9 @@ +Package: t5parent +Title: Test Provider Of A Foreign S4 Class +Version: 0.0.0.9000 +Authors@R: + person("Jim", "Hester", , "james.f.hester@gmail.com", role = c("aut", "cre")) +Description: Provides an S4 class used by installed-package S7 compatibility tests. +Imports: methods +License: MIT + file LICENSE +Encoding: UTF-8 diff --git a/tests/testthat/t5parent/NAMESPACE b/tests/testthat/t5parent/NAMESPACE new file mode 100644 index 000000000..39ab4867c --- /dev/null +++ b/tests/testthat/t5parent/NAMESPACE @@ -0,0 +1,4 @@ +# Generated by roxygen2: do not edit by hand + +export(identity_parent_class) +export(new_identity_parent) diff --git a/tests/testthat/t5parent/R/t5parent.R b/tests/testthat/t5parent/R/t5parent.R new file mode 100644 index 000000000..c832022ba --- /dev/null +++ b/tests/testthat/t5parent/R/t5parent.R @@ -0,0 +1,12 @@ +T5IdentityParent <- methods::setClass( + "T5IdentityParent", + slots = list(x = "numeric") +) + +identity_parent_class <- function() { + methods::getClass("T5IdentityParent", where = topenv()) +} + +new_identity_parent <- function(x) { + methods::new(identity_parent_class(), x = x) +} diff --git a/tests/testthat/test-S4.R b/tests/testthat/test-S4.R index be7efd4f3..73832af5a 100644 --- a/tests/testthat/test-S4.R +++ b/tests/testthat/test-S4.R @@ -364,6 +364,62 @@ test_that("S4_register allows S4 subclasses of package union members", { expect_equal(methods::is(child_object, union_name), TRUE) }) +test_that("S4 compatibility works from an installed S7 namespace", { + skip_if(getRversion() < "4.1" && Sys.info()[["sysname"]] == "Windows") + skip_if(quick_test()) + + tmp_lib <- local_libpath() + opts <- c( + "--data-compress=none", + "--no-byte-compile", + "--no-data", + "--no-demo", + "--no-docs", + "--no-help", + "--no-html", + "--use-vanilla" + ) + install.packages( + pkgs = normalizePath(test_path("../..")), + lib = tmp_lib, + repos = NULL, + type = "source", + quiet = TRUE, + INSTALL_opts = paste(opts, collapse = " ") + ) + quick_install(test_path("t5parent"), tmp_lib) + + expect_no_error(callr::r( + function(lib) { + .libPaths(c(lib, .libPaths())) + library(S7) + + methods::setClass("T5ValidityParent", slots = list(x = "numeric")) + methods::setValidity("T5ValidityParent", function(object) { + if (identical(as.character(class(object)), "T5ValidityParent")) { + TRUE + } else { + "parent validity must see parent class" + } + }) + T5ValidityChild <- S7::new_class( + name = "T5ValidityChild", + parent = methods::getClass("T5ValidityParent"), + package = NULL + ) + stopifnot(methods::validObject(T5ValidityChild(x = 1))) + + union <- S7::S4_register( + t5parent::identity_parent_class() | S7::class_character + ) + stopifnot(methods::is(t5parent::new_identity_parent(x = 1), union)) + + NULL + }, + args = list(lib = tmp_lib) + )) +}) + test_that("S4_register keeps global S4 union members distinct", { pkg_env <- local_package("s4regglobalunionpkg") defer({ From 1a61bebf894520d5320b5a16228564a733774e62 Mon Sep 17 00:00:00 2001 From: Tomasz Kalinowski Date: Thu, 25 Jun 2026 01:32:12 -0400 Subject: [PATCH 120/132] Fix S4 registration storage handling MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit [P2] Add .S3Class for S3 data-parent registrations — /Users/tomasz/github/RConsortium/S7/R/S4.R:707-707: When an S7 class wraps a custom S3 class whose class vector includes a base data class, `base_parent(class)` is an `S7_S3_class` and `parent_slot_names` is empty, so this returns `FALSE`. `S4_register()` then creates the S4 class without `.S3Class`; after `setOldClass()` adds `.Data`, `S4_set_S7_object_extension()` fails with “missing slot ... (.S3Class)”, breaking the documented registration path for S7 classes with S3 parents. [P2] Reject duplicate S7 storage names after merging properties — /Users/tomasz/github/RConsortium/S7/R/class.R:159-159: When an S4 parent has a slot whose name is already an S7 storage name, such as `_names`, and the S7 child adds the corresponding public property `names`, this merge leaves both properties in `all_props` even though `prop_storage_rename()` maps both to `_names`. The generated constructor accepts both arguments but `prop(obj, "names")` reads the parent `_names` slot, so the child `names` value is ignored or overwritten; reject duplicate storage names before storing `all_props`. --- R/S4.R | 48 +++++++++++++++++++++++++++++++--- R/class.R | 34 ++++++++++++++++++++++++ tests/testthat/_snaps/class.md | 9 +++++++ tests/testthat/test-S4.R | 15 +++++++++++ tests/testthat/test-class.R | 15 +++++++++++ 5 files changed, 118 insertions(+), 3 deletions(-) diff --git a/R/S4.R b/R/S4.R index 8cd5ca969..40b33859f 100644 --- a/R/S4.R +++ b/R/S4.R @@ -658,7 +658,7 @@ S4_register_class <- function(class, env = parent.frame()) { if (needs_S7_class_slot) { slots$`_S7_class` <- "S7_class" } - if (S4_needs_S3_class_slot(class, parent_slot_names, old_classes)) { + if (S4_needs_S3_class_slot(class, parent_slot_names, old_classes, where)) { slots$.S3Class <- "character" } contains <- S4_contains_classes(parent_class_name, where) @@ -699,12 +699,54 @@ S4_register_class <- function(class, env = parent.frame()) { class_name } -S4_needs_S3_class_slot <- function(class, parent_slot_names, old_classes) { +S4_needs_S3_class_slot <- function( + class, + parent_slot_names, + old_classes, + where +) { if (!"S7_object" %in% old_classes || ".S3Class" %in% parent_slot_names) { return(FALSE) } - is_base_class(base_parent(class)) || ".Data" %in% parent_slot_names + is_base_class(base_parent(class)) || + S4_has_S3_data_parent(class, where) || + ".Data" %in% parent_slot_names +} + +S4_has_S3_data_parent <- function(class, where) { + parent <- base_parent(class) + if (!is_S3_class(parent)) { + return(FALSE) + } + + any(vlapply(parent$class, S4_class_has_data_part, where = where)) +} + +S4_class_has_data_part <- function(class, where) { + if (class %in% S4_old_class_data_part_names()) { + return(TRUE) + } + + class_def <- methods::getClassDef(class, where = where) + !is.null(class_def) && ".Data" %in% names(class_def@slots) +} + +S4_old_class_data_part_names <- function() { + c( + "logical", + "integer", + "numeric", + "complex", + "character", + "raw", + "list", + "expression", + "name", + "call", + "function", + "environment" + ) } S4_set_S7_object_extension <- function(class_name, old_classes, where) { diff --git a/R/class.R b/R/class.R index a79338a86..a7e8ea0be 100644 --- a/R/class.R +++ b/R/class.R @@ -157,6 +157,7 @@ new_class <- function( # Combine properties from parent, overriding as needed all_props <- parent_props all_props[names(new_props)] <- new_props + check_prop_storage_names(all_props) if (is.null(constructor)) { constructor <- new_constructor( @@ -495,6 +496,39 @@ check_prop_names <- function(properties, call = sys.call(-1L)) { } } +check_prop_storage_names <- function(properties, call = sys.call(-1L)) { + nms <- names2(properties) + storage_nms <- prop_storage_rename_static(nms) + if (!anyDuplicated(storage_nms)) { + return(invisible()) + } + + storage_name <- storage_nms[duplicated(storage_nms)][[1L]] + prop_nms <- nms[storage_nms == storage_name] + msg <- sprintf( + "Properties %s must not use the same storage name %s.", + paste(dQuote(prop_nms), collapse = ", "), + dQuote(storage_name) + ) + stop2(msg, call = call) +} + +prop_storage_rename_static <- function(nms) { + special <- c( + names = "_names", + dim = "_dim", + dimnames = "_dimnames", + class = "_class", + tsp = "_tsp", + comment = "_comment", + row.names = "_row.names" + ) + idx <- match(nms, names(special)) + out <- nms + out[!is.na(idx)] <- unname(special[idx[!is.na(idx)]]) + out +} + check_prop_overrides <- function( child_props, parent_props, diff --git a/tests/testthat/_snaps/class.md b/tests/testthat/_snaps/class.md index 0774265f0..b1e55521c 100644 --- a/tests/testthat/_snaps/class.md +++ b/tests/testthat/_snaps/class.md @@ -116,6 +116,15 @@ ! Can't extend S4 class S4 because it has an implicit data part. Only S4 classes with data parts stored in an explicit `.Data` slot are supported. +# S7 classes reject duplicate property storage names + + Code + new_class("StorageNameChild", parent = getClass("StorageNameParent"), + properties = list(names = class_character), package = NULL) + Condition + Error in `new_class()`: + ! Properties "_names", "names" must not use the same storage name "_names". + # inheritance doesn't let child properties widen or change the parent's type Code diff --git a/tests/testthat/test-S4.R b/tests/testthat/test-S4.R index 73832af5a..9105d22e6 100644 --- a/tests/testthat/test-S4.R +++ b/tests/testthat/test-S4.R @@ -65,6 +65,21 @@ test_that("S4_register constructs S4 subclasses with S3 data-part parents", { expect_equal(methods::slot(child, "y"), "child") }) +test_that("S4_register registers S7 classes with custom S3 data parents", { + defer(S4_remove_classes("S4regS7S3Integer")) + + S4regS3Integer <- new_S3_class( + c("S4regS3Integer", "integer"), + constructor = function(.data = integer()) { + structure(.data, class = c("S4regS3Integer", "integer")) + } + ) + S4regS7S3Integer := new_class(parent = S4regS3Integer, package = NULL) + + expect_equal(S4_register(S4regS7S3Integer), "S4regS7S3Integer") + expect_contains(methods::slotNames("S4regS7S3Integer"), ".S3Class") +}) + test_that("S4_register registers S7 property classes", { defer(S4_remove_classes(c( "S4regS7PropParent", diff --git a/tests/testthat/test-class.R b/tests/testthat/test-class.R index e3724e790..723b4a62a 100644 --- a/tests/testthat/test-class.R +++ b/tests/testthat/test-class.R @@ -90,6 +90,21 @@ test_that("S7 classes reject S4 parents with implicit data parts", { }) }) +test_that("S7 classes reject duplicate property storage names", { + defer(S4_remove_classes("StorageNameParent")) + + setClass("StorageNameParent", slots = list(`_names` = "character")) + + expect_snapshot(error = TRUE, { + new_class( + "StorageNameChild", + parent = getClass("StorageNameParent"), + properties = list(names = class_character), + package = NULL + ) + }) +}) + test_that("S7_class can be used as a property name", { foo <- new_class( "foo", From f90a9ddb00f2385e36fab9f73a0868480c747711 Mon Sep 17 00:00:00 2001 From: Tomasz Kalinowski Date: Thu, 25 Jun 2026 01:53:48 -0400 Subject: [PATCH 121/132] Avoid methods C entry point for S4 validity MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit [P2] Avoid the unregistered methods C entry point — /Users/tomasz/github/RConsortium/S7/R/class-spec.R:300-302: `.Call(C_new_object, class)` triggers an R CMD check foreign-function registration NOTE because `C_new_object` is looked up from the `methods` namespace rather than being a registered symbol in this package. This also relies on an unexported methods implementation detail; use a supported construction path or avoid the internal C call. --- R/class-spec.R | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/R/class-spec.R b/R/class-spec.R index 90574da76..b8cdccea9 100644 --- a/R/class-spec.R +++ b/R/class-spec.R @@ -298,8 +298,9 @@ S4_as_validity_class <- function(object, class) { } S4_new_object <- function(class) { - C_new_object <- get("C_new_object", envir = asNamespace("methods")) - .Call(C_new_object, class) + value <- class@prototype + attr(value, "class") <- S4_class_coerce_name(class) + base::asS4(value, TRUE) } S4_class_coerce_name <- function(class) { From 3d2d9778069bad8ae97c347a0f8017e3e969dce5 Mon Sep 17 00:00:00 2001 From: Tomasz Kalinowski Date: Thu, 25 Jun 2026 02:22:00 -0400 Subject: [PATCH 122/132] Preserve S7 property names through S4 parents MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit [P2] Preserve public S7 property names from S4 parents — /Users/tomasz/github/RConsortium/S7/R/S4.R:1161-1165: When an S7 class extends an S4 class that itself extends an S7 class with a special-name property like `names`, the inherited S4 slot is the storage name (`_names`). Importing slot names verbatim makes the new S7 child expose `_names` instead of the public inherited `names` property, so `Grand(names = ...)` is rejected and `prop(obj, "names")` is missing even though the object still inherits from the original S7 class. --- R/S4.R | 39 ++++++++++++++++++++++++++++++++++----- R/constructor.R | 3 ++- tests/testthat/test-S4.R | 30 ++++++++++++++++++++++++++++++ 3 files changed, 66 insertions(+), 6 deletions(-) diff --git a/R/S4.R b/R/S4.R index 40b33859f..e8da08288 100644 --- a/R/S4.R +++ b/R/S4.R @@ -1156,21 +1156,50 @@ S4_to_S7_class <- function(x, error_base = "", call = sys.call(-1L)) { S4_slot_properties <- function(class) { slots <- class@slots slots <- slots[!names(slots) %in% S4_internal_slot_names()] + slot_names <- names(slots) + property_names <- S4_slot_property_names(class, slot_names) properties <- Map( S4_slot_property, slots, - names(slots), + slot_names, + property_names, MoreArgs = list(owner = class) ) - names(properties) <- names(slots) + names(properties) <- property_names properties } -S4_slot_property <- function(class, name, owner) { +S4_slot_property_names <- function(class, slot_names) { + property_names <- slot_names + inherited <- S4_inherited_S7_property_names(class) + idx <- match(slot_names, names(inherited)) + property_names[!is.na(idx)] <- inherited[idx[!is.na(idx)]] + property_names +} + +S4_inherited_S7_property_names <- function(class) { + properties <- character() + for (extension in class@contains) { + super <- methods::getClass(extension@superClass) + if (!S4_is_reified_S7_class(super)) { + next + } + + s7_class <- methods::slot(super@prototype, "_S7_class") + property_names <- names(s7_class@properties) + storage_names <- prop_storage_rename(property_names) + names(property_names) <- storage_names + properties <- c(properties, property_names) + } + + properties[!duplicated(names(properties))] +} + +S4_slot_property <- function(class, slot_name, property_name, owner) { new_property( class = S4_to_S7_class(methods::getClass(class)), - default = S4_slot_prototype_default(owner, name), - name = name + default = S4_slot_prototype_default(owner, slot_name), + name = property_name ) } diff --git a/R/constructor.R b/R/constructor.R index 5110cc4cf..f71c1915c 100644 --- a/R/constructor.R +++ b/R/constructor.R @@ -153,10 +153,11 @@ new_S4_constructor <- function(parent, properties, envir, package) { }) parent_value_nms <- setdiff(parent_nms, ".Data") + parent_value_storage_nms <- prop_storage_rename(parent_value_nms) parent_value_args <- if (parent@virtual) { as_names(parent_value_nms) } else { - lapply(parent_value_nms, function(name) { + lapply(parent_value_storage_nms, function(name) { bquote(.parent_values[[.(name)]]) }) } diff --git a/tests/testthat/test-S4.R b/tests/testthat/test-S4.R index 9105d22e6..d9223e4d6 100644 --- a/tests/testthat/test-S4.R +++ b/tests/testthat/test-S4.R @@ -2845,6 +2845,36 @@ test_that("S4_register keeps direct S7 special-name property slots valid", { expect_true(methods::validObject(object)) }) +test_that("S7 classes preserve special-named properties inherited through S4", { + defer(S4_remove_classes(c( + "S4regSpecialSlotGrand", + "S4regSpecialSlotMiddle", + "S4regSpecialSlotParent" + ))) + + S4regSpecialSlotParent := new_class( + properties = list(names = class_character), + package = NULL + ) + S4_register(S4regSpecialSlotParent) + methods::setClass( + "S4regSpecialSlotMiddle", + contains = S4_contains(S4regSpecialSlotParent) + ) + S4regSpecialSlotGrand := new_class( + parent = methods::getClass("S4regSpecialSlotMiddle"), + package = NULL + ) + + object <- S4regSpecialSlotGrand(names = "n") + + expect_equal(prop_names(object), "names") + expect_equal(prop(object, "names"), "n") + expect_equal(methods::slot(object, "_names"), "n") + expect_equal(S7_inherits(object, S4regSpecialSlotParent), TRUE) + expect_identical(methods::validObject(object), TRUE) +}) + test_that("S4 classes can not extend S7-over-S4 classes with property setters", { on.exit(S4_remove_classes(c("Parent2", "Child2", "S4Child2"))) setClass("Parent2", slots = list(x = "numeric")) From 3ac9c395b89b8618b24313192df0cb7701e3eb8e Mon Sep 17 00:00:00 2001 From: Tomasz Kalinowski Date: Thu, 25 Jun 2026 02:41:32 -0400 Subject: [PATCH 123/132] Refresh stale S7 property class registration MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit [P2] Re-register stale S7 property classes — /Users/tomasz/github/RConsortium/S7/R/S4.R:511-514: When a stored property uses an S7 class whose S4 definition already exists but no longer matches the current class object, such as after redefining that property class during development, the `isClass()` guard skips `S4_register()`. The following `S4_class()` then rejects the stale definition, so `S4_register(Holder)` fails unless users manually re-register the nested class, defeating the automatic property-class registration added here. --- R/S4.R | 4 +--- tests/testthat/test-S4.R | 27 +++++++++++++++++++++++++++ 2 files changed, 28 insertions(+), 3 deletions(-) diff --git a/R/S4.R b/R/S4.R index e8da08288..556758670 100644 --- a/R/S4.R +++ b/R/S4.R @@ -508,9 +508,7 @@ S4_property_class <- function(prop, S4_env) { } S4_register_property_class <- function(class, S4_env) { - if ( - is_class(class) && !methods::isClass(class_register(class), where = S4_env) - ) { + if (is_class(class) && is.null(S4_registered_class_or_null(class, S4_env))) { S4_register(class, S4_env) } invisible() diff --git a/tests/testthat/test-S4.R b/tests/testthat/test-S4.R index d9223e4d6..b8300cbc4 100644 --- a/tests/testthat/test-S4.R +++ b/tests/testthat/test-S4.R @@ -122,6 +122,33 @@ test_that("S4_register registers S7 property classes", { expect_true(methods::validObject(object)) }) +test_that("S4_register refreshes stale S7 property classes", { + defer(S4_remove_classes(c( + "S4regS7PropStaleHolder", + "S4regS7PropStale" + ))) + + S4regS7PropStale := new_class(package = NULL) + S4_register(S4regS7PropStale) + + S4regS7PropStale := new_class( + properties = list(x = new_property(class_numeric, default = 1)), + package = NULL + ) + S4regS7PropStaleHolder := new_class( + properties = list(prop = S4regS7PropStale), + package = NULL + ) + + expect_no_error(S4_register(S4regS7PropStaleHolder)) + expect_identical( + methods::validObject(S4regS7PropStaleHolder( + prop = S4regS7PropStale() + )), + TRUE + ) +}) + test_that("S4 parent slots declared as registered S7 classes use S7 classes", { defer(S4_remove_classes(c( "S4regSlotS7Child", From 6a048a65e4a187af62ac1ff31c79296fd5260008 Mon Sep 17 00:00:00 2001 From: Tomasz Kalinowski Date: Thu, 25 Jun 2026 03:12:02 -0400 Subject: [PATCH 124/132] Fix S4 data parts and union subclasses MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Finding 1: [P2] Preserve S3 data attributes for S4 data parts — /Users/tomasz/github/RConsortium/S7/R/S4.R:1100-1103: Because this treats every S4 slot as protected metadata, S4 subclasses of S7 classes with S3 data parents lose the attributes stored in those slots. For example, after `S4_register(new_class(parent = class_factor))`, `S7_data()` on an S4 subclass returns raw integer codes and `S7_data<-` drops new `levels`, rather than preserving a factor; data frames similarly lose `names`/`row.names`. Finding 2: [P2] Register existing package subclasses with S4 unions — /Users/tomasz/github/RConsortium/S7/R/S4.R:297-298: When a non-global S4 subclass already exists before `S4_register(parent | ...)` is called, this only connects the package-qualified member to the shim after the union has been built, so the existing subclass is not added to the union and `methods::is(child, union_name)`/union methods fail. This is a common package load order when classes are defined before unions, so existing subclasses need to be propagated to the union too. --- R/S4.R | 80 +++++++++++++++++++++++++++++- R/data.R | 4 ++ tests/testthat/test-S4.R | 103 +++++++++++++++++++++++++++++++++++++++ 3 files changed, 186 insertions(+), 1 deletion(-) diff --git a/R/S4.R b/R/S4.R index 556758670..a114b3108 100644 --- a/R/S4.R +++ b/R/S4.R @@ -296,9 +296,51 @@ S4_register_union_member_extension <- function(class, member, union, S4_env) { } suppressWarnings(do.call(methods::setIs, setIs_args)) S4_prune_union_subclass(union, class@className, S4_env) + S4_register_union_member_subclasses(class@className, member, union, S4_env) invisible() } +S4_register_union_member_subclasses <- function(class, member, union, S4_env) { + member_def <- methods::getClass(member, where = S4_env) + subclasses <- member_def@subclasses + subclasses <- base::Filter( + function(x) !identical(S4_class_key(x@subClass), S4_class_key(class)), + subclasses + ) + union_def <- methods::getClass(union, where = S4_env) + union_subclass_keys <- S4_class_keys( + S4_extension_subclasses(union_def@subclasses) + ) + + for (subclass in subclasses) { + if (S4_class_key(subclass@subClass) %in% union_subclass_keys) { + next + } + + subclass_def <- S4_get_class(subclass@subClass, S4_env) + suppressWarnings(methods::setIs( + subclass_def@className, + union, + where = S4_class_env(subclass_def@className, S4_env), + classDef = subclass_def + )) + } + invisible() +} + +S4_get_class <- function(class, S4_env) { + methods::getClass(as.character(class), where = S4_class_env(class, S4_env)) +} + +S4_class_env <- function(class, S4_env) { + package <- attr(class, "package", exact = TRUE) + if (is.null(package) || identical(package, ".GlobalEnv")) { + return(S4_env) + } + + asNamespace(package) +} + S4_union_member_needs_identity <- function(class) { package <- attr(class, "package", exact = TRUE) !is.null(package) && @@ -1099,7 +1141,7 @@ S4_initialize_data_part <- function(value, object) { S4_data_part_protected_attributes <- function(object) { c( - methods::slotNames(object), + setdiff(methods::slotNames(object), S4_data_part_attribute_names(object)), if (has_S7_class(object)) prop_storage_names(object), "class", "_S7_class", @@ -1107,6 +1149,42 @@ S4_data_part_protected_attributes <- function(object) { ) } +S4_data_part_attribute_names <- function(object) { + S3_class <- S4_data_part_S3_class(object) + if (is.null(S3_class)) { + return(character()) + } + + unique(unlist( + lapply(S3_class, S4_old_class_data_attribute_names), + use.names = FALSE + )) +} + +S4_old_class_data_attribute_names <- function(class) { + class <- tryCatch( + methods::getClass(class), + error = function(cnd) NULL + ) + if (is.null(class) || !methods::extends(class, "oldClass")) { + return(character()) + } + + setdiff(names(class@slots), c(".Data", ".S3Class")) +} + +S4_data_part_S3_class <- function(object) { + if (has_S7_class(object)) { + base <- base_parent(S7_class(object)) + if (is_S3_class(base)) { + return(base$class) + } + return(NULL) + } + + attr(object, ".S3Class", exact = TRUE) +} + is_S4_class <- function(x) inherits(x, "classRepresentation") S4_to_S7_class <- function(x, error_base = "", call = sys.call(-1L)) { diff --git a/R/data.R b/R/data.R index c9893a212..a9bc903fd 100644 --- a/R/data.R +++ b/R/data.R @@ -83,8 +83,12 @@ is_S4_data_part_object <- function(object) { S4_data_part <- function(object) { data <- methods::slot(object, ".Data") attrs <- attributes(object) %||% list() + S3_class <- S4_data_part_S3_class(object) attrs[c(S4_data_part_protected_attributes(object), ".S3Class")] <- NULL attributes(data) <- modify_list(attributes(data), attrs) + if (!is.null(S3_class)) { + class(data) <- S3_class + } data } diff --git a/tests/testthat/test-S4.R b/tests/testthat/test-S4.R index b8300cbc4..d6864ffd0 100644 --- a/tests/testthat/test-S4.R +++ b/tests/testthat/test-S4.R @@ -65,6 +65,58 @@ test_that("S4_register constructs S4 subclasses with S3 data-part parents", { expect_equal(methods::slot(child, "y"), "child") }) +test_that("S4_register preserves S3 data attributes for S4 subclasses", { + defer(S4_remove_classes(c( + "S4regS7DataFrameChild", + "S4regS7DataFrame", + "S4regS7FactorAttrsChild", + "S4regS7FactorAttrs" + ))) + + S4regS7FactorAttrs := new_class(parent = class_factor, package = NULL) + S4_register(S4regS7FactorAttrs) + methods::setClass( + "S4regS7FactorAttrsChild", + contains = S4_contains(S4regS7FactorAttrs), + slots = list(y = "character") + ) + factor_child <- methods::new( + "S4regS7FactorAttrsChild", + .Data = 1L, + levels = "a", + y = "child" + ) + + expect_equal(S7_data(factor_child), factor("a")) + + S7_data(factor_child) <- factor("b") + + expect_equal(S7_data(factor_child), factor("b")) + expect_equal(methods::slot(factor_child, "y"), "child") + + S4regS7DataFrame := new_class(parent = class_data.frame, package = NULL) + S4_register(S4regS7DataFrame) + methods::setClass( + "S4regS7DataFrameChild", + contains = S4_contains(S4regS7DataFrame), + slots = list(y = "character") + ) + df_child <- methods::new( + "S4regS7DataFrameChild", + .Data = list(a = 1), + names = "a", + row.names = 1L, + y = "child" + ) + + expect_equal(S7_data(df_child), data.frame(a = 1)) + + S7_data(df_child) <- data.frame(b = 2) + + expect_equal(S7_data(df_child), data.frame(b = 2)) + expect_equal(methods::slot(df_child, "y"), "child") +}) + test_that("S4_register registers S7 classes with custom S3 data parents", { defer(S4_remove_classes("S4regS7S3Integer")) @@ -637,6 +689,57 @@ test_that("S4_register dispatches union methods for same-package S4 subclasses", expect_equal(methods::is(global_object, union_name), FALSE) }) +test_that("S4_register dispatches union methods for existing S4 subclasses", { + pkg_env <- local_package("s4regunionexistingsubpkg") + defer({ + if (methods::isGeneric("S4regUnionExistingSubGeneric", where = pkg_env)) { + methods::removeGeneric("S4regUnionExistingSubGeneric", where = pkg_env) + } + suppressMessages({ + S4_remove_classes( + c( + "s4regunionexistingsubpkg::S4regUnionExistingSubFoo_OR_character", + "S4/s4regunionexistingsubpkg::S4regUnionExistingSubFoo", + "S4regUnionExistingSubChild", + "S4regUnionExistingSubFoo_OR_character" + ), + pkg_env + ) + S4_remove_classes("S4regUnionExistingSubFoo", pkg_env) + }) + }) + + pkg_foo <- methods::setClass( + "S4regUnionExistingSubFoo", + slots = list(x = "numeric"), + where = pkg_env + ) + child <- methods::setClass( + "S4regUnionExistingSubChild", + contains = "S4regUnionExistingSubFoo", + where = pkg_env + ) + + union_name <- S4_register(pkg_foo | class_character, env = pkg_env) + methods::setGeneric( + "S4regUnionExistingSubGeneric", + function(x) standardGeneric("S4regUnionExistingSubGeneric"), + where = pkg_env + ) + methods::setMethod( + "S4regUnionExistingSubGeneric", + union_name, + function(x) "union", + where = pkg_env + ) + + generic <- get("S4regUnionExistingSubGeneric", envir = pkg_env) + child_object <- child(x = 1) + + expect_equal(methods::is(child_object, union_name), TRUE) + expect_equal(generic(child_object), "union") +}) + test_that("S7 dispatch preserves package-qualified S4 parents", { pkg_env <- local_package("s4regdispatchpkg") defer({ From fbf04d26e3e2d4e4d1deecd1a865caa9acf6fff4 Mon Sep 17 00:00:00 2001 From: Tomasz Kalinowski Date: Thu, 25 Jun 2026 03:37:30 -0400 Subject: [PATCH 125/132] Fix S4/S7 registration and validation edge cases [P2] Preserve S7 validators through S4 hops: In /Users/tomasz/github/RConsortium/S7/R/class-spec.R:253-254, when an S7 class is extended by an S4 class and then used as the parent of another S7 class, validation of the original S7 superclass can be skipped. For example, with P -> Mid via S4_contains(P) and G := new_class(parent = getClass("Mid")), S7_inherits(G(), P) is TRUE, but mutating G after construction can bypass P's property/class validators because validation of Mid skips the reified P class. [P2] Require a reified S7 class for S4_contains(): In /Users/tomasz/github/RConsortium/S7/R/S4.R:78-80, old-style setOldClass(c("Foo", "S7_object")) registrations are accepted even though they only have .S3Class and lack the new _S7_class slot or S7 property slots. An S4 subclass created from that return value cannot initialize inherited S7 properties, e.g. methods::new("Child", x = 1) fails because slot x was never exposed; S4_contains() should force or reject old registrations rather than treating them as suitable contains targets. [P2] Preserve S4 subclass prototypes over deferred defaults: In /Users/tomasz/github/RConsortium/S7/R/S4.R:1061-1064, for S4 subclasses of registered S7 classes, using the concrete class prototype as the sentinel makes an explicit subclass prototype look like an unset inherited value. If the S7 property has a deferred default such as quote({ 1 }) and the S4 subclass sets prototype = list(x = 5), methods::new("Child") overwrites x with 1 instead of preserving the subclass prototype 5. --- R/S4.R | 35 +++++++---------- R/class-spec.R | 41 +++++++++++++++++++ tests/testthat/_snaps/S4.md | 17 ++++++++ tests/testthat/test-S4.R | 78 +++++++++++++++++++++++++++++++++++++ 4 files changed, 149 insertions(+), 22 deletions(-) diff --git a/R/S4.R b/R/S4.R index a114b3108..977147a7b 100644 --- a/R/S4.R +++ b/R/S4.R @@ -75,9 +75,18 @@ S4_contains <- function(class, env = parent.frame()) { stop2("S4 classes can not extend abstract S7 classes.", call = sys.call()) } - class_name <- as.character( - S4_registered_class(class, where, call = sys.call())@className - ) + registered <- S4_registered_class(class, where, call = sys.call()) + if (!S4_registered_S7_class_matches(registered, class)) { + msg <- sprintf( + paste0( + "Class has not been registered as a reified S7 class; ", + "please call S4_register(%s)." + ), + class_deparse(class) + ) + stop2(msg, call = sys.call()) + } + class_name <- as.character(registered@className) S4_check_contains(class) class_name } @@ -1059,7 +1068,7 @@ S4_initialize_default_values <- function(object, supplied, S4_env) { } S4_slot_has_prototype_value <- function(object, name, S4_env) { - prototype <- S4_object_class(object, S4_env)@prototype + prototype <- S4_registered_class(S7_class(object), S4_env)@prototype value <- methods::slot(object, name) prototype_value <- methods::slot(prototype, name) if (identical(value, prototype_value)) { @@ -1075,24 +1084,6 @@ S4_slot_has_prototype_value <- function(object, name, S4_env) { ) } -S4_object_class <- function(object, S4_env) { - class <- class(object) - name <- class[[1L]] - package <- attr(class, "package", exact = TRUE) - if (!is.null(package)) { - class_def <- methods::getClassDef( - name, - package = package, - inherits = FALSE - ) - if (!is.null(class_def)) { - return(class_def) - } - } - - methods::getClass(name, where = S4_env) -} - S4_strip_data_part_identity <- function(x) { attrs <- attributes(x) attrs[S4_internal_slot_names()] <- NULL diff --git a/R/class-spec.R b/R/class-spec.R index b8cdccea9..13bbf7996 100644 --- a/R/class-spec.R +++ b/R/class-spec.R @@ -251,6 +251,13 @@ S4_validate_old_class <- function(class, object, skip = character()) { break } if (S4_is_reified_S7_class(super_def)) { + super_S7 <- methods::slot(super_def@prototype, "_S7_class") + if (!S7_extends_via_S7_parent(S7_class(object), super_S7)) { + errors <- c(errors, S4_validate_reified_S7_class(super_S7, object)) + if (length(errors)) { + break + } + } next } @@ -283,6 +290,40 @@ S4_validate_old_class <- function(class, object, skip = character()) { } } +S4_validate_reified_S7_class <- function(class, object) { + errors <- validate_properties(object, class, parent_class = class@parent) + if (length(errors) > 0L) { + return(errors) + } + + error <- class_validate(class, object) + if (is.null(error)) { + character() + } else if (is.character(error)) { + error + } else { + stop2( + sprintf( + "%s validator must return NULL or a character, not <%s>.", + obj_desc(class), + typeof(error) + ), + call = NULL + ) + } +} + +S7_extends_via_S7_parent <- function(child, parent) { + while (is_class(child)) { + if (identical(child, parent) || isTRUE(all.equal(child, parent))) { + return(TRUE) + } + child <- child@parent + } + + FALSE +} + S4_as_validity_class <- function(object, class) { if (isS4(object) || !has_S7_class(object) || class@virtual) { return(methods::as(object, S4_class_coerce_name(class))) diff --git a/tests/testthat/_snaps/S4.md b/tests/testthat/_snaps/S4.md index 5a1c5a8e9..4890d6612 100644 --- a/tests/testthat/_snaps/S4.md +++ b/tests/testthat/_snaps/S4.md @@ -1,3 +1,11 @@ +# S4_contains rejects old-style S7 registrations + + Code + S4_contains(S4regContainsOldStyle) + Condition + Error in `S4_contains()`: + ! Class has not been registered as a reified S7 class; please call S4_register(S4regContainsOldStyle). + # S4_contains rejects unrelated S4 classes with the same name Code @@ -95,6 +103,15 @@ ! S4 object is invalid: - x must have length 1 +# S7-over-S4 classes run S7 validators inherited through S4 + + Code + prop(object, "x") <- numeric() + Condition + Error: + ! object is invalid: + - x must have length 1 + # S4 subclasses of S7 classes run concrete S4 validity Code diff --git a/tests/testthat/test-S4.R b/tests/testthat/test-S4.R index d6864ffd0..3884b7c41 100644 --- a/tests/testthat/test-S4.R +++ b/tests/testthat/test-S4.R @@ -243,6 +243,20 @@ test_that("S4_contains requires prior S4 registration", { ) }) +test_that("S4_contains rejects old-style S7 registrations", { + defer(S4_remove_classes("S4regContainsOldStyle")) + + S4regContainsOldStyle := new_class( + properties = list(x = class_numeric), + package = NULL + ) + methods::setOldClass(c("S4regContainsOldStyle", "S7_object")) + + expect_snapshot(error = TRUE, { + S4_contains(S4regContainsOldStyle) + }) +}) + test_that("S4_contains rejects unrelated S4 classes with the same name", { defer(S4_remove_classes("S4regContainsCollision")) setClass("S4regContainsCollision", slots = list(x = "numeric")) @@ -1298,6 +1312,36 @@ test_that("S4_register evaluates expression defaults for each S4 object", { expect_null(prop(object2, "x")$value) }) +test_that("S4 subclass prototypes override deferred S7 defaults", { + defer(S4_remove_classes(c( + "S4regPrototypeDeferred", + "S4regPrototypeDeferredChild" + ))) + + S4regPrototypeDeferred := new_class( + properties = list( + x = new_property( + class = class_numeric, + default = quote({ + 1 + }) + ) + ), + package = NULL + ) + S4_register(S4regPrototypeDeferred) + methods::setClass( + Class = "S4regPrototypeDeferredChild", + contains = S4_contains(S4regPrototypeDeferred), + prototype = list(x = 5) + ) + + object <- methods::new("S4regPrototypeDeferredChild") + + expect_equal(methods::slot(object, "x"), 5) + expect_equal(prop(object, "x"), 5) +}) + test_that("S4_register evaluates deferred defaults in the constructor environment", { defer(S4_remove_classes(c( "S4regDefaultEnv", @@ -2158,6 +2202,40 @@ test_that("S4 subclasses of S7-over-S4 classes run S4 parent validity", { }) }) +test_that("S7-over-S4 classes run S7 validators inherited through S4", { + defer(S4_remove_classes(c( + "S4regS7HopParent", + "S4regS7HopMid", + "S4regS7HopChild" + ))) + + S4regS7HopParent := new_class( + properties = list(x = class_numeric), + validator = function(self) { + if (length(prop(self, "x")) != 1) { + "x must have length 1" + } + }, + package = NULL + ) + S4_register(S4regS7HopParent) + methods::setClass( + Class = "S4regS7HopMid", + contains = S4_contains(S4regS7HopParent) + ) + S4regS7HopChild := new_class( + parent = methods::getClass("S4regS7HopMid"), + package = NULL + ) + + object <- S4regS7HopChild(x = 1) + expect_equal(S7_inherits(object, S4regS7HopParent), TRUE) + + expect_snapshot(error = TRUE, { + prop(object, "x") <- numeric() + }) +}) + test_that("S4 subclasses of S7 classes run concrete S4 validity", { defer(S4_remove_classes(c( "S4regConcreteValidityParent", From 18be07d046b8c61c4ad4d032b81480fe5c5143d7 Mon Sep 17 00:00:00 2001 From: Tomasz Kalinowski Date: Thu, 25 Jun 2026 04:06:58 -0400 Subject: [PATCH 126/132] Preserve S4 .S3Class slots for S7 children MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit [P2] Preserve .S3Class slots from S4 parents — /Users/tomasz/github/RConsortium/S7/R/S4.R:1223-1225. When an S4 parent has a real `.S3Class` slot, e.g. `setClass("P", contains = "factor")`, dropping it leaves direct S7 children missing part of the parent representation. In that case `S7_inherits(child, getClass("P"))` is `FALSE` and `convert(child, to = getClass("P"))` fails, even though the class was declared with that S4 parent. Preserve `.S3Class` for non-S7-reified parents or reject these parents up front. --- R/S4.R | 18 +++++++++++++++++- R/class-spec.R | 6 ++++++ R/convert.R | 4 ++++ tests/testthat/test-S4.R | 31 +++++++++++++++++++++++++++++++ 4 files changed, 58 insertions(+), 1 deletion(-) diff --git a/R/S4.R b/R/S4.R index 977147a7b..428c2e57e 100644 --- a/R/S4.R +++ b/R/S4.R @@ -1222,7 +1222,7 @@ S4_to_S7_class <- function(x, error_base = "", call = sys.call(-1L)) { S4_slot_properties <- function(class) { slots <- class@slots - slots <- slots[!names(slots) %in% S4_internal_slot_names()] + slots <- slots[!names(slots) %in% S4_slot_property_internal_names(class)] slot_names <- names(slots) property_names <- S4_slot_property_names(class, slot_names) properties <- Map( @@ -1236,6 +1236,22 @@ S4_slot_properties <- function(class) { properties } +S4_slot_property_internal_names <- function(class) { + if (S4_has_reified_S7_old_class_slot(class)) { + S4_internal_slot_names() + } else { + "_S7_class" + } +} + +S4_has_reified_S7_old_class_slot <- function(class) { + S4_is_reified_S7_class(class) || + any(vlapply(class@contains, function(extension) { + super <- methods::getClass(extension@superClass) + S4_is_reified_S7_class(super) + })) +} + S4_slot_property_names <- function(class, slot_names) { property_names <- slot_names inherited <- S4_inherited_S7_property_names(class) diff --git a/R/class-spec.R b/R/class-spec.R index 13bbf7996..bd0d04fe4 100644 --- a/R/class-spec.R +++ b/R/class-spec.R @@ -560,6 +560,12 @@ inherits_S4_class <- function(x, what) { if (identical(as.character(what@className), "ANY")) { return(TRUE) } + if (has_S7_class(x)) { + class <- S7_class(x) + if (is_class(class) && class_extends(class, what)) { + return(TRUE) + } + } if (!inherits_S4(x) && is.object(x)) { return(FALSE) } diff --git a/R/convert.R b/R/convert.R index a44ba493d..3a5381e61 100644 --- a/R/convert.R +++ b/R/convert.R @@ -206,6 +206,10 @@ convert_up <- function(from, to, call = sys.call(-1L)) { } else { class(from) <- class_dispatch(to) } + } else if ( + is_S4_class(to) && is_class(from_class) && class_extends(from_class, to) + ) { + from <- S4_as_validity_class(from, to) } else if (is_S4_coerce(from, to)) { from <- convert_S4(from, to) } else { diff --git a/tests/testthat/test-S4.R b/tests/testthat/test-S4.R index 3884b7c41..d0f076ad0 100644 --- a/tests/testthat/test-S4.R +++ b/tests/testthat/test-S4.R @@ -3083,6 +3083,37 @@ test_that("S7 classes preserve special-named properties inherited through S4", { expect_identical(methods::validObject(object), TRUE) }) +test_that("S7 classes preserve .S3Class slots inherited from S4 parents", { + defer(S4_remove_classes(c( + "S4regS3ClassSlotChild", + "S4regS3ClassSlotParent", + "S4regS3ClassSlotOld", + "S4regS3ClassSlotBase" + ))) + + old_classes <- c("S4regS3ClassSlotOld", "S4regS3ClassSlotBase") + methods::setOldClass(old_classes) + methods::setClass( + "S4regS3ClassSlotParent", + contains = "S4regS3ClassSlotOld" + ) + S4regS3ClassSlotChild := new_class( + parent = methods::getClass("S4regS3ClassSlotParent"), + package = NULL + ) + + object <- S4regS3ClassSlotChild() + + expect_equal(prop(object, ".S3Class"), old_classes) + expect_equal( + S7_inherits(object, methods::getClass("S4regS3ClassSlotParent")), + TRUE + ) + parent <- convert(object, to = methods::getClass("S4regS3ClassSlotParent")) + expect_s4_class(parent, "S4regS3ClassSlotParent") + expect_equal(methods::slot(parent, ".S3Class"), old_classes) +}) + test_that("S4 classes can not extend S7-over-S4 classes with property setters", { on.exit(S4_remove_classes(c("Parent2", "Child2", "S4Child2"))) setClass("Parent2", slots = list(x = "numeric")) From be64d9dde5bbfa4672ca33c7d9f4be23528d2582 Mon Sep 17 00:00:00 2001 From: Tomasz Kalinowski Date: Thu, 25 Jun 2026 04:34:38 -0400 Subject: [PATCH 127/132] Preserve S4 data part attributes MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit [P2] Preserve S4 data-part attributes for direct S7 children — /Users/tomasz/github/RConsortium/S7/R/data.R:31-33: When an S7 class directly extends an S4 class with an S3 data part, such as `setClass("P", contains = "factor")`, instances are intentionally not `isS4()`, so they skip this branch and fall through to `zap_attr()`. Because slots like `levels` and `.S3Class` were imported as S7 properties, `S7_data(Child(.Data = 1:2, levels = c("a", "b"), .S3Class = "factor"))` returns bare integers instead of a factor. Handle S4 data-part ancestry here or reject these parents when defining the class. --- R/S4.R | 12 +++++++++--- R/data.R | 12 +++++++++++- tests/testthat/test-S4.R | 27 +++++++++++++++++++++++++++ 3 files changed, 47 insertions(+), 4 deletions(-) diff --git a/R/S4.R b/R/S4.R index 428c2e57e..a4e4f1ded 100644 --- a/R/S4.R +++ b/R/S4.R @@ -1131,9 +1131,13 @@ S4_initialize_data_part <- function(value, object) { } S4_data_part_protected_attributes <- function(object) { + attribute_names <- S4_data_part_attribute_names(object) + c( - setdiff(methods::slotNames(object), S4_data_part_attribute_names(object)), - if (has_S7_class(object)) prop_storage_names(object), + setdiff(methods::slotNames(object), attribute_names), + if (has_S7_class(object)) { + setdiff(prop_storage_names(object), attribute_names) + }, "class", "_S7_class", "S7_class" @@ -1170,7 +1174,9 @@ S4_data_part_S3_class <- function(object) { if (is_S3_class(base)) { return(base$class) } - return(NULL) + if (!is_S4_class(base) || !".S3Class" %in% names(base@slots)) { + return(NULL) + } } attr(object, ".S3Class", exact = TRUE) diff --git a/R/data.R b/R/data.R index a9bc903fd..6fa784f21 100644 --- a/R/data.R +++ b/R/data.R @@ -77,7 +77,17 @@ base_parent <- function(class) { } is_S4_data_part_object <- function(object) { - isS4(object) && ".Data" %in% methods::slotNames(object) + if (isS4(object)) { + return(".Data" %in% methods::slotNames(object)) + } + + if (!S7_inherits(object)) { + return(FALSE) + } + + class <- S7_class(object) + parent <- if (is_class(class)) S4_ancestor(class) + !is.null(parent) && ".Data" %in% names(parent@slots) } S4_data_part <- function(object) { diff --git a/tests/testthat/test-S4.R b/tests/testthat/test-S4.R index d0f076ad0..cfac44096 100644 --- a/tests/testthat/test-S4.R +++ b/tests/testthat/test-S4.R @@ -2923,6 +2923,33 @@ test_that("S7_data() reads and writes S4 subclass data parts", { expect_identical(methods::validObject(object), TRUE) }) +test_that("S7_data() preserves S4 data-part attributes on direct S7 children", { + defer(S4_remove_classes(c( + "S4regS7FactorChild", + "S4regS7FactorParent" + ))) + + setClass("S4regS7FactorParent", contains = "factor") + suppressWarnings({ + S4regS7FactorChild := new_class( + parent = getClass("S4regS7FactorParent"), + package = NULL + ) + }) + + object <- S4regS7FactorChild( + .Data = 1:2, + levels = c("a", "b"), + .S3Class = "factor" + ) + + expect_equal(S7_data(object), factor(c("a", "b"))) + + S7_data(object) <- factor("b", levels = c("a", "b", "c")) + + expect_equal(S7_data(object), factor("b", levels = c("a", "b", "c"))) +}) + test_that("S7_data() keeps data attributes that match renamed S7 properties", { defer(S4_remove_classes(c( "S4regS7DataNameAttrChild", From 48c749e2b5d06bb203e66ad1a04e2dfcd2b05a30 Mon Sep 17 00:00:00 2001 From: Tomasz Kalinowski Date: Thu, 25 Jun 2026 04:57:28 -0400 Subject: [PATCH 128/132] Check S4 slot types for S7 subclasses MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit [P2] Check concrete S4 slot types for S7-backed slots — /Users/tomasz/github/RConsortium/S7/R/valid.R:166. When an S4 subclass redeclares an inherited S7 property slot with a narrower S4 type, construction only runs S4 validity methods and skips formal slot-class checks. For example, a parent S7 property `x = class_numeric` with a child S4 slot `x = "integer"` lets `methods::new("Child", x = 1)` return an object that `methods::validObject()` immediately rejects, so construction can produce invalid S4 objects. --- R/class-spec.R | 80 ++++++++++++++++++++++++++++++++++++- tests/testthat/_snaps/S4.md | 9 +++++ tests/testthat/test-S4.R | 22 ++++++++++ 3 files changed, 110 insertions(+), 1 deletion(-) diff --git a/R/class-spec.R b/R/class-spec.R index bd0d04fe4..aea9dcf71 100644 --- a/R/class-spec.R +++ b/R/class-spec.R @@ -228,7 +228,7 @@ S4_validate_old_class <- function(class, object, skip = character()) { if (isTRUE(x)) character() else x } - errors <- character() + errors <- S4_validate_slots(class, object) extends <- rev(class@contains) for (ext in extends) { super_class <- ext@superClass @@ -290,6 +290,84 @@ S4_validate_old_class <- function(class, object, skip = character()) { } } +S4_validate_slots <- function(class, object) { + errors <- character() + slot_types <- class@slots + slot_names <- names(slot_types) + attr_names <- c(".Data", ".S3Class", names(attributes(object))) + + missing <- is.na(match(slot_names, attr_names)) + if (any(missing)) { + errors <- c( + errors, + paste( + "slots in class definition but not in object:", + paste0("\"", slot_names[missing], "\"", collapse = ", ") + ) + ) + slot_types <- slot_types[!missing] + slot_names <- slot_names[!missing] + } + + where <- get(".classEnv", envir = asNamespace("methods"))(class) + S3Class <- get("S3Class", envir = asNamespace("methods")) + for (i in seq_along(slot_types)) { + slot_class <- slot_types[[i]] + slot_class_def <- methods::getClassDef(slot_class, where = where) + if (is.null(slot_class_def)) { + errors <- c( + errors, + paste0( + "undefined class for slot \"", + slot_names[[i]], + "\" (\"", + slot_class, + "\")" + ) + ) + next + } + + slot_name <- slot_names[[i]] + value <- tryCatch( + switch( + slot_name, + .S3Class = S3Class(object), + methods::slot(object, slot_name) + ), + error = function(cnd) cnd + ) + if (inherits(value, "error")) { + errors <- c(errors, conditionMessage(value)) + next + } + + ok <- methods::possibleExtends( + class(value), + slot_class, + ClassDef2 = slot_class_def + ) + if (isFALSE(ok)) { + errors <- c( + errors, + paste0( + "invalid object for slot \"", + slot_name, + "\" in class \"", + class(object)[[1L]], + "\": got class \"", + class(value)[[1L]], + "\", should be or extend class \"", + slot_class, + "\"" + ) + ) + } + } + + errors +} + S4_validate_reified_S7_class <- function(class, object) { errors <- validate_properties(object, class, parent_class = class@parent) if (length(errors) > 0L) { diff --git a/tests/testthat/_snaps/S4.md b/tests/testthat/_snaps/S4.md index 4890d6612..512c15138 100644 --- a/tests/testthat/_snaps/S4.md +++ b/tests/testthat/_snaps/S4.md @@ -130,6 +130,15 @@ ! S4 object is invalid: - x must have length 1 +# S4 subclasses of S7 classes check concrete slot types + + Code + methods::new("S4regConcreteSlotChild", x = 1) + Condition + Error in `validate()`: + ! S4 object is invalid: + - invalid object for slot "x" in class "S4regConcreteSlotChild": got class "numeric", should be or extend class "integer" + # S4 subclass validation preserves concrete class package Code diff --git a/tests/testthat/test-S4.R b/tests/testthat/test-S4.R index cfac44096..585684dd2 100644 --- a/tests/testthat/test-S4.R +++ b/tests/testthat/test-S4.R @@ -2270,6 +2270,28 @@ test_that("S4 subclasses of S7 classes run concrete S4 validity", { }) }) +test_that("S4 subclasses of S7 classes check concrete slot types", { + defer(S4_remove_classes(c( + "S4regConcreteSlotParent", + "S4regConcreteSlotChild" + ))) + + S4regConcreteSlotParent := new_class( + properties = list(x = class_numeric), + package = NULL + ) + S4_register(S4regConcreteSlotParent) + setClass( + "S4regConcreteSlotChild", + contains = S4_contains(S4regConcreteSlotParent), + slots = list(x = "integer") + ) + + expect_snapshot(error = TRUE, { + methods::new("S4regConcreteSlotChild", x = 1) + }) +}) + test_that("S4 subclass validation preserves concrete class package", { pkg_env <- local_package("s4regvalidpkg") defer({ From 279fd8e65b78cd94100e36147fdccabaace86071 Mon Sep 17 00:00:00 2001 From: Tomasz Kalinowski Date: Thu, 25 Jun 2026 05:18:10 -0400 Subject: [PATCH 129/132] Preserve S7_class property when upcasting MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit [P2] Preserve S7_class when upcasting — /Users/tomasz/github/RConsortium/S7/R/convert.R:201-201: When the target S7 parent has a user property named `S7_class`, the hard-coded removal drops that property even though it is included in `to_props`. Upcasting `Child(S7_class = 1, ...)` to a parent that defines `S7_class` returns an object where `@S7_class` is `NULL` and validation fails; the legacy class attribute should only be removed when it is not a target property. --- R/convert.R | 3 ++- tests/testthat/test-convert.R | 21 +++++++++++++++++++++ 2 files changed, 23 insertions(+), 1 deletion(-) diff --git a/R/convert.R b/R/convert.R index 3a5381e61..014717859 100644 --- a/R/convert.R +++ b/R/convert.R @@ -196,9 +196,10 @@ convert_up <- function(from, to, call = sys.call(-1L)) { } else { character() } + class_attrs <- c("_S7_class", setdiff("S7_class", to_props)) from <- zap_attr( from, - c(setdiff(from_props, to_props), s4_slot_attrs, "_S7_class", "S7_class") + c(setdiff(from_props, to_props), s4_slot_attrs, class_attrs) ) attr(from, "_S7_class") <- to if (is_s4_subclass) { diff --git a/tests/testthat/test-convert.R b/tests/testthat/test-convert.R index 9a79f8b49..a0b79ca2c 100644 --- a/tests/testthat/test-convert.R +++ b/tests/testthat/test-convert.R @@ -69,6 +69,27 @@ test_that("fallback convert can convert to super class", { expect_equal(attr(obj, "y"), NULL) }) +test_that("fallback convert preserves S7_class property when upcasting", { + local_methods(convert) + Parent := new_class( + properties = list(S7_class = class_numeric), + package = NULL + ) + Child := new_class( + parent = Parent, + properties = list(x = class_character), + package = NULL + ) + + child <- Child(S7_class = 1, x = "a") + parent <- convert(child, to = Parent) + + expect_equal(S7_class(parent), Parent) + expect_equal(prop(parent, "S7_class"), 1) + expect_equal(props(parent), list(S7_class = 1)) + expect_null(attr(parent, "x", exact = TRUE)) +}) + test_that("fallback convert can convert to subclass", { local_methods(convert) Foo := new_class(properties = list(x = class_numeric)) From 2988150b6b4765627239aa474ebb5b874046bda5 Mon Sep 17 00:00:00 2001 From: Tomasz Kalinowski Date: Thu, 25 Jun 2026 05:49:08 -0400 Subject: [PATCH 130/132] Fix S4 data-part replacement and contains validation MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit [P2] Unwrap S4 values before replacing S4 data parts — /Users/tomasz/github/RConsortium/S7/R/S4.R:1128. When the replacement `.Data` is itself an S4 data-part object and the target is a direct S7 child of an S4 data-part class (`isS4(object)` is false), this branch strips and reattributes the whole S4 wrapper instead of its `.Data` slot. Calls such as `initialize(child, .Data = methods::new("Parent", .Data = 2))` can hang or produce a corrupt object; unwrap incoming S4 data-part values with `S4_data_part(value)` before copying attributes. [P2] Reject or handle multiple S7 superclasses in S4 contains — /Users/tomasz/github/RConsortium/S7/R/class-spec.R:372. When an S4 class contains more than one `S4_contains()` superclass, this validation path tries to validate each reified S7 superclass through `prop()`, but `prop()` resolves properties through the object's single `_S7_class` slot. For `setClass("Both", contains = c(S4_contains(Foo), S4_contains(Bar)))`, properties or validators from the secondary S7 class can fail with `Property not found` or be inconsistent with `S7_class()`, so this should either be rejected up front or validated without relying on a single `_S7_class`. --- R/S4.R | 3 ++ R/class-spec.R | 29 +++++++++++++++++++ tests/testthat/_snaps/S4.md | 9 ++++++ tests/testthat/test-S4.R | 57 +++++++++++++++++++++++++++++++++++++ 4 files changed, 98 insertions(+) diff --git a/R/S4.R b/R/S4.R index a4e4f1ded..3063e5cdd 100644 --- a/R/S4.R +++ b/R/S4.R @@ -1115,6 +1115,9 @@ S4_initialize_values <- function(object) { } S4_initialize_data_part <- function(value, object) { + if (is_S4_data_part_object(value)) { + value <- S4_data_part(value) + } protected <- S4_data_part_protected_attributes(object) incoming <- attributes(value) %||% list() incoming[protected] <- NULL diff --git a/R/class-spec.R b/R/class-spec.R index aea9dcf71..ed31f70bf 100644 --- a/R/class-spec.R +++ b/R/class-spec.R @@ -228,6 +228,11 @@ S4_validate_old_class <- function(class, object, skip = character()) { if (isTRUE(x)) character() else x } + errors <- S4_validate_single_reified_S7_contains(class) + if (length(errors) > 0L) { + return(errors) + } + errors <- S4_validate_slots(class, object) extends <- rev(class@contains) for (ext in extends) { @@ -290,6 +295,30 @@ S4_validate_old_class <- function(class, object, skip = character()) { } } +S4_validate_single_reified_S7_contains <- function(class) { + classes <- S4_direct_reified_S7_contains(class) + if (length(classes) <= 1L) { + return(character()) + } + + class_names <- vcapply(classes, class_desc) + sprintf( + "%s directly contains multiple S7 classes via S4_contains(): %s", + class_desc(class), + paste(class_names, collapse = ", ") + ) +} + +S4_direct_reified_S7_contains <- function(class) { + contains <- base::Filter(function(x) x@distance == 1, class@contains) + supers <- lapply(contains, function(x) methods::getClassDef(x@superClass)) + supers <- base::Filter( + function(x) !is.null(x) && S4_is_reified_S7_class(x), + supers + ) + lapply(supers, function(x) methods::slot(x@prototype, "_S7_class")) +} + S4_validate_slots <- function(class, object) { errors <- character() slot_types <- class@slots diff --git a/tests/testthat/_snaps/S4.md b/tests/testthat/_snaps/S4.md index 512c15138..0e0e87601 100644 --- a/tests/testthat/_snaps/S4.md +++ b/tests/testthat/_snaps/S4.md @@ -139,6 +139,15 @@ ! S4 object is invalid: - invalid object for slot "x" in class "S4regConcreteSlotChild": got class "numeric", should be or extend class "integer" +# S4 subclasses reject multiple S4_contains() parents + + Code + methods::new("S4regMultipleS7ContainsBoth", x = 1, y = 2) + Condition + Error in `validate()`: + ! S4 object is invalid: + - S4 directly contains multiple S7 classes via S4_contains(): , + # S4 subclass validation preserves concrete class package Code diff --git a/tests/testthat/test-S4.R b/tests/testthat/test-S4.R index 585684dd2..80aaf136c 100644 --- a/tests/testthat/test-S4.R +++ b/tests/testthat/test-S4.R @@ -2292,6 +2292,36 @@ test_that("S4 subclasses of S7 classes check concrete slot types", { }) }) +test_that("S4 subclasses reject multiple S4_contains() parents", { + defer(S4_remove_classes(c( + "S4regMultipleS7ContainsFoo", + "S4regMultipleS7ContainsBar", + "S4regMultipleS7ContainsBoth" + ))) + + S4regMultipleS7ContainsFoo := new_class( + properties = list(x = class_numeric), + package = NULL + ) + S4regMultipleS7ContainsBar := new_class( + properties = list(y = class_numeric), + package = NULL + ) + S4_register(S4regMultipleS7ContainsFoo) + S4_register(S4regMultipleS7ContainsBar) + setClass( + "S4regMultipleS7ContainsBoth", + contains = c( + S4_contains(S4regMultipleS7ContainsFoo), + S4_contains(S4regMultipleS7ContainsBar) + ) + ) + + expect_snapshot(error = TRUE, { + methods::new("S4regMultipleS7ContainsBoth", x = 1, y = 2) + }) +}) + test_that("S4 subclass validation preserves concrete class package", { pkg_env <- local_package("s4regvalidpkg") defer({ @@ -2680,6 +2710,33 @@ test_that("S4 data-part initialization preserves data attributes", { expect_equal(S7_data(out), c(b = 2)) }) +test_that("S4 initialize unwraps S4 data-part replacements", { + defer(S4_remove_classes(c( + "S4regDataPartObjectValueChild", + "S4regDataPartObjectValueParent" + ))) + + setClass("S4regDataPartObjectValueParent", contains = "numeric") + S4regDataPartObjectValueChild := new_class( + parent = getClass("S4regDataPartObjectValueParent"), + properties = list(y = class_character), + package = NULL + ) + + object <- S4regDataPartObjectValueChild(.Data = c(a = 1), y = "target") + source <- methods::new( + "S4regDataPartObjectValueParent", + .Data = c(b = 2) + ) + + out <- methods::initialize(object, .Data = source) + + expect_equal(S7_class(out), S4regDataPartObjectValueChild) + expect_equal(S7_data(out), c(b = 2)) + expect_equal(prop(out, "y"), "target") + expect_identical(methods::validObject(out), TRUE) +}) + test_that("S4 initialize ignores data-part attributes that collide with slots", { defer(S4_remove_classes(c( "S4regDataAttrParent", From 8fa70fbe3b8224d4e470fb9d3b80e48fab557617 Mon Sep 17 00:00:00 2001 From: Tomasz Kalinowski Date: Thu, 25 Jun 2026 08:19:09 -0400 Subject: [PATCH 131/132] Simplify S4 compatibility helpers --- R/S4.R | 93 ++++++++++++++++++---------------------- R/class-spec.R | 12 ++++-- R/class.R | 22 +++------- R/constructor.R | 14 ++---- R/property.R | 14 ++---- R/valid.R | 3 +- tests/testthat/helper.R | 4 +- tests/testthat/test-S4.R | 47 ++++++++++++-------- 8 files changed, 94 insertions(+), 115 deletions(-) diff --git a/R/S4.R b/R/S4.R index 3063e5cdd..fae116f30 100644 --- a/R/S4.R +++ b/R/S4.R @@ -165,11 +165,8 @@ S4_registered_S7_class_matches <- function(class, x) { return(FALSE) } registered <- methods::slot(class@prototype, "_S7_class") - is_class(registered) && S4_registered_S7_class_object_matches(registered, x) -} - -S4_registered_S7_class_object_matches <- function(registered, x) { - identical(registered, x) || isTRUE(all.equal(registered, x)) + is_class(registered) && + (identical(registered, x) || isTRUE(all.equal(registered, x))) } S4_registered_old_class_matches <- function(class, x) { @@ -289,7 +286,7 @@ S4_register_union_member_extension <- function(class, member, union, S4_env) { subclasses <- base::Filter(function(x) x@distance == 1, member_def@subclasses) if ( S4_class_key(class@className) %in% - S4_class_keys(S4_extension_subclasses(subclasses)) + S4_class_keys(S4_subclasses(subclasses)) ) { return(invisible()) } @@ -318,7 +315,7 @@ S4_register_union_member_subclasses <- function(class, member, union, S4_env) { ) union_def <- methods::getClass(union, where = S4_env) union_subclass_keys <- S4_class_keys( - S4_extension_subclasses(union_def@subclasses) + S4_subclasses(union_def@subclasses) ) for (subclass in subclasses) { @@ -342,7 +339,7 @@ S4_get_class <- function(class, S4_env) { } S4_class_env <- function(class, S4_env) { - package <- attr(class, "package", exact = TRUE) + package <- S4_class_package(class, methods = FALSE) if (is.null(package) || identical(package, ".GlobalEnv")) { return(S4_env) } @@ -351,13 +348,13 @@ S4_class_env <- function(class, S4_env) { } S4_union_member_needs_identity <- function(class) { - package <- attr(class, "package", exact = TRUE) + package <- S4_class_package(class, methods = FALSE) !is.null(package) && !(identical(package, "methods") && class %in% S4_methods_class_names()) } S4_union_member_same_package <- function(class, S4_env) { - package <- attr(class, "package", exact = TRUE) + package <- S4_class_package(class, methods = FALSE) !is.null(package) && identical(package, methods::getPackageName(S4_env)) } @@ -439,12 +436,7 @@ S4_same_class_identity <- function(x, y) { } S4_class_identity_key <- function(class) { - package <- attr(class, "package", exact = TRUE) - if (is.null(package) && class %in% S4_methods_class_names()) { - package <- "methods" - } - - paste0(package %||% "", "::", as.character(class)) + S4_class_key(class, bare_missing = FALSE, bare_global = FALSE) } S4_find_union <- function(members, S4_env) { @@ -485,30 +477,42 @@ S4_union_matches <- function(class, members, S4_env) { S4_union_members <- function(class) { subclasses <- base::Filter(function(x) x@distance == 1, class@subclasses) - S4_extension_subclasses(subclasses) + S4_subclasses(subclasses) } -S4_extension_subclasses <- function(x) { - lapply(x, function(x) x@subClass) +S4_subclasses <- function(x) { + lapply(x, methods::slot, "subClass") } S4_class_keys <- function(classes) { vcapply(classes, S4_class_key) } -S4_class_key <- function(class) { - package <- attr(class, "package", exact = TRUE) +S4_class_key <- function( + class, + bare_missing = TRUE, + bare_global = TRUE +) { + package <- S4_class_package(class) class <- as.character(class) - if (is.null(package) && class %in% S4_methods_class_names()) { - package <- "methods" - } - if (is.null(package) || identical(package, ".GlobalEnv")) { + if ( + (is.null(package) && bare_missing) || + (identical(package, ".GlobalEnv") && bare_global) + ) { class } else { - paste0(package, "::", class) + paste0(package %||% "", "::", class) } } +S4_class_package <- function(class, methods = TRUE) { + package <- attr(class, "package", exact = TRUE) + if (methods && is.null(package) && class %in% S4_methods_class_names()) { + package <- "methods" + } + package +} + S4_methods_class_names <- function() { c("NULL", "missing", "ANY", names(S4_basic_classes())) } @@ -596,7 +600,7 @@ S4_properties_prototype <- function( ) { args <- list() for (name in names(properties)) { - value <- S4_property_prototype(properties[[name]], env, class@package) + value <- S4_property_default_value(properties[[name]], env, class@package) if (length(value) != 0L) { slot_name <- prop_storage_rename(name) args[slot_name] <- value @@ -608,41 +612,25 @@ S4_properties_prototype <- function( do.call(methods::prototype, args) } -S4_property_prototype <- function(prop, env, package) { - tryCatch( - { - value <- prop_default(prop, env, package) - value <- S4_decode_pseudo_null(value) - if (is.call(value) || is.symbol(value)) { - return(list()) - } - list(value) - }, - error = function(cnd) { - if (!is.null(prop$default)) { - stop(cnd) - } - list() - } - ) -} - -S4_property_deferred_default <- function( +S4_property_default_value <- function( prop, env, package, + deferred = FALSE, allow_simple = FALSE ) { tryCatch( { value <- prop_default(prop, env, package) value <- S4_decode_pseudo_null(value) - if (!is.call(value) && !is.symbol(value)) { - if (allow_simple) { - return(list(value)) - } + is_deferred <- is.call(value) || is.symbol(value) + if (!is_deferred) { + return(if (!deferred || allow_simple) list(value) else list()) + } + if (!deferred) { return(list()) } + value <- eval(value, env) value <- S4_decode_pseudo_null(value) list(value) @@ -1054,10 +1042,11 @@ S4_initialize_default_values <- function(object, supplied, S4_env) { } prop <- properties[[name]] - value <- S4_property_deferred_default( + value <- S4_property_default_value( prop, env, class@package, + deferred = TRUE, allow_simple = identical(name, ".Data") ) if (length(value) != 0L) { diff --git a/R/class-spec.R b/R/class-spec.R index ed31f70bf..ca7a5793d 100644 --- a/R/class-spec.R +++ b/R/class-spec.R @@ -223,7 +223,12 @@ class_validate <- function(class, object) { } } -S4_validate_old_class <- function(class, object, skip = character()) { +S4_validate_old_class <- function( + class, + object, + skip = character(), + skip_slots = character() +) { any_strings <- function(x) { if (isTRUE(x)) character() else x } @@ -233,7 +238,7 @@ S4_validate_old_class <- function(class, object, skip = character()) { return(errors) } - errors <- S4_validate_slots(class, object) + errors <- S4_validate_slots(class, object, skip = skip_slots) extends <- rev(class@contains) for (ext in extends) { super_class <- ext@superClass @@ -319,9 +324,10 @@ S4_direct_reified_S7_contains <- function(class) { lapply(supers, function(x) methods::slot(x@prototype, "_S7_class")) } -S4_validate_slots <- function(class, object) { +S4_validate_slots <- function(class, object, skip = character()) { errors <- character() slot_types <- class@slots + slot_types <- slot_types[!names(slot_types) %in% skip] slot_names <- names(slot_types) attr_names <- c(".Data", ".S3Class", names(attributes(object))) diff --git a/R/class.R b/R/class.R index a7e8ea0be..53bcec368 100644 --- a/R/class.R +++ b/R/class.R @@ -498,7 +498,11 @@ check_prop_names <- function(properties, call = sys.call(-1L)) { check_prop_storage_names <- function(properties, call = sys.call(-1L)) { nms <- names2(properties) - storage_nms <- prop_storage_rename_static(nms) + if (length(nms) == 0L) { + return(invisible()) + } + + storage_nms <- prop_storage_rename(nms) if (!anyDuplicated(storage_nms)) { return(invisible()) } @@ -513,22 +517,6 @@ check_prop_storage_names <- function(properties, call = sys.call(-1L)) { stop2(msg, call = call) } -prop_storage_rename_static <- function(nms) { - special <- c( - names = "_names", - dim = "_dim", - dimnames = "_dimnames", - class = "_class", - tsp = "_tsp", - comment = "_comment", - row.names = "_row.names" - ) - idx <- match(nms, names(special)) - out <- nms - out[!is.na(idx)] <- unname(special[idx[!is.na(idx)]]) - out -} - check_prop_overrides <- function( child_props, parent_props, diff --git a/R/constructor.R b/R/constructor.R index f71c1915c..f84a3b9ca 100644 --- a/R/constructor.R +++ b/R/constructor.R @@ -10,18 +10,10 @@ new_constructor <- function( return(new_S4_constructor(parent, properties, envir, package)) } - if ( - identical(parent, S7_object) || - is_S4_class(parent) || - (is_class(parent) && parent@abstract) - ) { + if (identical(parent, S7_object) || (is_class(parent) && parent@abstract)) { # There's no parent constructor to delegate to, so the constructor must # handle all properties: inherited and newly declared (which win). - parent_props <- if (is_S4_class(parent)) { - class_properties(parent) - } else { - attr(parent, "properties", exact = TRUE) - } + parent_props <- attr(parent, "properties", exact = TRUE) all_props <- modify_list( parent_props, properties @@ -30,7 +22,7 @@ new_constructor <- function( arg_info <- constructor_args(parent, all_props, envir, package) force_args <- as_names(names(arg_info$self)) - s4_parent <- if (is_S4_class(parent)) parent else S4_ancestor(parent) + s4_parent <- S4_ancestor(parent) s4_data_part <- !is.null(s4_parent) && ".Data" %in% names(s4_parent@slots) self_arg_names <- names(arg_info$self) parent_call <- if (s4_data_part) { diff --git a/R/property.R b/R/property.R index 65e530e07..eda65b04b 100644 --- a/R/property.R +++ b/R/property.R @@ -309,17 +309,9 @@ prop <- function(object, name) { } prop_is_S4_data_part <- function(object, name) { - if (!identical(name, ".Data") || isS4(object) || !S7_inherits(object)) { - return(FALSE) - } - - class <- S7_class(object) - if (!is_class(class)) { - return(FALSE) - } - - parent <- S4_ancestor(class) - !is.null(parent) && ".Data" %in% names(parent@slots) + identical(name, ".Data") && + !isS4(object) && + is_S4_data_part_object(object) } # called from src/prop.c diff --git a/R/valid.R b/R/valid.R index e5f921aad..f7caaa77d 100644 --- a/R/valid.R +++ b/R/valid.R @@ -163,7 +163,8 @@ validate_S4_subclass <- function(object) { ancestor <- S4_ancestor(S7_class(object)) skip <- if (is.null(ancestor)) character() else S4_validity_classes(ancestor) - S4_validate_old_class(class, object, skip = skip) + skip_slots <- if (is.null(ancestor)) character() else names(ancestor@slots) + S4_validate_old_class(class, object, skip = skip, skip_slots = skip_slots) } S4_validity_classes <- function(class) { diff --git a/tests/testthat/helper.R b/tests/testthat/helper.R index 0340a330c..5b49642eb 100644 --- a/tests/testthat/helper.R +++ b/tests/testthat/helper.R @@ -1,4 +1,4 @@ -quick_install <- function(package, lib, quiet = TRUE) { +quick_install <- function(package, lib, quiet = TRUE, libs = FALSE) { opts <- c( "--data-compress=none", "--no-byte-compile", @@ -7,7 +7,7 @@ quick_install <- function(package, lib, quiet = TRUE) { "--no-docs", "--no-help", "--no-html", - "--no-libs", + if (!libs) "--no-libs", "--use-vanilla", NULL ) diff --git a/tests/testthat/test-S4.R b/tests/testthat/test-S4.R index 80aaf136c..9b8cf8a47 100644 --- a/tests/testthat/test-S4.R +++ b/tests/testthat/test-S4.R @@ -477,24 +477,7 @@ test_that("S4 compatibility works from an installed S7 namespace", { skip_if(quick_test()) tmp_lib <- local_libpath() - opts <- c( - "--data-compress=none", - "--no-byte-compile", - "--no-data", - "--no-demo", - "--no-docs", - "--no-help", - "--no-html", - "--use-vanilla" - ) - install.packages( - pkgs = normalizePath(test_path("../..")), - lib = tmp_lib, - repos = NULL, - type = "source", - quiet = TRUE, - INSTALL_opts = paste(opts, collapse = " ") - ) + quick_install(normalizePath(test_path("../..")), tmp_lib, libs = TRUE) quick_install(test_path("t5parent"), tmp_lib) expect_no_error(callr::r( @@ -2202,6 +2185,34 @@ test_that("S4 subclasses of S7-over-S4 classes run S4 parent validity", { }) }) +test_that("S4 subclass validation reports inherited S4 slot errors once", { + defer(S4_remove_classes(c( + "S4regSubSlotErrorParent", + "S4regSubSlotErrorChild", + "S4regSubSlotErrorShim" + ))) + + setClass("S4regSubSlotErrorParent", slots = list(x = "numeric")) + S4regSubSlotErrorChild := new_class( + parent = getClass("S4regSubSlotErrorParent"), + package = NULL + ) + S4regSubSlotErrorChild_S4 <- S4_contains(S4regSubSlotErrorChild) + setClass("S4regSubSlotErrorShim", contains = S4regSubSlotErrorChild_S4) + + object <- methods::new("S4regSubSlotErrorShim", x = 1) + attr(object, "x") <- "bad" + error <- tryCatch(validate(object, properties = FALSE), error = identity) + matches <- gregexpr( + "invalid object for slot", + conditionMessage(error), + fixed = TRUE + ) + + expect_s3_class(error, "S7_error_validation_failed") + expect_equal(lengths(regmatches(conditionMessage(error), matches)), 1L) +}) + test_that("S7-over-S4 classes run S7 validators inherited through S4", { defer(S4_remove_classes(c( "S4regS7HopParent", From c582779b4aa8cd1b50c4ca45e1e9b1083d342e04 Mon Sep 17 00:00:00 2001 From: Tomasz Kalinowski Date: Thu, 25 Jun 2026 08:47:02 -0400 Subject: [PATCH 132/132] Reduce S4 compatibility test duplication --- tests/testthat/test-S4.R | 118 ++++----------------------------------- 1 file changed, 10 insertions(+), 108 deletions(-) diff --git a/tests/testthat/test-S4.R b/tests/testthat/test-S4.R index 9b8cf8a47..4bdf607ff 100644 --- a/tests/testthat/test-S4.R +++ b/tests/testthat/test-S4.R @@ -1730,31 +1730,10 @@ test_that("S4_register treats S4 NULL slot sentinels as NULL-valued S7 propertie plain <- S4regNullable(x = "a") prop(plain, "x") <- NULL expect_equal(prop(plain, "x"), NULL) + expect_equal(methods::slot(plain, "x"), NULL) expect_identical(attr(plain, "x", exact = TRUE), as.name("\001NULL\001")) }) -test_that("S4_register keeps direct S7 nullable property slots valid", { - defer(S4_remove_classes(c( - "S4regDirectNullable", - "NULL_OR_character" - ))) - - S4_register(NULL | class_character) - S4regDirectNullable <- new_class( - "S4regDirectNullable", - properties = list(x = NULL | class_character), - package = NULL - ) - S4_register(S4regDirectNullable) - - object <- S4regDirectNullable() - - expect_equal(prop(object, "x"), NULL) - expect_equal(methods::slot(object, "x"), NULL) - expect_true(methods::validObject(object)) - expect_identical(attr(object, "x", exact = TRUE), as.name("\001NULL\001")) -}) - test_that("S4_contains rejects properties with custom accessors", { on.exit(S4_remove_classes(c( "S4regContainsDynamicChild", @@ -2943,39 +2922,6 @@ test_that("S4 data part constructors use overridden .Data defaults", { expect_equal(prop(object, ".Data"), 2) }) -test_that("S4 data part initialization preserves S4 subclasses", { - defer(S4_remove_classes(c( - "S4regDataPartGrandChild", - "S4regDataPartChild", - "S4regDataPartParent" - ))) - - setClass("S4regDataPartParent", contains = "numeric") - S4regDataPartChild := new_class( - parent = getClass("S4regDataPartParent"), - properties = list(y = class_character), - package = NULL - ) - setClass( - "S4regDataPartGrandChild", - slots = list(z = "logical"), - contains = "S4regDataPartChild" - ) - - object <- methods::new( - "S4regDataPartGrandChild", - .Data = 1, - y = "a", - z = TRUE - ) - - expect_s4_class(object, "S4regDataPartGrandChild") - expect_equal(as.vector(object), 1) - expect_equal(prop(object, "y"), "a") - expect_equal(methods::slot(object, "z"), TRUE) - expect_true(methods::validObject(object)) -}) - test_that("S7_data() reads and writes S4 subclass data parts", { defer(S4_remove_classes(c( "S4regS7DataPartGrandChild", @@ -3003,6 +2949,7 @@ test_that("S7_data() reads and writes S4 subclass data parts", { ) expect_equal(S7_data(object), c(a = 1)) + expect_equal(as.vector(object), 1) S7_data(object) <- c(b = 2) @@ -3081,6 +3028,11 @@ test_that("S4 subclasses read and write special-named S7 property storage slots" ) S4_register(S4regSpecialSlots) S4regSpecialSlots_S4 <- S4_contains(S4regSpecialSlots) + + direct <- S4regSpecialSlots(names = "direct", dim = 1L) + expect_equal(methods::slot(direct, "_names"), "direct") + expect_equal(prop(direct, "names"), "direct") + setClass( "S4regSpecialSlotsChild", contains = S4regSpecialSlots_S4, @@ -3114,60 +3066,10 @@ test_that("S4 subclasses read and write special-named S7 property storage slots" expect_equal(methods::slot(object, "_names"), "updated") expect_equal(methods::slot(object, "names"), "s4-only") expect_equal(prop(object, "names"), "updated") -}) - -test_that("S4 initializers copy renamed S7 property storage slots", { - defer(S4_remove_classes(c( - "S4regCopySpecialSlotsChild", - "S4regCopySpecialSlots" - ))) - - S4regCopySpecialSlots := new_class( - properties = list(names = class_character), - package = NULL - ) - S4_register(S4regCopySpecialSlots) - S4regCopySpecialSlots_S4 <- S4_contains(S4regCopySpecialSlots) - setClass( - "S4regCopySpecialSlotsChild", - contains = S4regCopySpecialSlots_S4, - slots = list(extra = "character") - ) - - old <- methods::new( - "S4regCopySpecialSlotsChild", - names = "n", - extra = "old" - ) - new <- methods::new("S4regCopySpecialSlotsChild", old) - expect_equal(prop(new, "names"), "n") - expect_equal(methods::slot(new, "_names"), "n") - expect_equal(methods::slot(new, "extra"), "old") -}) - -test_that("S4_register keeps direct S7 special-name property slots valid", { - defer(S4_remove_classes("S4regDirectSpecialSlots")) - - S4regDirectSpecialSlots <- new_class( - "S4regDirectSpecialSlots", - properties = list( - names = class_character, - dim = class_integer - ), - package = NULL - ) - S4_register(S4regDirectSpecialSlots) - - object <- S4regDirectSpecialSlots( - names = "n", - dim = 2L - ) - - expect_equal(methods::slot(object, "_names"), "n") - expect_equal(methods::slot(object, "_dim"), 2L) - expect_equal(prop(object, "names"), "n") - expect_true(methods::validObject(object)) + new <- methods::new("S4regSpecialSlotsChild", object) + expect_equal(prop(new, "names"), "updated") + expect_equal(methods::slot(new, "_names"), "updated") }) test_that("S7 classes preserve special-named properties inherited through S4", {