From ffdca456ed052d47e6eb5a28a8f3641202a38eea Mon Sep 17 00:00:00 2001 From: Hadley Wickham Date: Wed, 24 Jun 2026 09:04:27 -0500 Subject: [PATCH 1/5] Pass `...` to parent constructor There are two cases where it's not safe to re-use the deafults from the parent in a subclass constructor: * When the parent comes from another package, because the specification might change between class construction and object instantaition. Fixes #317. * When the parent constructor is custom, because we don't know anything about its environment. Fixes #609. This does not make external parent classes entirely safe because it's possible the parent can make backward incompatible changes leading to run-time errors. But I think we believe that's outside of the scope of S7, and something that you'd discover when running your revdep checks prior to CRAN submission. --- NAMESPACE | 2 + NEWS.md | 3 +- R/class.R | 21 +++- R/constructor.R | 128 +++++++++++++++++++++++- R/external-class.R | 15 ++- R/utils.R | 4 + man/new_class.Rd | 3 +- man/new_external_class.Rd | 13 ++- tests/testthat/_snaps/constructor.md | 10 ++ tests/testthat/_snaps/external-class.md | 9 ++ tests/testthat/test-constructor.R | 72 +++++++++++++ tests/testthat/test-external-class.R | 58 +++++++++++ vignettes/classes-objects.Rmd | 12 ++- 13 files changed, 333 insertions(+), 17 deletions(-) diff --git a/NAMESPACE b/NAMESPACE index 713dcf051..bb00c7908 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -17,6 +17,7 @@ S3method(print,S7_S3_class) S3method(print,S7_any) S3method(print,S7_base_class) S3method(print,S7_class) +S3method(print,S7_constructor) S3method(print,S7_external_class) S3method(print,S7_external_generic) S3method(print,S7_generic) @@ -32,6 +33,7 @@ S3method(str,S7_S3_class) S3method(str,S7_any) S3method(str,S7_base_class) S3method(str,S7_class) +S3method(str,S7_constructor) S3method(str,S7_missing) S3method(str,S7_object) S3method(str,S7_property) diff --git a/NEWS.md b/NEWS.md index 6c34bdccb..2e59ca828 100644 --- a/NEWS.md +++ b/NEWS.md @@ -23,8 +23,9 @@ * `new_class()` now errors if a child class overrides a parent property with a type that doesn't extend the parent's type, since such a class could never be instantiated. Narrowing the type is still allowed, as are dynamic (getter) properties (#352). * `new_class()` now allows properties named `names`, `dim`, `dimnames`, `class`, `comment`, `tsp`, and `row.names`. But property names beginning with `_` are now reserved for internal use (#579). * `new_class()` experimentally allows `class_environment` as a parent again, so you can build S7 objects that share R's reference semantics for environments. This support is provisional: because environments are mutated in place, some operations behave differently than for value-typed S7 objects, and the API may change. `S7_data()` and `S7_data<-()` error on environment-based objects, since they would otherwise destroy the object's S7 attributes in place (#590). +* `new_class()` generates a working default constructor for a subclass of a class with a custom constructor: the subclass takes `...` and forwards it to the parent constructor (followed by a named argument for each property the subclass adds), so the parent's argument defaults are matched and evaluated by the parent itself. This is a breaking change: such a subclass constructor no longer exposes the parent's properties as named or positional arguments, only via `...` (#609, #317). * `new_class()`'s default constructor now respects properties overridden in a subclass: the subclass's default is used (#467) and its setter is run during construction (#585). Values for overridden properties are passed to both the parent constructor and the new object, so a subclass can override a parent property whose default is mandatory. -* `new_external_class()` creates a delayed reference to an S7 class in another package (or your own package, but not yet defined). It is useful for registering methods on classes from suggested packages (#573) and for creating self-referential or mutually recursive classes (#250). +* `new_external_class()` creates a delayed reference to an S7 class in another package (or your own package, but not yet defined). It is useful for registering methods on classes from suggested packages (#573), for creating self-referential or mutually recursive classes (#250), and for extending class from other packages (#317). * `new_object()` now gives an informative error when `.parent` is a class specification rather than an instance of the parent class (#409). * `new_object()` no longer materialises ALTREP parent values (e.g. `seq_len()`), so constructing an S7 object that wraps a large compact integer sequence is now O(1) in memory instead of O(n) (@kschaubroeck, #607). * `new_object()` no longer re-runs property validators for properties inherited unchanged from an already-validated parent class, so constructing an instance of a deeply nested class hierarchy validates each property exactly once (#539). diff --git a/R/class.R b/R/class.R index 4cbf99bf0..a19cf5915 100644 --- a/R/class.R +++ b/R/class.R @@ -15,11 +15,12 @@ #' `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 three options: +#' There are four options: #' #' * An S7 class, like [S7_object]. #' * An S3 class wrapped by [new_S3_class()]. #' * A base type, like [class_logical], [class_integer], etc. +#' * A class from another package, wrapped by [new_external_class()]. #' @param package Package name. This is automatically resolved if the class is #' defined in a package, and `NULL` otherwise. #' @@ -111,6 +112,15 @@ new_class <- function( parent <- as_class(parent) + # We have to resolve at build-time to validate the properties we know. + # But we otherwise avoid embedding the resolved parent because its definition + # may have changed in between package build time and run time. + if (is_external_class(parent)) { + parent_resolved <- resolve_external_class_req(parent, package) + } else { + parent_resolved <- parent + } + # Don't check arguments for S7_object if (!is.null(parent)) { check_can_inherit(parent) @@ -125,14 +135,15 @@ new_class <- function( } if ( abstract && - (!is_class(parent) || !(parent@abstract || parent@name == "S7_object")) + (!is_class(parent_resolved) || + !(parent_resolved@abstract || parent_resolved@name == "S7_object")) ) { stop2("Abstract classes must have abstract parents.") } } # Combine properties from parent, overriding as needed - parent_props <- attr(parent, "properties", exact = TRUE) %||% list() + parent_props <- attr(parent_resolved, "properties", exact = TRUE) %||% list() new_props <- as_properties(properties) check_prop_names(new_props) check_prop_overrides(new_props, parent_props, name, parent) @@ -249,7 +260,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_external_class(x) +} check_can_inherit <- function( x, diff --git a/R/constructor.R b/R/constructor.R index 528ae3712..939d58693 100644 --- a/R/constructor.R +++ b/R/constructor.R @@ -24,7 +24,7 @@ new_constructor <- function( bquote(S7::new_object(S7::S7_object(), ..(self_args)), splice = TRUE) } - return(new_function( + return(new_S7_constructor( args = arg_info$self, body = as.call(c( quote(`{`), @@ -37,6 +37,39 @@ new_constructor <- function( )) } + # Prefer to inline properties to give better constructor formals, but + # that's not always safe + if (can_inline(parent)) { + constructor_inline(parent, properties, envir, package) + } else { + constructor_forward(parent, properties, envir, package) + } +} + + +can_inline <- function(parent) { + if (is_external_class(parent)) { + FALSE + } else if (is_class(parent)) { + # can't inline custom constructors (#609) + inherits(parent@constructor, "S7_constructor") + } else if (is_S3_class(parent)) { + ctor <- parent$constructor + if (is_S3_stub_constructor(ctor)) { + return(TRUE) + } + # S7's own base/S3 wrappers (e.g. class_factor) define their constructors in + # the S7 namespace and are safe to inline; a user `new_S3_class()` wrapper + # carries the user's environment and must forward. + env <- environment(ctor) + identical(env, baseenv()) || identical(env, asNamespace("S7")) + } else { + TRUE + } +} + + +constructor_inline <- function(parent, properties, envir, package) { # 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)) { @@ -94,7 +127,77 @@ new_constructor <- function( # And finally the constructor itself env <- new.env(parent = envir) env[[parent_name]] <- parent_fun - new_function(constr_args[constr_nms], child_call, env) + new_S7_constructor(constr_args[constr_nms], child_call, env) +} + +# The forwarding constructor: the child takes `...` and hands it to the parent +# constructor, so the parent's arguments (and their defaults) are matched and +# evaluated by the parent itself. Only the child's own properties become named +# arguments, listed after `...`. +constructor_forward <- function(parent, properties, envir, package) { + # Work out how to refer to and call the parent's constructor: + # * `ref`: passed to `new_call()` to build the parent call (a name, or a + # `package`/`name` pair for an external class in another package). + # * `name`/`fun`: the constructor to embed in the child's environment (NULL + # for external classes, which are resolved dynamically via `pkg::name`). + if (is_external_class(parent)) { + resolved <- resolve_external_class_req(parent, package) + ref <- if (identical(package, parent$package)) { + parent$name + } else { + c(parent$package, parent$name) + } + name <- NULL + fun <- NULL + parent_props <- attr(resolved, "properties", exact = TRUE) %||% list() + parent_formal_nms <- names(formals(resolved)) + } else if (is_class(parent)) { + ref <- name <- parent@name + fun <- parent + parent_props <- attr(parent, "properties", exact = TRUE) %||% list() + parent_formal_nms <- names(formals(parent)) + } else if (is_S3_class(parent)) { + ref <- name <- paste0("new_", parent$class[[1]]) + fun <- parent$constructor + parent_props <- attr(parent, "properties", exact = TRUE) %||% list() + parent_formal_nms <- names(formals(fun)) + } else { + # user facing error in S7_class() + stop2("Unsupported `parent` type.", call = NULL) + } + + # New (non read-only) properties become name-only arguments after `...`. + self_props <- properties[!vlapply(properties, prop_is_read_only)] + self_nms <- names(self_props) + self_args <- as.pairlist(lapply( + setNames(, self_nms), + function(name) prop_default(self_props[[name]], envir, package) + )) + + # Overridden parent properties are passed to *both* the parent (so the child + # default wins over the parent default) and new_object() (so the child setter + # runs). An override is only forwarded to the parent if it can accept it. + override_nms <- intersect(self_nms, names(parent_props)) + parent_override_nms <- if ("..." %in% parent_formal_nms) { + override_nms + } else { + intersect(override_nms, parent_formal_nms) + } + + # Parent(, ...) + parent_call <- new_call(ref, as_names(c(parent_override_nms, "..."))) + + new_object <- c(if (!has_S7_symbols(envir, "new_object")) "S7", "new_object") + child_call <- new_call(new_object, c(list(parent_call), as_names(self_nms))) + + # `...` must come first, followed by the child's own properties. + constr_args <- as.pairlist(c(alist(... = ), self_args)) + + env <- new.env(parent = envir) + if (!is.null(name)) { + env[[name]] <- fun + } + new_S7_constructor(constr_args, child_call, env) } constructor_args <- function( @@ -118,6 +221,27 @@ constructor_args <- function( # helpers ----------------------------------------------------------------- +new_S7_constructor <- function( + args = NULL, + body = NULL, + env = asNamespace("S7") +) { + f <- new_function(args, body, env) + class(f) <- "S7_constructor" + f +} + +#' @export +print.S7_constructor <- function(x, ...) { + print(unclass(x), ...) + invisible(x) +} + +#' @export +str.S7_constructor <- function(object, ...) { + str(unclass(object), ...) +} + is_property_dynamic <- function(x) is.function(x$getter) missing_args <- function(names) { diff --git a/R/external-class.R b/R/external-class.R index 97c81bf72..411a66150 100644 --- a/R/external-class.R +++ b/R/external-class.R @@ -6,7 +6,7 @@ #' defined). It carries only the package and class name, and is resolved to #' the real S7 class when needed. #' -#' External classes are useful in two situations: +#' External classes are useful in three situations: #' #' * To register a method for a generic in your package, dispatching on a class #' from a soft dependency. The method will be registered when `pkg` is loaded @@ -25,12 +25,19 @@ #' new_class("tree", properties = list(child = NULL | tree_stub)) #' ``` #' +#' * To use a class from another package as the `parent` of your own class. +#' The parent's properties are captured when your class is defined, but its +#' constructor is called at run time, so your subclass always builds on the +#' installed version of the parent package. +#' +#' ```R +#' TheirClass <- new_external_class("theirpkg", "TheirClass") +#' new_class("MyClass", parent = TheirClass) +#' ``` +#' #' Make sure to call [S7_on_load()] in your package's `.onLoad()` so that #' deferred method registrations fire when the relevant package is loaded. #' -#' External classes can not currently be used as parents in [new_class()]. -#' We hope to relax that restriction in the near future. -#' #' @param package Package the class is defined in. #' @param name Name of the class, as a string. #' @inheritParams new_external_generic version diff --git a/R/utils.R b/R/utils.R index cab73e2a1..899692aea 100644 --- a/R/utils.R +++ b/R/utils.R @@ -136,6 +136,10 @@ str_nest <- function( str_function <- function(object, ..., nest.lev = 0) { attr(object, "srcref") <- NULL + # Display S7-generated constructors like any other function + if (inherits(object, "S7_constructor")) { + class(object) <- NULL + } if (identical(class(object), "function")) { cat(" ") } diff --git a/man/new_class.Rd b/man/new_class.Rd index b5a3251bc..f94b09493 100644 --- a/man/new_class.Rd +++ b/man/new_class.Rd @@ -27,11 +27,12 @@ with this name, i.e. \code{Foo <- new_class("Foo", ...)} or 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 S3 class wrapped by \code{\link[=new_S3_class]{new_S3_class()}}. \item A base type, like \link{class_logical}, \link{class_integer}, etc. +\item A class from another package, wrapped by \code{\link[=new_external_class]{new_external_class()}}. }} \item{package}{Package name. This is automatically resolved if the class is diff --git a/man/new_external_class.Rd b/man/new_external_class.Rd index 3a05f3f9f..5d5b63766 100644 --- a/man/new_external_class.Rd +++ b/man/new_external_class.Rd @@ -23,7 +23,7 @@ another package (or in your own package and needed before it's fully defined). It carries only the package and class name, and is resolved to the real S7 class when needed. -External classes are useful in two situations: +External classes are useful in three situations: \itemize{ \item To register a method for a generic in your package, dispatching on a class from a soft dependency. The method will be registered when \code{pkg} is loaded @@ -38,13 +38,18 @@ self-referential or mutually recursive class. \if{html}{\out{
}}\preformatted{tree_stub <- new_external_class("mypkg", "tree") new_class("tree", properties = list(child = NULL | tree_stub)) }\if{html}{\out{
}} +\item To use a class from another package as the \code{parent} of your own class. +The parent's properties are captured when your class is defined, but its +constructor is called at run time, so your subclass always builds on the +installed version of the parent package. + +\if{html}{\out{
}}\preformatted{TheirClass <- new_external_class("theirpkg", "TheirClass") +new_class("MyClass", parent = TheirClass) +}\if{html}{\out{
}} } Make sure to call \code{\link[=S7_on_load]{S7_on_load()}} in your package's \code{.onLoad()} so that deferred method registrations fire when the relevant package is loaded. - -External classes can not currently be used as parents in \code{\link[=new_class]{new_class()}}. -We hope to relax that restriction in the near future. } \examples{ # Refer to an S7 class in another package without taking a hard dependency: diff --git a/tests/testthat/_snaps/constructor.md b/tests/testthat/_snaps/constructor.md index 3ac909fde..2a5ab9a31 100644 --- a/tests/testthat/_snaps/constructor.md +++ b/tests/testthat/_snaps/constructor.md @@ -81,3 +81,13 @@ new_object(foo(...), y = y) +# forwarding constructor passes overrides to both parent and object + + Code + new_constructor(P, as_properties(list(a = new_property(class_double, default = 99), + b = class_double))) + Output + function (..., a = 99, b = numeric(0)) + new_object(P(a = a, ...), a = a, b = b) + + diff --git a/tests/testthat/_snaps/external-class.md b/tests/testthat/_snaps/external-class.md index 0204cee67..469882b47 100644 --- a/tests/testthat/_snaps/external-class.md +++ b/tests/testthat/_snaps/external-class.md @@ -60,3 +60,12 @@ ! object properties are invalid: - @child: x must be non-negative +# subclassing errors when the external parent can't be resolved + + Code + new_class(name = "Dog", parent = Animal) + Condition + Error: + ! Can't find external class : + * Package 'dep' needs version 2.0.0, but only 1.0.0 is available. + diff --git a/tests/testthat/test-constructor.R b/tests/testthat/test-constructor.R index 5f1ae8692..28ba498c7 100644 --- a/tests/testthat/test-constructor.R +++ b/tests/testthat/test-constructor.R @@ -120,6 +120,78 @@ test_that("can use `...` in parent constructor", { expect_equal(bar(y = 2)@x, list()) }) +test_that("subclass forwards `...` to a custom parent constructor (#609)", { + # The parent default references a symbol from the parent's own environment, + # which the child can't see -- so it must be evaluated by the parent. + make_parent <- function() { + secret <- 42L + new_class( + name = "Parent", + package = NULL, + properties = list(x = class_integer), + constructor = function(x = secret) new_object(S7_object(), x = x) + ) + } + Parent <- make_parent() + Child := new_class( + parent = Parent, + package = NULL, + properties = list(y = class_double) + ) + + expect_named(formals(Child), c("...", "y")) + expect_equal(Child()@x, 42L) # parent default resolved in the parent's env + expect_equal(Child(10L)@x, 10L) # positional arg forwarded to the parent + expect_equal(Child(y = 2)@y, 2) # named child arg is not forwarded +}) + +test_that("subclass of a custom S3 parent forwards `...`", { + new_rle <- function(.data = list(), n = integer()) { + structure(.data, n = n, class = "rle2") + } + rle2 <- new_S3_class("rle2", constructor = new_rle) + + Child := new_class( + parent = rle2, + package = NULL, + properties = list(z = class_double) + ) + + expect_named(formals(Child), c("...", "z")) + expect_equal(Child(z = 1)@z, 1) + + # S7's own S3 wrappers stay on the inline path + Factor := new_class(parent = class_factor, package = NULL) + expect_named(formals(Factor), c(".data", "levels")) +}) + +test_that("forwarding constructor passes overrides to both parent and object", { + P := new_class( + package = NULL, + properties = list(a = new_property(class_double, default = 1)), + constructor = function(a = 1) new_object(S7_object(), a = a) + ) + + expect_snapshot( + new_constructor( + P, + as_properties(list( + a = new_property(class_double, default = 99), + b = class_double + )) + ), + transform = scrub_environment + ) + + C := new_class( + parent = P, + package = NULL, + properties = list(a = new_property(class_double, default = 99)) + ) + expect_equal(C()@a, 99) # child default wins over parent default + expect_equal(C(a = 5)@a, 5) +}) + test_that("subclass can override simple parent property defaults", { foo := new_class( properties = list(x = new_property(class_numeric, default = 1)) diff --git a/tests/testthat/test-external-class.R b/tests/testthat/test-external-class.R index 56f64051d..255ae8a91 100644 --- a/tests/testthat/test-external-class.R +++ b/tests/testthat/test-external-class.R @@ -121,3 +121,61 @@ test_that("external class property validation reports validator errors", { expect_snapshot(Holder(child = invalid), error = TRUE) }) + +test_that("an external class can be used as a parent (#317)", { + dep := local_package({ + Animal := new_class( + properties = list(name = class_character, legs = class_integer) + ) + }) + + Animal := new_external_class(package = "dep") + Dog := new_class( + parent = Animal, + properties = list(breed = class_character) + ) + # parent properties are captured statically; construction forwards `...` + expect_named(Dog@properties, c("name", "legs", "breed")) + expect_named(formals(Dog), c("...", "breed")) + + d <- Dog(name = "Rex", legs = 4L, breed = "lab") + expect_equal(d@name, "Rex") + expect_equal(d@legs, 4L) + expect_equal(d@breed, "lab") + expect_s3_class(d, "dep::Animal") + expect_true(S7_inherits(d, Animal)) +}) + +test_that("subclass constructs against the parent's run-time definition (#317)", { + dep := local_package({ + Animal := new_class( + properties = list(legs = new_property(class_integer, default = 4L)) + ) + }) + Animal := new_external_class(package = "dep") + + Dog := new_class( + parent = Animal, + properties = list(breed = class_character) + ) + expect_equal(Dog()@legs, 4L) + + # The parent package changes the default and is reloaded; the subclass is + # *not* rebuilt, yet its constructor picks up the new definition. + dep$Animal <- new_class( + name = "Animal", + package = "dep", + properties = list(legs = new_property(class_integer, default = 6L)) + ) + expect_equal(Dog()@legs, 6L) + # explicit values are still forwarded to the parent + expect_equal(Dog(legs = 2L, breed = "x")@legs, 2L) +}) + +test_that("subclassing errors when the external parent can't be resolved", { + dep := local_package(version = "1.0.0", { + Animal := new_class() + }) + Animal := new_external_class(package = "dep", version = "2.0.0") + expect_snapshot(new_class(name = "Dog", parent = Animal), error = TRUE) +}) diff --git a/vignettes/classes-objects.Rmd b/vignettes/classes-objects.Rmd index de983214e..ed044ccef 100644 --- a/vignettes/classes-objects.Rmd +++ b/vignettes/classes-objects.Rmd @@ -410,4 +410,14 @@ A constructor must always end with a call to `new_object()`. The first argument to `new_object()` should be an object of the `parent` class (if you haven't specified a `parent` argument to `new_class()`, then you should use `S7_object()` as the parent here). That argument should be followed by one named argument for each property. -There's one drawback of custom constructors that you should be aware of: any subclass will also require a custom constructor. +A subclass of a class with a custom constructor doesn't need its own custom constructor. +Its default constructor takes `...` and forwards it to the parent constructor, followed by one named argument for each property the subclass adds: + +```{r} +PositiveRange := new_class( + parent = Range, + properties = list(positive = class_logical) +) +# `...` is forwarded to Range()'s custom constructor +PositiveRange(c(10, 5, 0, 2, 5, 7), positive = TRUE) +``` From 8fd0969013ad278dc23be4e8e18bda9f06b21653 Mon Sep 17 00:00:00 2001 From: Hadley Wickham Date: Wed, 24 Jun 2026 09:25:51 -0500 Subject: [PATCH 2/5] Rename so collates first --- R/{aaa.R => AAA.R} | 0 1 file changed, 0 insertions(+), 0 deletions(-) rename R/{aaa.R => AAA.R} (100%) diff --git a/R/aaa.R b/R/AAA.R similarity index 100% rename from R/aaa.R rename to R/AAA.R From bb9a0be5fb6d9635a964f4bb9abb2ce1f2a98c0c Mon Sep 17 00:00:00 2001 From: Hadley Wickham Date: Wed, 24 Jun 2026 09:27:23 -0500 Subject: [PATCH 3/5] Consistent constructor labelling --- R/AAA.R | 9 +++++++ R/S3.R | 62 ++++++++++++++++++++----------------------------- R/class.R | 2 +- R/constructor.R | 50 ++++++++++++++++++--------------------- 4 files changed, 57 insertions(+), 66 deletions(-) diff --git a/R/AAA.R b/R/AAA.R index 3f89137ab..f47e0c60b 100644 --- a/R/AAA.R +++ b/R/AAA.R @@ -4,6 +4,15 @@ new_function <- function(args = NULL, body = NULL, env = asNamespace("S7")) { as.function.default(c(args, body) %||% list(NULL), env) } +# Tag a function as an S7-generated constructor (vs a user-supplied one), so +# `is_default_constructor()` can tell them apart, and re-home it (by default in +# the S7 namespace). Defined here because the base S3 wrappers in S3.R need it +# at load time. +new_S7_constructor <- function(f, env = asNamespace("S7")) { + environment(f) <- env + class(f) <- "S7_constructor" + f +} `append<-` <- function(x, after, value) { if (missing(after)) { diff --git a/R/S3.R b/R/S3.R index 5a941b7a1..b5680de9d 100644 --- a/R/S3.R +++ b/R/S3.R @@ -97,12 +97,13 @@ new_S3_class <- function(class, constructor = NULL, validator = NULL) { check_S3_constructor(constructor) } else { abstract <- TRUE - constructor <- function(.data) { - stop2( - sprintf("S3 class <%s> doesn't have a constructor.", class[[1]]), + constructor <- new_S7_constructor(new_function( + args = alist(.data = ), + body = bquote(stop2( + sprintf("S3 class <%s> doesn't have a constructor.", .(class[[1]])), call = NULL - ) - } + )) + )) } out <- list( @@ -147,21 +148,6 @@ is_S3_class <- function(x) { inherits(x, "S7_S3_class") } -# Detect the stub constructor that `new_S3_class()` inserts when no constructor -# is supplied. Needed as a fallback for `S7_S3_class` objects created by older -# versions of S7. -is_S3_stub_constructor <- function(constructor) { - if (!is.function(constructor)) { - return(FALSE) - } - call <- find_call(body(constructor), quote(sprintf)) - if (is.null(call)) { - return(FALSE) - } - fmt <- call[[2]] - is.character(fmt) && grepl("doesn't have a constructor", fmt, fixed = TRUE) -} - # ------------------------------------------------------------------------- # Pull out validation functions so hit by code coverage @@ -324,10 +310,10 @@ validate_formula <- function(self) { #' @order 3 class_factor <- new_S3_class( "factor", - constructor = function(.data = integer(), levels = NULL) { + constructor = new_S7_constructor(function(.data = integer(), levels = NULL) { levels <- levels %||% attr(.data, "levels", TRUE) %||% character() structure(.data, levels = levels, class = "factor") - }, + }), validator = validate_factor ) @@ -337,9 +323,9 @@ class_factor <- new_S3_class( #' @order 3 class_Date <- new_S3_class( "Date", - constructor = function(.data = double()) { + constructor = new_S7_constructor(function(.data = double()) { .Date(.data) - }, + }), validator = validate_date ) @@ -349,9 +335,9 @@ class_Date <- new_S3_class( #' @order 3 class_POSIXct <- new_S3_class( c("POSIXct", "POSIXt"), - constructor = function(.data = double(), tz = "") { + constructor = new_S7_constructor(function(.data = double(), tz = "") { .POSIXct(.data, tz = tz) - }, + }), validator = validate_POSIXct ) @@ -361,9 +347,9 @@ class_POSIXct <- new_S3_class( #' @order 3 class_POSIXlt <- new_S3_class( c("POSIXlt", "POSIXt"), - constructor = function(.data = NULL, tz = "") { + constructor = new_S7_constructor(function(.data = NULL, tz = "") { as.POSIXlt(.data, tz = tz) - }, + }), validator = validate_POSIXlt ) @@ -379,7 +365,7 @@ class_POSIXt <- new_S3_class("POSIXt") # abstract class #' @order 3 class_data.frame <- new_S3_class( "data.frame", - constructor = function(.data = list(), row.names = NULL) { + constructor = new_S7_constructor(function(.data = list(), row.names = NULL) { if (is.null(row.names)) { list2DF(.data) } else { @@ -387,7 +373,7 @@ class_data.frame <- new_S3_class( attr(out, "row.names") <- row.names out } - }, + }), validator = validate_data.frame ) @@ -397,7 +383,7 @@ class_data.frame <- new_S3_class( # @order 3 class_matrix <- new_S3_class( "matrix", - constructor = function( + constructor = new_S7_constructor(function( .data = logical(), nrow = NULL, ncol = NULL, @@ -412,7 +398,7 @@ class_matrix <- new_S3_class( } } matrix(.data, nrow, ncol, byrow, dimnames) - }, + }), validator = validate_matrix ) @@ -422,13 +408,13 @@ class_matrix <- new_S3_class( # @order 3 class_array <- new_S3_class( "array", - constructor = function( + constructor = new_S7_constructor(function( .data = logical(), dim = base::dim(.data) %||% length(.data), dimnames = base::dimnames(.data) ) { array(.data, dim, dimnames) - }, + }), validator = validate_array ) @@ -438,8 +424,10 @@ class_array <- new_S3_class( #' @order 3 class_formula <- new_S3_class( "formula", - constructor = function(.data = NULL, env = parent.frame()) { - stats::formula(.data, env = env) - }, + constructor = new_S7_constructor( + function(.data = NULL, env = parent.frame()) { + stats::formula(.data, env = env) + } + ), validator = validate_formula ) diff --git a/R/class.R b/R/class.R index a19cf5915..b94e384df 100644 --- a/R/class.R +++ b/R/class.R @@ -287,7 +287,7 @@ 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) + class$abstract %||% is_default_constructor(class$constructor) } else { FALSE } diff --git a/R/constructor.R b/R/constructor.R index 939d58693..9e8602530 100644 --- a/R/constructor.R +++ b/R/constructor.R @@ -25,14 +25,16 @@ new_constructor <- function( } return(new_S7_constructor( - args = arg_info$self, - body = as.call(c( - quote(`{`), - # Force all promises here so that any errors are signaled from - # the constructor() call instead of the new_object() call. - unname(self_args), - new_object_call - )), + new_function( + args = arg_info$self, + body = as.call(c( + quote(`{`), + # Force all promises here so that any errors are signaled from + # the constructor() call instead of the new_object() call. + unname(self_args), + new_object_call + )) + ), env = envir )) } @@ -52,17 +54,12 @@ can_inline <- function(parent) { FALSE } else if (is_class(parent)) { # can't inline custom constructors (#609) - inherits(parent@constructor, "S7_constructor") + is_default_constructor(parent@constructor) } else if (is_S3_class(parent)) { - ctor <- parent$constructor - if (is_S3_stub_constructor(ctor)) { - return(TRUE) - } - # S7's own base/S3 wrappers (e.g. class_factor) define their constructors in - # the S7 namespace and are safe to inline; a user `new_S3_class()` wrapper - # carries the user's environment and must forward. - env <- environment(ctor) - identical(env, baseenv()) || identical(env, asNamespace("S7")) + # S7's own base/S3 wrappers (e.g. class_factor) and the stub are inlinable; + # a user `new_S3_class(constructor = )` carries the user's environment and + # must forward (#609) + is_default_constructor(parent$constructor) } else { TRUE } @@ -127,7 +124,10 @@ constructor_inline <- function(parent, properties, envir, package) { # And finally the constructor itself env <- new.env(parent = envir) env[[parent_name]] <- parent_fun - new_S7_constructor(constr_args[constr_nms], child_call, env) + new_S7_constructor( + new_function(constr_args[constr_nms], child_call), + env = env + ) } # The forwarding constructor: the child takes `...` and hands it to the parent @@ -197,7 +197,7 @@ constructor_forward <- function(parent, properties, envir, package) { if (!is.null(name)) { env[[name]] <- fun } - new_S7_constructor(constr_args, child_call, env) + new_S7_constructor(new_function(constr_args, child_call), env = env) } constructor_args <- function( @@ -221,14 +221,8 @@ constructor_args <- function( # helpers ----------------------------------------------------------------- -new_S7_constructor <- function( - args = NULL, - body = NULL, - env = asNamespace("S7") -) { - f <- new_function(args, body, env) - class(f) <- "S7_constructor" - f +is_default_constructor <- function(constructor) { + inherits(constructor, "S7_constructor") } #' @export From e2aba4526019a482adbf72ac4634a79250eb83d3 Mon Sep 17 00:00:00 2001 From: Hadley Wickham Date: Wed, 24 Jun 2026 09:29:52 -0500 Subject: [PATCH 4/5] Style --- R/constructor.R | 18 +++++++----------- 1 file changed, 7 insertions(+), 11 deletions(-) diff --git a/R/constructor.R b/R/constructor.R index 9e8602530..9180755e1 100644 --- a/R/constructor.R +++ b/R/constructor.R @@ -48,24 +48,20 @@ new_constructor <- function( } } - can_inline <- function(parent) { if (is_external_class(parent)) { + # can't inline constructors from external classes FALSE } else if (is_class(parent)) { # can't inline custom constructors (#609) is_default_constructor(parent@constructor) } else if (is_S3_class(parent)) { - # S7's own base/S3 wrappers (e.g. class_factor) and the stub are inlinable; - # a user `new_S3_class(constructor = )` carries the user's environment and - # must forward (#609) is_default_constructor(parent$constructor) } else { TRUE } } - constructor_inline <- function(parent, properties, envir, package) { # We need a name so we get a compact constructor, and the actual function # which we'll embed in the constructor's environment @@ -142,10 +138,10 @@ constructor_forward <- function(parent, properties, envir, package) { # for external classes, which are resolved dynamically via `pkg::name`). if (is_external_class(parent)) { resolved <- resolve_external_class_req(parent, package) - ref <- if (identical(package, parent$package)) { - parent$name + if (identical(package, parent$package)) { + ref <- parent$name } else { - c(parent$package, parent$name) + ref <- c(parent$package, parent$name) } name <- NULL fun <- NULL @@ -178,10 +174,10 @@ constructor_forward <- function(parent, properties, envir, package) { # default wins over the parent default) and new_object() (so the child setter # runs). An override is only forwarded to the parent if it can accept it. override_nms <- intersect(self_nms, names(parent_props)) - parent_override_nms <- if ("..." %in% parent_formal_nms) { - override_nms + if ("..." %in% parent_formal_nms) { + parent_override_nms <- override_nms } else { - intersect(override_nms, parent_formal_nms) + parent_override_nms <- intersect(override_nms, parent_formal_nms) } # Parent(, ...) From ba6c04d169fe2ba7fbd7d0097d6f2c019e0f5ed8 Mon Sep 17 00:00:00 2001 From: Hadley Wickham Date: Wed, 24 Jun 2026 10:05:58 -0500 Subject: [PATCH 5/5] Simplifying --- R/constructor.R | 5 ----- tests/testthat/test-constructor.R | 26 ++++++++++---------------- 2 files changed, 10 insertions(+), 21 deletions(-) diff --git a/R/constructor.R b/R/constructor.R index 9180755e1..687f5366d 100644 --- a/R/constructor.R +++ b/R/constructor.R @@ -107,11 +107,6 @@ constructor_inline <- function(parent, properties, envir, package) { constr_nms <- setdiff(constr_nms, read_only_override_nms) override_nms <- setdiff(override_nms, read_only_override_nms) - # If parent takes ..., we can't match overrides by name, so pass all args on - if ("..." %in% names(arg_info$parent)) { - parent_nms <- union(parent_nms, override_nms) - } - # Now we can generate the parent and child calls parent_call <- new_call(parent_name, as_names(parent_nms)) new_object <- c(if (!has_S7_symbols(envir, "new_object")) "S7", "new_object") diff --git a/tests/testthat/test-constructor.R b/tests/testthat/test-constructor.R index 28ba498c7..5a82e7e0c 100644 --- a/tests/testthat/test-constructor.R +++ b/tests/testthat/test-constructor.R @@ -123,45 +123,39 @@ test_that("can use `...` in parent constructor", { test_that("subclass forwards `...` to a custom parent constructor (#609)", { # The parent default references a symbol from the parent's own environment, # which the child can't see -- so it must be evaluated by the parent. - make_parent <- function() { + Parent <- local({ secret <- 42L new_class( name = "Parent", - package = NULL, properties = list(x = class_integer), constructor = function(x = secret) new_object(S7_object(), x = x) ) - } - Parent <- make_parent() + }) Child := new_class( parent = Parent, - package = NULL, properties = list(y = class_double) ) expect_named(formals(Child), c("...", "y")) - expect_equal(Child()@x, 42L) # parent default resolved in the parent's env + expect_equal(Child()@x, 42L) expect_equal(Child(10L)@x, 10L) # positional arg forwarded to the parent expect_equal(Child(y = 2)@y, 2) # named child arg is not forwarded }) test_that("subclass of a custom S3 parent forwards `...`", { - new_rle <- function(.data = list(), n = integer()) { - structure(.data, n = n, class = "rle2") - } - rle2 <- new_S3_class("rle2", constructor = new_rle) - - Child := new_class( - parent = rle2, - package = NULL, - properties = list(z = class_double) + rle2 <- new_S3_class( + "rle2", + constructor = function(.data = list(), n = integer()) { + structure(.data, n = n, class = "rle2") + } ) + Child := new_class(parent = rle2, properties = list(z = class_double)) expect_named(formals(Child), c("...", "z")) expect_equal(Child(z = 1)@z, 1) # S7's own S3 wrappers stay on the inline path - Factor := new_class(parent = class_factor, package = NULL) + Factor := new_class(parent = class_factor) expect_named(formals(Factor), c(".data", "levels")) })