diff --git a/NEWS.md b/NEWS.md index 2e92eccd..dbf2ef0f 100644 --- a/NEWS.md +++ b/NEWS.md @@ -25,8 +25,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/AAA.R b/R/AAA.R index 5148c3a1..f47e0c60 100644 --- a/R/AAA.R +++ b/R/AAA.R @@ -14,7 +14,6 @@ new_S7_constructor <- function(f, env = asNamespace("S7")) { f } - `append<-` <- function(x, after, value) { if (missing(after)) { c(x, value) diff --git a/R/class.R b/R/class.R index ca1640f1..8df70979 100644 --- a/R/class.R +++ b/R/class.R @@ -21,6 +21,7 @@ #' * 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. +#' * 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. #' @@ -123,6 +124,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) @@ -137,15 +147,15 @@ new_class <- function( } if ( abstract && - !((is_class(parent) && - (parent@abstract || parent@name == "S7_object")) || - (is_S4_class(parent) && parent@virtual)) + !((is_class(parent_resolved) && + (parent_resolved@abstract || parent_resolved@name == "S7_object")) || + (is_S4_class(parent_resolved) && parent_resolved@virtual)) ) { stop2("Abstract classes must have abstract parents.") } } - parent_props <- class_properties(parent) + parent_props <- class_properties(parent_resolved) new_props <- as_properties(properties) check_prop_names(new_props) check_prop_overrides(new_props, parent_props, name, parent) @@ -272,7 +282,11 @@ c.S7_class <- function(...) { } can_inherit <- function(x) { - is_base_class(x) || is_S3_class(x) || is_class(x) || is_S4_class(x) + is_base_class(x) || + is_S3_class(x) || + is_class(x) || + is_S4_class(x) || + is_external_class(x) } check_can_inherit <- function( diff --git a/R/constructor.R b/R/constructor.R index 50d48b3b..a1823276 100644 --- a/R/constructor.R +++ b/R/constructor.R @@ -53,6 +53,30 @@ 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)) { + # 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)) { + 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 if (is_class(parent)) { @@ -97,11 +121,6 @@ new_constructor <- function( 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") @@ -116,6 +135,76 @@ new_constructor <- function( ) } +# 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) + if (identical(package, parent$package)) { + ref <- parent$name + } else { + ref <- 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)) + if ("..." %in% parent_formal_nms) { + parent_override_nms <- override_nms + } else { + parent_override_nms <- 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(new_function(constr_args, child_call), env = env) +} + constructor_args <- function( parent, properties = list(), diff --git a/R/external-class.R b/R/external-class.R index 97c81bf7..411a6615 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/man/new_class.Rd b/man/new_class.Rd index 304cbda7..ecb7b018 100644 --- a/man/new_class.Rd +++ b/man/new_class.Rd @@ -33,6 +33,7 @@ There are four options: \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. +\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 3a05f3f9..5d5b6376 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/class.md b/tests/testthat/_snaps/class.md index 2879f3b7..83e411ca 100644 --- a/tests/testthat/_snaps/class.md +++ b/tests/testthat/_snaps/class.md @@ -304,3 +304,4 @@ Condition Error: ! No S7 class for base type . + diff --git a/tests/testthat/_snaps/constructor.md b/tests/testthat/_snaps/constructor.md index 3ac909fd..2a5ab9a3 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 0204cee6..469882b4 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 5f1ae869..5a82e7e0 100644 --- a/tests/testthat/test-constructor.R +++ b/tests/testthat/test-constructor.R @@ -120,6 +120,72 @@ 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. + Parent <- local({ + secret <- 42L + new_class( + name = "Parent", + properties = list(x = class_integer), + constructor = function(x = secret) new_object(S7_object(), x = x) + ) + }) + Child := new_class( + parent = Parent, + properties = list(y = class_double) + ) + + expect_named(formals(Child), c("...", "y")) + 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 `...`", { + 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) + 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 56f64051..255ae8a9 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 de983214..ed044cce 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) +```