From 6afaae1d4787e1250b32706481f6350c32265d34 Mon Sep 17 00:00:00 2001 From: Michael Lawrence Date: Tue, 2 Jun 2026 16:08:12 -0700 Subject: [PATCH 01/79] 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 57bbdb132edb69017e544134afa60576a5c59ef4 Mon Sep 17 00:00:00 2001 From: Michael Lawrence Date: Tue, 2 Jun 2026 16:27:09 -0700 Subject: [PATCH 02/79] 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 825cea05c94ab2f9dfd9b25197b4d7bf11373ab6 Mon Sep 17 00:00:00 2001 From: Michael Lawrence Date: Tue, 2 Jun 2026 16:32:02 -0700 Subject: [PATCH 03/79] 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 119ca5f7df47312ca741585b30067300501fa10b Mon Sep 17 00:00:00 2001 From: Michael Lawrence Date: Tue, 2 Jun 2026 17:23:14 -0700 Subject: [PATCH 04/79] 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 8944b2860..5d7f909ea 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 a3de211cd64cd393415d86eeb5a681753f429204 Mon Sep 17 00:00:00 2001 From: Michael Lawrence Date: Tue, 26 May 2026 02:59:33 -0700 Subject: [PATCH 05/79] 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 3367f8dd0..7a5d0abb2 100644 --- a/R/class-spec.R +++ b/R/class-spec.R @@ -82,6 +82,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), @@ -207,12 +216,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, @@ -274,7 +284,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"), S7_external = class_dispatch(resolve_external_class_req(x)), @@ -330,7 +344,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 = some(what$classes, class_inherits, x = x), S7_S3 = !isS4(x) && class_dispatch_extends(what$class, class(x)), @@ -390,7 +404,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 5d7f909ea..9bed9de2c 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 10aea80da2e4d5a09304a78ed1ea467f20778053 Mon Sep 17 00:00:00 2001 From: Michael Lawrence Date: Tue, 26 May 2026 03:23:36 -0700 Subject: [PATCH 06/79] 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 7a5d0abb2..05548f27c 100644 --- a/R/class-spec.R +++ b/R/class-spec.R @@ -217,7 +217,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 9bed9de2c..2b7ed968f 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 69e86b107f83bbe62671ad84c1dcbabf36eca60e Mon Sep 17 00:00:00 2001 From: Michael Lawrence Date: Tue, 26 May 2026 12:23:11 -0700 Subject: [PATCH 07/79] 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 82f4840916305652cc017c0793b83e93b82a5656 Mon Sep 17 00:00:00 2001 From: Michael Lawrence Date: Tue, 26 May 2026 14:35:44 -0700 Subject: [PATCH 08/79] 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 2b7ed968f..c275cf7b6 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 f6ff8c3e7412ac7cbe4d3e2453b96a0567d19bf0 Mon Sep 17 00:00:00 2001 From: Michael Lawrence Date: Tue, 26 May 2026 15:43:18 -0700 Subject: [PATCH 09/79] 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 c275cf7b6..55e5b6c3b 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 64d369003ff09f699e2e9807c57bfe9b2de7b898 Mon Sep 17 00:00:00 2001 From: Michael Lawrence Date: Tue, 26 May 2026 15:43:35 -0700 Subject: [PATCH 10/79] 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 0f70a2b5aed8ccc989710de5ad7a9815f5f24b9c Mon Sep 17 00:00:00 2001 From: Michael Lawrence Date: Tue, 26 May 2026 16:27:33 -0700 Subject: [PATCH 11/79] 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 05548f27c..1559046ec 100644 --- a/R/class-spec.R +++ b/R/class-spec.R @@ -345,8 +345,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 = some(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 434a44b40174ad56a927cdf3dbc82b831a77914d Mon Sep 17 00:00:00 2001 From: Michael Lawrence Date: Tue, 26 May 2026 17:05:44 -0700 Subject: [PATCH 12/79] 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 c263486718b840a02f0195cf45a9ef75456a4b35 Mon Sep 17 00:00:00 2001 From: Michael Lawrence Date: Tue, 26 May 2026 17:27:53 -0700 Subject: [PATCH 13/79] 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 39d19eb4f6862675252d2e3eee1f0c06b0497d4d Mon Sep 17 00:00:00 2001 From: Michael Lawrence Date: Tue, 26 May 2026 17:29:25 -0700 Subject: [PATCH 14/79] 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 1559046ec..9ba50307f 100644 --- a/R/class-spec.R +++ b/R/class-spec.R @@ -346,7 +346,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 = some(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 8a360b8d82331b69d3b11359f7f1a35ad98d4e27 Mon Sep 17 00:00:00 2001 From: Michael Lawrence Date: Tue, 26 May 2026 23:23:27 -0700 Subject: [PATCH 15/79] 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 cc43d73c4aa817c2e2a8d16140da6cbf3d4ea3ac Mon Sep 17 00:00:00 2001 From: Michael Lawrence Date: Tue, 26 May 2026 23:42:13 -0700 Subject: [PATCH 16/79] 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 68e13987a234797d3d5d3440bbcc1668c3b42925 Mon Sep 17 00:00:00 2001 From: Michael Lawrence Date: Wed, 27 May 2026 00:08:58 -0700 Subject: [PATCH 17/79] 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 4dc60c5ab965b0e355817f0245379e595c383201 Mon Sep 17 00:00:00 2001 From: Michael Lawrence Date: Wed, 27 May 2026 11:59:52 -0700 Subject: [PATCH 18/79] 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 8d0e96713..6b443f40a 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 @@ -322,4 +326,3 @@ Condition Error: ! No S7 class for base type . - diff --git a/tests/testthat/test-class.R b/tests/testthat/test-class.R index cb3ddc669..33ac59571 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 abb356995ffe5263c8a7e5deddefa63aa5b302da Mon Sep 17 00:00:00 2001 From: Michael Lawrence Date: Wed, 27 May 2026 13:33:42 -0700 Subject: [PATCH 19/79] 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 414551b734703fae97ce909584853bbe3f035ba5 Mon Sep 17 00:00:00 2001 From: Michael Lawrence Date: Wed, 27 May 2026 23:24:06 -0700 Subject: [PATCH 20/79] 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 55e5b6c3b..622df69f6 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 5dc232532e7225dfc43d58258c63ac8e316242ac Mon Sep 17 00:00:00 2001 From: Michael Lawrence Date: Thu, 28 May 2026 02:23:31 -0700 Subject: [PATCH 21/79] 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 9b9f4da666d78174c656e2498647faf2ffbae79d Mon Sep 17 00:00:00 2001 From: Michael Lawrence Date: Thu, 28 May 2026 02:24:06 -0700 Subject: [PATCH 22/79] 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 20d89d612ff928247de324ceda771fd7450ddbd5 Mon Sep 17 00:00:00 2001 From: Michael Lawrence Date: Thu, 28 May 2026 17:24:45 -0700 Subject: [PATCH 23/79] 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 e08b1ee5efdf334ed8116bdaa171478a85d53432 Mon Sep 17 00:00:00 2001 From: Michael Lawrence Date: Fri, 29 May 2026 00:01:38 -0700 Subject: [PATCH 24/79] 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 e366cd6762b10a7ccb799bce359f3dc2c4cb1ee7 Mon Sep 17 00:00:00 2001 From: Michael Lawrence Date: Fri, 29 May 2026 00:25:46 -0700 Subject: [PATCH 25/79] 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 88ed4a6ce689f2815e76fbba90c57bb0bf8a70e4 Mon Sep 17 00:00:00 2001 From: Michael Lawrence Date: Fri, 29 May 2026 00:38:24 -0700 Subject: [PATCH 26/79] 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 adae124c82ccd8590b461edd5c1b9dad801e38a8 Mon Sep 17 00:00:00 2001 From: Michael Lawrence Date: Fri, 29 May 2026 01:40:51 -0700 Subject: [PATCH 27/79] 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 279bc2350b1105a928353146a30ecf2eb1f4fbf0 Mon Sep 17 00:00:00 2001 From: Michael Lawrence Date: Fri, 29 May 2026 01:43:27 -0700 Subject: [PATCH 28/79] 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 7cd378a935ca68375c2e07f1790419a226c69f25 Mon Sep 17 00:00:00 2001 From: Michael Lawrence Date: Sun, 31 May 2026 02:57:18 -0700 Subject: [PATCH 29/79] 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 f7d28c31ac7f27ddba45d33e14d8379b6e5839a6 Mon Sep 17 00:00:00 2001 From: Michael Lawrence Date: Sun, 31 May 2026 03:05:51 -0700 Subject: [PATCH 30/79] 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 32907a22957428a291865f655fc03596ef08e055 Mon Sep 17 00:00:00 2001 From: Michael Lawrence Date: Sun, 31 May 2026 03:19:33 -0700 Subject: [PATCH 31/79] 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 67ed28db9b0bcf1eb666f2a00bdb80b1fbd51e07 Mon Sep 17 00:00:00 2001 From: Michael Lawrence Date: Sun, 31 May 2026 03:20:58 -0700 Subject: [PATCH 32/79] 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 8d5f1ee79..7125f87aa 100644 --- a/R/method-register.R +++ b/R/method-register.R @@ -403,6 +403,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 afcf09bb03ff2d7c9f075dfe9d29ba18979e8153 Mon Sep 17 00:00:00 2001 From: Michael Lawrence Date: Sun, 31 May 2026 03:28:14 -0700 Subject: [PATCH 33/79] 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 713dcf051..527f00d7e 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -43,6 +43,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 622df69f6..74f4c7efc 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", { defer(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", { defer(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 0333e02bc5d9c900140e2c48606eb4fef60f322b Mon Sep 17 00:00:00 2001 From: Michael Lawrence Date: Mon, 1 Jun 2026 02:42:34 -0700 Subject: [PATCH 34/79] 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 99e0badf64d3a57ac484f39256cc979042a82837 Mon Sep 17 00:00:00 2001 From: Michael Lawrence Date: Mon, 1 Jun 2026 11:23:22 -0700 Subject: [PATCH 35/79] 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 b62a9a28854571986473f8a4da461a6e815d446a Mon Sep 17 00:00:00 2001 From: Michael Lawrence Date: Mon, 1 Jun 2026 11:23:45 -0700 Subject: [PATCH 36/79] 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 c78a6bb477b1c87b5ccbf074b135e169bf3f0556 Mon Sep 17 00:00:00 2001 From: Michael Lawrence Date: Mon, 1 Jun 2026 11:47:11 -0700 Subject: [PATCH 37/79] 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 74f4c7efc..26f697500 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 9a1a9d7bb3a5b896911383332569ea1a081932b6 Mon Sep 17 00:00:00 2001 From: Michael Lawrence Date: Mon, 1 Jun 2026 12:22:53 -0700 Subject: [PATCH 38/79] 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 c7bca26084e6857f23ffdc71b500c6515fe29bf4 Mon Sep 17 00:00:00 2001 From: Michael Lawrence Date: Mon, 1 Jun 2026 12:49:44 -0700 Subject: [PATCH 39/79] 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 26f697500..0d493f1dd 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 c409cbf31a2eb2de7f1a48dfba406d534052b058 Mon Sep 17 00:00:00 2001 From: Michael Lawrence Date: Mon, 1 Jun 2026 13:41:46 -0700 Subject: [PATCH 40/79] 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 6b443f40a..6ca133c2e 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 d2854192215e39938604754ac0488a95eed07352 Mon Sep 17 00:00:00 2001 From: Michael Lawrence Date: Mon, 1 Jun 2026 19:16:50 -0700 Subject: [PATCH 41/79] 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 0d493f1dd..16b71a858 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", { defer(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 bb0035af2102f66781f692f0a6df11f8c7d285c8 Mon Sep 17 00:00:00 2001 From: Michael Lawrence Date: Mon, 1 Jun 2026 19:25:02 -0700 Subject: [PATCH 42/79] 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 ef76c1c14ea6da615fe69abc227e139f2509d9e3 Mon Sep 17 00:00:00 2001 From: Michael Lawrence Date: Tue, 2 Jun 2026 02:56:20 -0700 Subject: [PATCH 43/79] 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 ed153f402e850ede0efe3f7c05273c306e40c283 Mon Sep 17 00:00:00 2001 From: Michael Lawrence Date: Tue, 2 Jun 2026 05:31:53 -0700 Subject: [PATCH 44/79] 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 16b71a858..6d491e124 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 de2c4f2ed89b214c0cdc1011864bdb211d014a9e Mon Sep 17 00:00:00 2001 From: Michael Lawrence Date: Tue, 2 Jun 2026 16:34:46 -0700 Subject: [PATCH 45/79] 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 9ba50307f..85c4d48ba 100644 --- a/R/class-spec.R +++ b/R/class-spec.R @@ -406,10 +406,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 6d491e124..5057c3545 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 630a503ec2f5e56228b5911e814baa962853b967 Mon Sep 17 00:00:00 2001 From: Michael Lawrence Date: Tue, 2 Jun 2026 16:58:36 -0700 Subject: [PATCH 46/79] 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 7125f87aa..8d5f1ee79 100644 --- a/R/method-register.R +++ b/R/method-register.R @@ -403,18 +403,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 edb789fe674dcb4fdd4976eb26a354f8630e8406 Mon Sep 17 00:00:00 2001 From: Michael Lawrence Date: Wed, 3 Jun 2026 03:59:23 -0700 Subject: [PATCH 47/79] 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 5057c3545..327dda789 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 18a00fc66e75c137e1fe80df86816f6bd4e4b472 Mon Sep 17 00:00:00 2001 From: Michael Lawrence Date: Wed, 3 Jun 2026 04:01:53 -0700 Subject: [PATCH 48/79] 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 327dda789..80ed18a72 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 fe3f60310c1cb0ace9cfe65417a28b5958d12943 Mon Sep 17 00:00:00 2001 From: Michael Lawrence Date: Wed, 3 Jun 2026 14:34:48 -0700 Subject: [PATCH 49/79] 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 80ed18a72..3eb41543b 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 de2e88e89b07ae73c5a5ef8c8fb99bcd33637b8c Mon Sep 17 00:00:00 2001 From: Michael Lawrence Date: Wed, 3 Jun 2026 17:05:26 -0700 Subject: [PATCH 50/79] 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 3eb41543b..f4958d6b1 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 23e0f4312d8e04db048d169190eec148fdefb8d0 Mon Sep 17 00:00:00 2001 From: Michael Lawrence Date: Wed, 3 Jun 2026 17:09:05 -0700 Subject: [PATCH 51/79] 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 e5804ea4449b693870ecc847491ed8321961a0e0 Mon Sep 17 00:00:00 2001 From: Michael Lawrence Date: Wed, 3 Jun 2026 18:53:23 -0700 Subject: [PATCH 52/79] 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 cd2019fbc4fcea067ede1744fe5efe28bf2ccfc4 Mon Sep 17 00:00:00 2001 From: Michael Lawrence Date: Wed, 3 Jun 2026 23:36:02 -0700 Subject: [PATCH 53/79] 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 f4958d6b1..e2fb191da 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 ce320152f50c5be7e8bfe2933632c4728a6e55ab Mon Sep 17 00:00:00 2001 From: Michael Lawrence Date: Thu, 4 Jun 2026 04:01:01 -0700 Subject: [PATCH 54/79] 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 f1315e19814ab902061632b85d3ed03e2e184e6c Mon Sep 17 00:00:00 2001 From: Michael Lawrence Date: Thu, 4 Jun 2026 04:32:50 -0700 Subject: [PATCH 55/79] 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 e2fb191da..9114ffa6c 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 8b5996bb715dadd680eb05b03cd797217304e4c9 Mon Sep 17 00:00:00 2001 From: Michael Lawrence Date: Thu, 4 Jun 2026 04:40:28 -0700 Subject: [PATCH 56/79] 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 9114ffa6c..180979afb 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 ac985ceb53dea0fbdb97ae6c946d222a1d16ea56 Mon Sep 17 00:00:00 2001 From: Michael Lawrence Date: Fri, 5 Jun 2026 00:53:01 -0700 Subject: [PATCH 57/79] 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 95dfc6e90a8923f234ef9f36580363e321618502 Mon Sep 17 00:00:00 2001 From: Michael Lawrence Date: Fri, 5 Jun 2026 05:17:15 -0700 Subject: [PATCH 58/79] 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 8d5f1ee79..87c97e6be 100644 --- a/R/method-register.R +++ b/R/method-register.R @@ -264,10 +264,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"))) @@ -283,6 +291,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 f32bbb9bc4dc1d0070eb9937addaf82c86a6f827 Mon Sep 17 00:00:00 2001 From: Michael Lawrence Date: Fri, 5 Jun 2026 11:56:16 -0700 Subject: [PATCH 59/79] 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 180979afb..3118b23ea 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 368ee9d0eadd0c6e3d99b2571b3e22f296d06bda Mon Sep 17 00:00:00 2001 From: Michael Lawrence Date: Fri, 5 Jun 2026 14:17:00 -0700 Subject: [PATCH 60/79] @<- 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 3118b23ea..b752f5c27 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 cadcc4cf3a6d7a130eaaa843d98e93cd9fa15a3f Mon Sep 17 00:00:00 2001 From: Michael Lawrence Date: Sat, 6 Jun 2026 23:31:58 -0700 Subject: [PATCH 61/79] 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 b752f5c27..64ee3fa25 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 bfad4cbf92a15cffe0e46eeb4005adb64ff336bd Mon Sep 17 00:00:00 2001 From: Michael Lawrence Date: Sun, 7 Jun 2026 02:11:32 -0700 Subject: [PATCH 62/79] 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 85c4d48ba..836ef730e 100644 --- a/R/class-spec.R +++ b/R/class-spec.R @@ -218,7 +218,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 a422af7486cc3707e1a865188e01d23c48364426 Mon Sep 17 00:00:00 2001 From: Michael Lawrence Date: Sun, 7 Jun 2026 03:48:32 -0700 Subject: [PATCH 63/79] 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 64ee3fa25..4ec0c3f69 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 00f69a56b80966275133945e66b529979751d1e5 Mon Sep 17 00:00:00 2001 From: Michael Lawrence Date: Sun, 7 Jun 2026 14:39:36 -0700 Subject: [PATCH 64/79] 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 05957b5133bc49cd2de6e0132c5d5b535e5f99d7 Mon Sep 17 00:00:00 2001 From: Michael Lawrence Date: Fri, 19 Jun 2026 09:07:43 -0700 Subject: [PATCH 65/79] 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 fefe9e979e570cbade8cdd5d91e865159f195477 Mon Sep 17 00:00:00 2001 From: Michael Lawrence Date: Fri, 19 Jun 2026 09:12:45 -0700 Subject: [PATCH 66/79] 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 7e47f148af96424448921a995d6e46e9160942ae Mon Sep 17 00:00:00 2001 From: Michael Lawrence Date: Fri, 19 Jun 2026 09:20:43 -0700 Subject: [PATCH 67/79] 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 87c97e6be..93ffde908 100644 --- a/R/method-register.R +++ b/R/method-register.R @@ -265,7 +265,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) @@ -275,7 +275,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"))) @@ -291,10 +291,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 cab73e2a1..b83f0cf8c 100644 --- a/R/utils.R +++ b/R/utils.R @@ -243,6 +243,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 38b45a3bf8dc819828137c82873ae2a43c8fa6d7 Mon Sep 17 00:00:00 2001 From: Michael Lawrence Date: Fri, 19 Jun 2026 09:25:35 -0700 Subject: [PATCH 68/79] 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 11c8bbd071c7feec35a2c6eae19d5f3dfcbab525 Mon Sep 17 00:00:00 2001 From: Michael Lawrence Date: Fri, 19 Jun 2026 09:31:02 -0700 Subject: [PATCH 69/79] 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 b252c6843860c853994c357411958100591d19d9 Mon Sep 17 00:00:00 2001 From: Michael Lawrence Date: Fri, 19 Jun 2026 10:46:44 -0700 Subject: [PATCH 70/79] 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 527f00d7e..713dcf051 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -43,7 +43,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 4ec0c3f69..43bf477d6 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 68d446a6dea56db49880e21e530fde3b27425bb2 Mon Sep 17 00:00:00 2001 From: Michael Lawrence Date: Fri, 19 Jun 2026 11:28:08 -0700 Subject: [PATCH 71/79] add NEWS entry --- NEWS.md | 1 + 1 file changed, 1 insertion(+) diff --git a/NEWS.md b/NEWS.md index 6c34bdccb..244ba7f1a 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 9439c1ddb32bb5fe173201fde86a024440f179bb Mon Sep 17 00:00:00 2001 From: Michael Lawrence Date: Fri, 19 Jun 2026 17:36:40 -0700 Subject: [PATCH 72/79] 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 836ef730e..89ec8770a 100644 --- a/R/class-spec.R +++ b/R/class-spec.R @@ -217,7 +217,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 43bf477d6..b18ec1d3e 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 853963a5274fa16511f5f5219a16fbafc4f018d0 Mon Sep 17 00:00:00 2001 From: Michael Lawrence Date: Fri, 19 Jun 2026 21:10:02 -0700 Subject: [PATCH 73/79] 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 16ab264333346eb9f61bd4d02b0b9de8b41a1e01 Mon Sep 17 00:00:00 2001 From: Michael Lawrence Date: Fri, 19 Jun 2026 21:10:34 -0700 Subject: [PATCH 74/79] 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 6ca133c2e..2879f3b73 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 33ac59571..c5dd79751 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 14e07f3776d588237877cceeee0cd31845839b3d Mon Sep 17 00:00:00 2001 From: Michael Lawrence Date: Fri, 19 Jun 2026 22:01:41 -0700 Subject: [PATCH 75/79] 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 5cc0f8acb..6248d70d5 100644 --- a/tests/testthat/helper.R +++ b/tests/testthat/helper.R @@ -102,13 +102,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 b9f71f571e1325bc405cdc295a2b0dac72085a1e Mon Sep 17 00:00:00 2001 From: Michael Lawrence Date: Sat, 20 Jun 2026 14:58:46 -0700 Subject: [PATCH 76/79] 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 713dcf051..6e485aaae 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -42,6 +42,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 b18ec1d3e..01ac90bab 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 6bc5862d141e7371b3c965d7a6852f0f002263f1 Mon Sep 17 00:00:00 2001 From: Michael Lawrence Date: Sat, 20 Jun 2026 15:26:01 -0700 Subject: [PATCH 77/79] 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 cfae9a5d2335d67521cea56a8967fc7c4ba45a3b Mon Sep 17 00:00:00 2001 From: Michael Lawrence Date: Mon, 22 Jun 2026 18:06:36 -0700 Subject: [PATCH 78/79] 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 01ac90bab..f7512701b 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 616de468f94fe250bf322737d767e02f7580f8db Mon Sep 17 00:00:00 2001 From: Michael Lawrence Date: Sat, 27 Jun 2026 12:00:49 -0700 Subject: [PATCH 79/79] fix a few style / rebase issues --- R/class-spec.R | 3 ++- R/class.R | 9 --------- R/convert.R | 5 +---- 3 files changed, 3 insertions(+), 14 deletions(-) diff --git a/R/class-spec.R b/R/class-spec.R index 89ec8770a..ef20b9f75 100644 --- a/R/class-spec.R +++ b/R/class-spec.R @@ -220,8 +220,9 @@ class_validate <- function(class, object) { if (isS4(object)) { check <- methods::validObject(object, test = TRUE) return(if (isTRUE(check)) NULL else check) + } else { + return(NULL) } - return(NULL) } validator <- switch( 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/convert.R b/R/convert.R index 82bb4100a..e2abf2c45 100644 --- a/R/convert.R +++ b/R/convert.R @@ -187,10 +187,7 @@ 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", "S7_class") - ) + 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_coerce(from, to)) {