Allow subclassing an external class with deferred resolution

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).

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,

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 -----------------------------------------------------------------
 

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.
 #'

tests/testthat/_snaps/external-class.md

@@ -49,3 +49,28 @@
       ! <mypkg::Tree> object properties are invalid:
       - @child must be <NULL> or <mypkg::Tree>, not <double>
 
+# can subclass an external class without resolving it (in process)
+
+    Code
+      Child(x = 1)
+    Condition
+      Error:
+      ! Can't find external class <not_a_pkg::Foo>: 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 <t1::ParentClass>: package 't1' is not installed.
+
+---
+
+    Code
+      t5::ChildClass(child_prop = "a", parent_prop = 1)
+    Condition
+      Error in `ParentClass()`:
+      ! <t1::ParentClass> object properties are invalid:
+      - @parent_prop must be <character>, not <double>
+

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)

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)
+)

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

tests/testthat/t5/NAMESPACE

@@ -0,0 +1,3 @@
+# Generated by roxygen2: do not edit by hand
+
+export(ChildClass)

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()
+}

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")))