diff --git a/NEWS.md b/NEWS.md index 03ace2a7..ee6f4722 100644 --- a/NEWS.md +++ b/NEWS.md @@ -18,7 +18,7 @@ * `method<-` can now register methods on S3 and S4 generics with base types (e.g. `class_character`), S3 classes (`new_S3_class()`, `class_factor`, etc.), S7 unions (expanded to one registration per class), `class_any` (registered as the `default` method), and `NULL` (registered as the `NULL` method) (#455). * `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_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 subclassing a class from a soft dependency (the parent is only resolved when an object is constructed, so your package builds and loads even if the parent's package is absent). * `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 7bfa02c1..df5a8afa 100644 --- a/R/class.R +++ b/R/class.R @@ -248,7 +248,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 83cc88f7..dbc4c49a 100644 --- a/R/constructor.R +++ b/R/constructor.R @@ -5,6 +5,11 @@ new_constructor <- function( package = NULL ) { properties <- as_properties(properties) + + if (is_external_class(parent)) { + return(new_external_constructor(parent, properties, envir, package)) + } + arg_info <- constructor_args(parent, properties, envir, package) self_args <- as_names(names(arg_info$self), named = TRUE) @@ -97,6 +102,57 @@ constructor_args <- function( list(parent = parent_args, self = self_args) } +# Constructor for a class that inherits from an external class. The parent's +# package might not be loaded when the class is defined, so rather than inlining +# the parent's constructor arguments (which would require resolving the external +# class now), the constructor takes the child's own properties plus a `...` that +# is forwarded to the parent. The external class is only resolved the first time +# an object is constructed (when its package must be loaded anyway): at that +# point we rebuild the class with the resolved parent so that inherited +# properties, validation, and dispatch all behave as if the parent had been +# known up front. The completed class is cached for subsequent calls. +new_external_constructor <- function(parent, properties, envir, package) { + properties <- properties[!vlapply(properties, prop_is_read_only)] + self_args <- as.pairlist(lapply( + setNames(, names2(properties)), + function(name) prop_default(properties[[name]], envir, package) + )) + self_names <- as_names(names(self_args), named = TRUE) + + # Bind the resolver into the constructor's environment: the wrapper runs in + # the consumer's namespace, which only imports S7's *exported* functions, so + # this internal helper must be reachable lexically. + env <- new.env(parent = envir) + env$parent <- parent + env$completed <- NULL + env$complete_external_class <- complete_external_class + + body <- bquote( + { + if (is.null(completed)) { + completed <<- complete_external_class(sys.function(), parent) + } + completed(..(self_names), ...) + }, + splice = TRUE + ) + + new_function(c(self_args, alist(... = )), body, env) +} + +# Rebuild a class that inherits from an external `parent`, now that the parent's +# package is loaded and the external class can be resolved. +complete_external_class <- function(child, parent) { + new_class( + child@name, + parent = resolve_external_class_req(parent), + package = child@package, + properties = child@properties, + abstract = child@abstract, + validator = child@validator + ) +} + # helpers ----------------------------------------------------------------- diff --git a/R/external-class.R b/R/external-class.R index ce7d2555..8b043c24 100644 --- a/R/external-class.R +++ b/R/external-class.R @@ -25,6 +25,15 @@ #' new_class("tree", properties = list(child = NULL | tree_stub)) #' ``` #' +#' * To subclass a class from a soft dependency. The child constructor forwards +#' `...` to the parent, so the parent is only resolved when an object is +#' constructed (not when the class is defined), and your package builds and +#' loads even if the parent's package is absent. +#' +#' ```R +#' Child <- new_class("Child", parent = new_external_class("pkg", "Parent")) +#' ``` +#' #' Make sure to call [S7_on_load()] in your package's `.onLoad()` so that #' deferred method registrations fire when the relevant package is loaded. #' diff --git a/man/new_external_class.Rd b/man/new_external_class.Rd index b1816605..d9563e37 100644 --- a/man/new_external_class.Rd +++ b/man/new_external_class.Rd @@ -38,6 +38,13 @@ 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 subclass a class from a soft dependency. The child constructor forwards +\code{...} to the parent, so the parent is only resolved when an object is +constructed (not when the class is defined), and your package builds and +loads even if the parent's package is absent. + +\if{html}{\out{
}}\preformatted{Child <- new_class("Child", parent = new_external_class("pkg", "Parent")) +}\if{html}{\out{
}} } Make sure to call \code{\link[=S7_on_load]{S7_on_load()}} in your package's \code{.onLoad()} so that diff --git a/tests/testthat/_snaps/external-class.md b/tests/testthat/_snaps/external-class.md index 64dbe751..a8280d7c 100644 --- a/tests/testthat/_snaps/external-class.md +++ b/tests/testthat/_snaps/external-class.md @@ -49,3 +49,28 @@ ! object properties are invalid: - @child must be or , not +# can subclass an external class without resolving it (in process) + + Code + Child(x = 1) + Condition + Error: + ! Can't find external class : package 'not_a_pkg' is not installed. + +# can subclass an external class with deferred resolution + + Code + t5::ChildClass(child_prop = "a", parent_prop = "b") + Condition + Error: + ! Can't find external class : package 't1' is not installed. + +--- + + Code + t5::ChildClass(child_prop = "a", parent_prop = 1) + Condition + Error in `ParentClass()`: + ! object properties are invalid: + - @parent_prop must be , not + diff --git a/tests/testthat/t1/NAMESPACE b/tests/testthat/t1/NAMESPACE index ec360154..b59d7e6b 100644 --- a/tests/testthat/t1/NAMESPACE +++ b/tests/testthat/t1/NAMESPACE @@ -1,5 +1,6 @@ # Generated by roxygen2: do not edit by hand export("Another S7 Class") +export(ParentClass) export(another_s3_generic) export(another_s7_generic) diff --git a/tests/testthat/t1/R/t1.R b/tests/testthat/t1/R/t1.R index ab11284a..80da275f 100644 --- a/tests/testthat/t1/R/t1.R +++ b/tests/testthat/t1/R/t1.R @@ -6,3 +6,10 @@ another_s3_generic <- function(x) UseMethod("another_s3_generic") #' @export `Another S7 Class` <- S7::new_class("Another S7 Class", package = "t1") + +#' @export +ParentClass <- S7::new_class( + "ParentClass", + package = "t1", + properties = list(parent_prop = S7::class_character) +) diff --git a/tests/testthat/t5/DESCRIPTION b/tests/testthat/t5/DESCRIPTION new file mode 100644 index 00000000..a64edb18 --- /dev/null +++ b/tests/testthat/t5/DESCRIPTION @@ -0,0 +1,19 @@ +Package: t5 +Title: Test Consumer Subclassing an External Class +Version: 0.0.0.9000 +Authors@R: + c(person(given = "Jim", + family = "Hester", + role = c("aut", "cre"), + email = "james.f.hester@gmail.com", + comment = c(ORCID = "0000-0002-2739-7082")), + person(given = "RStudio", + role = c("cph", "fnd"))) +Description: What the package does (one paragraph). +Imports: S7 +Suggests: t1 +License: MIT + file LICENSE +Encoding: UTF-8 +LazyData: true +Roxygen: list(markdown = TRUE) +Config/roxygen2/version: 8.0.0 diff --git a/tests/testthat/t5/NAMESPACE b/tests/testthat/t5/NAMESPACE new file mode 100644 index 00000000..aa71d02f --- /dev/null +++ b/tests/testthat/t5/NAMESPACE @@ -0,0 +1,3 @@ +# Generated by roxygen2: do not edit by hand + +export(ChildClass) diff --git a/tests/testthat/t5/R/t5.R b/tests/testthat/t5/R/t5.R new file mode 100644 index 00000000..845c28f7 --- /dev/null +++ b/tests/testthat/t5/R/t5.R @@ -0,0 +1,16 @@ +# `ChildClass` subclasses `ParentClass`, which is defined in t1 (a soft +# dependency). Because the parent is referenced via new_external_class(), t5 can +# be built and loaded even when t1 is not installed: the external class is only +# resolved when an object is actually constructed. + +#' @export +ChildClass <- S7::new_class( + "ChildClass", + package = "t5", + parent = S7::new_external_class("t1", "ParentClass"), + properties = list(child_prop = S7::class_character) +) + +.onLoad <- function(libname, pkgname) { + S7::S7_on_load() +} diff --git a/tests/testthat/test-external-class.R b/tests/testthat/test-external-class.R index 0d82d4c2..620837b5 100644 --- a/tests/testthat/test-external-class.R +++ b/tests/testthat/test-external-class.R @@ -117,6 +117,48 @@ test_that("method_deps() collects the generic and external classes", { expect_equal(deps[[3]]$version, "1.0") }) +test_that("can subclass an external class without resolving it (in process)", { + ec <- new_external_class("not_a_pkg", "Foo") + Child <- new_class("Child", parent = ec, properties = list(x = class_integer)) + + expect_named(formals(Child), c("x", "...")) + # still can't construct + expect_snapshot(Child(x = 1), error = TRUE) +}) + +test_that("can subclass an external class with deferred resolution", { + # NB: Relies on installed S7 + skip_if(getRversion() < "4.1" && Sys.info()[["sysname"]] == "Windows") + skip_if(quick_test()) + tmp_lib <- local_libpath() + + # t5 subclasses ParentClass from t1 (a soft dependency) via + # new_external_class(). It must install and load even though t1 is absent, + # because the external parent is only resolved when an object is constructed. + local_install_and_attach(test_path("t5"), tmp_lib) + + # Constructing errors clearly while t1 is unavailable + expect_snapshot( + t5::ChildClass(child_prop = "a", parent_prop = "b"), + error = TRUE + ) + + # Once t1 is installed, construction resolves the parent and forwards the + # parent property through `...` + local_install_and_attach(test_path("t1"), tmp_lib) + obj <- t5::ChildClass(child_prop = "a", parent_prop = "b") + expect_equal(obj@child_prop, "a") + expect_equal(obj@parent_prop, "b") + expect_s3_class(obj, "t5::ChildClass") + expect_s3_class(obj, "t1::ParentClass") + + # The parent constructor still validates the inherited property's type + expect_snapshot( + error = TRUE, + t5::ChildClass(child_prop = "a", parent_prop = 1) + ) +}) + test_that("dep_available() respects loaded + version", { # S7 is loaded, so this dep is available expect_true(dep_available(new_external_generic("S7", "S7_inherits", "x")))