From 9746ecfc063446bc082df4574e8a23155d8e0bb3 Mon Sep 17 00:00:00 2001 From: Hadley Wickham Date: Wed, 27 May 2026 17:17:07 -0500 Subject: [PATCH 01/25] Implement external class helper Used for adding methods for classes in suggested packages, or if you need a recursive class definition. Fixes #250. Fixes #573 --- NAMESPACE | 2 + NEWS.md | 1 + R/class-spec.R | 48 +++++++++ R/external-class.R | 99 +++++++++++++++++ R/external-generic.R | 66 ++++++++---- R/method-register.R | 33 ++++++ R/union.R | 1 + _pkgdown.yml | 1 + man/new_external_class.Rd | 52 +++++++++ tests/testthat/_snaps/external-class.md | 33 ++++++ tests/testthat/t1/DESCRIPTION | 2 +- tests/testthat/t1/NAMESPACE | 1 + tests/testthat/t1/R/t1.R | 3 + tests/testthat/t2/DESCRIPTION | 2 +- tests/testthat/t2/NAMESPACE | 2 + tests/testthat/t2/R/t2.R | 18 ++++ tests/testthat/test-external-class.R | 138 ++++++++++++++++++++++++ tests/testthat/test-external-generic.R | 7 ++ vignettes/packages.Rmd | 53 ++++++++- 19 files changed, 539 insertions(+), 23 deletions(-) create mode 100644 R/external-class.R create mode 100644 man/new_external_class.Rd create mode 100644 tests/testthat/_snaps/external-class.md create mode 100644 tests/testthat/test-external-class.R diff --git a/NAMESPACE b/NAMESPACE index c6e15e82..cc991495 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -15,6 +15,7 @@ S3method(print,S7_S3_class) S3method(print,S7_any) S3method(print,S7_base_class) S3method(print,S7_class) +S3method(print,S7_external_class) S3method(print,S7_external_generic) S3method(print,S7_generic) S3method(print,S7_method) @@ -76,6 +77,7 @@ export(method_explain) export(methods_register) export(new_S3_class) export(new_class) +export(new_external_class) export(new_external_generic) export(new_generic) export(new_object) diff --git a/NEWS.md b/NEWS.md index 0934262c..b8f70476 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,5 +1,6 @@ # S7 (development version) +* `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). * Internal changes to support R-devel (4.6) (#592, #593, #598, #600). * Method dispatch on `class_missing` now correctly handles missing arguments forwarded through a wrapper functions (#595). * `S7_error_method_not_found` now has a correct class vector without a duplicate `"error"` entry (@jjjermiah, #604). diff --git a/R/class-spec.R b/R/class-spec.R index 03fb7fe4..01c7a1c2 100644 --- a/R/class-spec.R +++ b/R/class-spec.R @@ -51,6 +51,7 @@ is_foundation_class <- function(x) { is_union(x) || is_base_class(x) || is_S3_class(x) || + is_external_class(x) || is_class_missing(x) || is_class_any(x) } @@ -70,6 +71,8 @@ class_type <- function(x) { "S7_union" } else if (is_S3_class(x)) { "S7_S3" + } else if (is_external_class(x)) { + "S7_external" } else if (is_S4_class(x)) { "S4" } else { @@ -88,6 +91,7 @@ class_friendly <- function(x) { S7_base = "a base type", S7_union = "an S7 union", S7_S3 = "an S3 class", + S7_external = "an external S7 class", ) } @@ -184,11 +188,35 @@ class_constructor <- function(.x) { S7_base = .x$constructor, S7_union = class_constructor(.x$classes[[1]]), S7_S3 = .x$constructor, + S7_external = class_constructor(resolve_or_error(.x)), stop(sprintf("Can't construct %s.", class_friendly(.x)), call. = FALSE) ) } +# Resolve an external_class to its concrete class, or error. +resolve_or_error <- function(x) { + resolved <- resolve_external_class(x) + if (is.null(resolved)) { + msg <- sprintf( + "Can't resolve external class `%s::%s`: package %s is not loaded.", + x$package, + x$name, + x$package + ) + stop(msg, call. = FALSE) + } + resolved +} + class_validate <- function(class, object) { + if (class_type(class) == "S7_external") { + resolved <- resolve_external_class(class) + if (is.null(resolved)) { + return(NULL) + } + class <- resolved + } + validator <- switch( class_type(class), S4 = methods::validObject, @@ -234,6 +262,7 @@ class_desc <- function(x) { S7_base = paste0("<", x$class, ">"), S7_union = oxford_or(unlist(lapply(x$classes, class_desc))), S7_S3 = paste0("S3<", paste0(x$class, collapse = "/"), ">"), + S7_external = paste0("<", external_class_name(x), ">"), ) } @@ -252,6 +281,14 @@ class_dispatch <- function(x) { S7 = c(S7_class_name(x), class_dispatch(x@parent)), S7_base = c(x$class, "S7_object"), S7_S3 = c(x$class, "S7_object"), + S7_external = { + resolved <- resolve_external_class(x) + if (is.null(resolved)) { + c(external_class_name(x), "S7_object") + } else { + class_dispatch(resolved) + } + }, stop("Unsupported class type.", call. = FALSE) ) } @@ -267,6 +304,7 @@ class_register <- function(x) { S7 = S7_class_name(x), S7_base = x$class, S7_S3 = x$class[[1]], + S7_external = external_class_name(x), stop("Unsupported class type.", call. = FALSE) ) } @@ -286,6 +324,11 @@ class_deparse <- function(x) { paste0("new_union(", paste(classes, collapse = ", "), ")") }, S7_S3 = paste0("new_S3_class(", deparse1(x$class), ")"), + S7_external = sprintf( + "new_external_class(%s, %s)", + deparse1(x$package), + deparse1(x$name) + ), ) } @@ -303,6 +346,11 @@ class_inherits <- function(x, what) { # order and contiguous, but it's probably close enough for practical # purposes S7_S3 = !isS4(x) && all(what$class %in% class(x)), + # An external class is identified by its combined "pkg::name" — S7 stamps + # this name onto every instance's class vector, so we can check inheritance + # without resolving the class itself. + S7_external = inherits(x, "S7_object") && + inherits(x, external_class_name(what)), ) } diff --git a/R/external-class.R b/R/external-class.R new file mode 100644 index 00000000..3f661503 --- /dev/null +++ b/R/external-class.R @@ -0,0 +1,99 @@ +#' Classes in other packages +#' +#' @description +#' An external class is a lightweight placeholder for an S7 class defined in +#' another package (or in your own package, but not yet 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: +#' +#' * To register a method for a generic in your package, dispatching on a class +#' from a soft dependency: `method(my_generic, new_external_class("pkg", +#' "SomeClass")) <- ...`. The method will be registered when `pkg` is loaded +#' (using the same machinery as [new_external_generic()]). +#' +#' * To refer to a class that hasn't been defined yet, such as a self-referential +#' or mutually recursive class. For example, you can create a nested class +#' with `new_class("tree", properties = list(child = NULL | +#' new_external_class("mypkg", "tree")))`. +#' +#' Make sure to call [methods_register()] in your package's `.onLoad()` so that +#' deferred method registrations fire when the relevant package is loaded. +#' +#' @param package Package the class is defined in. +#' @param name Name of the class, as a string. +#' @param version An optional version that `package` must meet for any +#' deferred method registration to fire. +#' @returns An S7 external class, i.e. a list with class `S7_external_class`. +#' @export +#' @examples +#' # Referring to a class in another package without taking a hard dependency: +#' Tibble <- new_external_class("tibble", "tbl_df") +#' Tibble +#' +#' # Self-referential class: the `child` property can be another `tree`, +#' # or `NULL` to terminate the chain. +#' tree <- new_class("tree", +#' package = "mypkg", +#' properties = list( +#' child = NULL | new_external_class("mypkg", "tree") +#' ) +#' ) +new_external_class <- function(package, name, version = NULL) { + if (!is_string(package)) { + stop("`package` must be a string.", call. = FALSE) + } + if (!is_string(name)) { + stop("`name` must be a string.", call. = FALSE) + } + + out <- list( + package = package, + name = name, + version = version + ) + class(out) <- "S7_external_class" + out +} + +is_external_class <- function(x) { + inherits(x, "S7_external_class") +} + +#' @export +print.S7_external_class <- function(x, ...) { + cat( + " ", + x$package, + "::", + x$name, + if (!is.null(x$version)) paste0(" (>= ", x$version, ")"), + "\n", + sep = "" + ) + invisible(x) +} + +# Resolve to a real class if the package is loaded (and the optional version +# constraint is met). Returns `NULL` otherwise. +resolve_external_class <- function(x) { + if (!isNamespaceLoaded(x$package)) { + return(NULL) + } + if (!is.null(x$version) && getNamespaceVersion(x$package) < x$version) { + return(NULL) + } + + ns <- asNamespace(x$package) + if (!exists(x$name, envir = ns, inherits = FALSE)) { + return(NULL) + } + get(x$name, envir = ns, inherits = FALSE) +} + +# Combined "pkg::name" string used to identify the class in registries +# and S3 class vectors. +external_class_name <- function(x) { + paste0(x$package, "::", x$name) +} diff --git a/R/external-generic.R b/R/external-generic.R index dec36025..427a66bb 100644 --- a/R/external-generic.R +++ b/R/external-generic.R @@ -99,41 +99,67 @@ methods_register <- function() { tbl <- S7_methods_table(package) for (x in tbl) { - register <- registrar(x$generic, x$signature, x$method, ns) - - if (isNamespaceLoaded(x$generic$package)) { - register() + deps <- method_deps(x$generic, x$signature) + register <- registrar(deps, x$generic, x$signature, x$method, ns) + register() + for (pkg in unique(vcapply(deps, \(dep) dep$package))) { + setHook(packageEvent(pkg, "onLoad"), register) } - setHook(packageEvent(x$generic$package, "onLoad"), register) } invisible() } -registrar <- function(generic, signature, method, env) { +# Collects all external dependencies (the generic + any external classes) +# into a single list. Each entry has at minimum `package` + `version`. +method_deps <- function(generic, signature) { + ext <- vlapply(signature, is_external_class) + c(list(generic), signature[ext]) +} + +# Are all dependency packages loaded, and do they meet any optional version +# constraints? +method_deps_available <- function(deps) { + for (dep in deps) { + if (!isNamespaceLoaded(dep$package)) { + return(FALSE) + } + if (!is.null(dep$version)) { + if (getNamespaceVersion(dep$package) < dep$version) { + return(FALSE) + } + } + } + TRUE +} + +registrar <- function(deps, generic, signature, method, env) { # Force all arguments + deps generic signature method env function(...) { + if (!method_deps_available(deps)) { + return(invisible()) + } + ns <- asNamespace(generic$package) - if ( - is.null(generic$version) || getNamespaceVersion(ns) >= generic$version - ) { - if (!exists(generic$name, envir = ns, inherits = FALSE)) { - msg <- sprintf( - "[S7] Failed to find generic %s() in package %s", - generic$name, - generic$package - ) - warning(msg, call. = FALSE) - } else { - generic_fun <- get(generic$name, envir = ns, inherits = FALSE) - register_method(generic_fun, signature, method, env, package = NULL) - } + if (!exists(generic$name, envir = ns, inherits = FALSE)) { + msg <- sprintf( + "[S7] Failed to find generic %s() in package %s", + generic$name, + generic$package + ) + warning(msg, call. = FALSE) + return(invisible()) } + + generic_fun <- get(generic$name, envir = ns, inherits = FALSE) + signature <- resolve_signature(signature) + register_method(generic_fun, signature, method, env, package = NULL) } } diff --git a/R/method-register.R b/R/method-register.R index 587b7f96..39edd151 100644 --- a/R/method-register.R +++ b/R/method-register.R @@ -73,6 +73,27 @@ register_method <- function( generic <- as_generic(getFromNamespace(generic$name, generic$package)) } + # Try to resolve any external classes whose packages are loaded. + signature <- resolve_signature(signature) + has_unresolved <- any(vlapply(signature, is_external_class)) + + if (has_unresolved) { + if (is.null(package)) { + stop( + paste0( + "External classes can only be used in method signatures inside a ", + "package, since deferred method registration requires ", + "`methods_register()`." + ), + call. = FALSE + ) + } + # Defer registration until all relevant packages are loaded. + generic_ext <- as_external_generic(generic) + external_methods_add(package, generic_ext, signature, method) + return(invisible(generic)) + } + # Register in current session if (is_S7_generic(generic)) { check_method(method, generic, name = method_name(generic, signature)) @@ -96,6 +117,18 @@ register_method <- function( invisible(generic) } +resolve_signature <- function(signature) { + for (i in seq_along(signature)) { + if (is_external_class(signature[[i]])) { + resolved <- resolve_external_class(signature[[i]]) + if (!is.null(resolved)) { + signature[[i]] <- as_class(resolved) + } + } + } + signature +} + register_S3_method <- function( generic, signature, diff --git a/R/union.R b/R/union.R index 4f5fd58d..1c4e3b12 100644 --- a/R/union.R +++ b/R/union.R @@ -60,6 +60,7 @@ on_load_define_or_methods <- function() { registerS3method("|", "S7_union", `|.S7_class`) registerS3method("|", "S7_base_class", `|.S7_class`) registerS3method("|", "S7_S3_class", `|.S7_class`) + registerS3method("|", "S7_external_class", `|.S7_class`) registerS3method("|", "S7_any", `|.S7_class`) registerS3method("|", "S7_missing", `|.S7_class`) registerS3method("|", "classGeneratorFunction", `|.S7_class`) diff --git a/_pkgdown.yml b/_pkgdown.yml index 5695611b..7cb30b96 100644 --- a/_pkgdown.yml +++ b/_pkgdown.yml @@ -41,6 +41,7 @@ reference: for more details. contents: - methods_register + - new_external_class - new_external_generic - title: Compatibility diff --git a/man/new_external_class.Rd b/man/new_external_class.Rd new file mode 100644 index 00000000..1f4aabb1 --- /dev/null +++ b/man/new_external_class.Rd @@ -0,0 +1,52 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/external-class.R +\name{new_external_class} +\alias{new_external_class} +\title{Classes in other packages} +\usage{ +new_external_class(package, name, version = NULL) +} +\arguments{ +\item{package}{Package the class is defined in.} + +\item{name}{Name of the class, as a string.} + +\item{version}{An optional version that \code{package} must meet for any +deferred method registration to fire.} +} +\value{ +An S7 external class, i.e. a list with class \code{S7_external_class}. +} +\description{ +An external class is a lightweight placeholder for an S7 class defined in +another package (or in your own package, but not yet 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: +\itemize{ +\item To register a method for a generic in your package, dispatching on a class +from a soft dependency: \code{method(my_generic, new_external_class("pkg", "SomeClass")) <- ...}. The method will be registered when \code{pkg} is loaded +(using the same machinery as \code{\link[=new_external_generic]{new_external_generic()}}). +\item To refer to a class that hasn't been defined yet, such as a self-referential +or mutually recursive class. For example, you can create a nested class +with \code{new_class("tree", properties = list(child = NULL | new_external_class("mypkg", "tree")))}. +} + +Make sure to call \code{\link[=methods_register]{methods_register()}} in your package's \code{.onLoad()} so that +deferred method registrations fire when the relevant package is loaded. +} +\examples{ +# Referring to a class in another package without taking a hard dependency: +Tibble <- new_external_class("tibble", "tbl_df") +Tibble + +# Self-referential class: the `child` property can be another `tree`, +# or `NULL` to terminate the chain. +tree <- new_class("tree", + package = "mypkg", + properties = list( + child = NULL | new_external_class("mypkg", "tree") + ) +) +} diff --git a/tests/testthat/_snaps/external-class.md b/tests/testthat/_snaps/external-class.md new file mode 100644 index 00000000..d14a7133 --- /dev/null +++ b/tests/testthat/_snaps/external-class.md @@ -0,0 +1,33 @@ +# new_external_class() validates inputs + + Code + new_external_class(1, "x") + Condition + Error: + ! `package` must be a string. + Code + new_external_class("pkg", 1) + Condition + Error: + ! `name` must be a string. + +# print method works + + Code + print(new_external_class("foo", "Bar")) + Output + foo::Bar + Code + print(new_external_class("foo", "Bar", version = "1.0")) + Output + foo::Bar (>= 1.0) + +# external class works as a property type for self-reference + + Code + tree(label = "bad", child = 1) + Condition + Error: + ! object properties are invalid: + - @child must be or , not + diff --git a/tests/testthat/t1/DESCRIPTION b/tests/testthat/t1/DESCRIPTION index bd9ecdb0..fad67487 100644 --- a/tests/testthat/t1/DESCRIPTION +++ b/tests/testthat/t1/DESCRIPTION @@ -15,4 +15,4 @@ License: MIT + file LICENSE Encoding: UTF-8 LazyData: true Roxygen: list(markdown = TRUE) -RoxygenNote: 7.3.2 +Config/roxygen2/version: 8.0.0 diff --git a/tests/testthat/t1/NAMESPACE b/tests/testthat/t1/NAMESPACE index d28a2ae2..ec360154 100644 --- a/tests/testthat/t1/NAMESPACE +++ b/tests/testthat/t1/NAMESPACE @@ -1,4 +1,5 @@ # Generated by roxygen2: do not edit by hand +export("Another S7 Class") 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 a40712c1..ab11284a 100644 --- a/tests/testthat/t1/R/t1.R +++ b/tests/testthat/t1/R/t1.R @@ -3,3 +3,6 @@ another_s7_generic <- S7::new_generic("another_s7_generic", "x") #' @export another_s3_generic <- function(x) UseMethod("another_s3_generic") + +#' @export +`Another S7 Class` <- S7::new_class("Another S7 Class", package = "t1") diff --git a/tests/testthat/t2/DESCRIPTION b/tests/testthat/t2/DESCRIPTION index 07c4290d..26e3ab27 100644 --- a/tests/testthat/t2/DESCRIPTION +++ b/tests/testthat/t2/DESCRIPTION @@ -16,4 +16,4 @@ License: MIT + file LICENSE Encoding: UTF-8 LazyData: true Roxygen: list(markdown = TRUE) -RoxygenNote: 7.3.2 +Config/roxygen2/version: 8.0.0 diff --git a/tests/testthat/t2/NAMESPACE b/tests/testthat/t2/NAMESPACE index 0fb0c4c0..3484637f 100644 --- a/tests/testthat/t2/NAMESPACE +++ b/tests/testthat/t2/NAMESPACE @@ -2,6 +2,8 @@ export("An S7 Class 2") export(an_s7_class) +export(nested) +export(own_generic) importFrom(t0, `An S7 Class`) importFrom(t0,an_s3_generic) importFrom(t0,an_s7_generic) diff --git a/tests/testthat/t2/R/t2.R b/tests/testthat/t2/R/t2.R index 72cdea59..e4a78878 100644 --- a/tests/testthat/t2/R/t2.R +++ b/tests/testthat/t2/R/t2.R @@ -33,6 +33,24 @@ S7::method(another_s7_generic, an_s7_class) <- function(x) "foo" another_s3_generic <- S7::new_external_generic("t1", "another_s3_generic", "x") S7::method(another_s3_generic, an_s7_class) <- function(x) "foo" +# A local generic with a method dispatched on a class from a soft dep (t1). +# Must register lazily, after t1 is loaded. +#' @export +own_generic <- S7::new_generic("own_generic", "x") +S7::method(own_generic, S7::new_external_class("t1", "Another S7 Class")) <- + function(x) "from t1 class" + +# A self-referential class (forward reference via new_external_class). +#' @export +nested <- S7::new_class( + "nested", + package = "t2", + properties = list( + label = S7::class_character, + child = NULL | S7::new_external_class("t2", "nested") + ) +) + .onLoad <- function(libname, pkgname) { S7::methods_register() diff --git a/tests/testthat/test-external-class.R b/tests/testthat/test-external-class.R new file mode 100644 index 00000000..6283e9d4 --- /dev/null +++ b/tests/testthat/test-external-class.R @@ -0,0 +1,138 @@ +test_that("new_external_class() validates inputs", { + expect_snapshot(error = TRUE, { + new_external_class(1, "x") + new_external_class("pkg", 1) + }) +}) + +test_that("print method works", { + expect_snapshot({ + print(new_external_class("foo", "Bar")) + print(new_external_class("foo", "Bar", version = "1.0")) + }) +}) + +test_that("external class is a valid class spec", { + ec <- new_external_class("foo", "Bar") + + expect_identical(as_class(ec), ec) + expect_equal(class_type(ec), "S7_external") + expect_equal(class_register(ec), "foo::Bar") + expect_equal(class_desc(ec), "") + expect_equal(S7_class_desc(ec), "") +}) + +test_that("external class can refer to a loaded package", { + # S7 is itself loaded, S7_object exists in it + ec <- new_external_class("S7", "S7_object") + resolved <- resolve_external_class(ec) + expect_true(is_class(resolved)) + expect_equal(resolved@name, "S7_object") +}) + +test_that("unresolved external class returns NULL", { + expect_null(resolve_external_class(new_external_class("not_a_pkg", "X"))) + expect_null(resolve_external_class(new_external_class("S7", "not_a_class"))) +}) + +test_that("external class can be used as a union arm", { + ec <- new_external_class("foo", "Bar") + u <- NULL | ec + expect_s3_class(u, "S7_union") + expect_length(u$classes, 2) +}) + +test_that("external class works as a property type for self-reference", { + tree <- new_class( + "tree", + package = "mypkg", + properties = list( + label = class_character, + child = NULL | new_external_class("mypkg", "tree") + ) + ) + + t1 <- tree(label = "leaf") + expect_null(t1@child) + + t2 <- tree(label = "root", child = t1) + expect_equal(t2@child@label, "leaf") + + # type checking still rejects wrong types + expect_snapshot(error = TRUE, tree(label = "bad", child = 1)) +}) + +test_that("external class works for mutually recursive classes", { + class_one <- new_class( + "class_one", + package = "mypkg", + properties = list(x = NULL | new_external_class("mypkg", "class_two")) + ) + class_two <- new_class( + "class_two", + package = "mypkg", + properties = list(y = NULL | new_external_class("mypkg", "class_one")) + ) + + obj <- class_one(x = class_two(y = class_one())) + expect_s3_class(obj@x, "mypkg::class_two") + expect_s3_class(obj@x@y, "mypkg::class_one") +}) + +test_that("class_inherits() works for external class", { + tree <- new_class( + "tree", + package = "mypkg", + properties = list(child = NULL | new_external_class("mypkg", "tree")) + ) + ec <- new_external_class("mypkg", "tree") + expect_true(class_inherits(tree(), ec)) + expect_false(class_inherits(1, ec)) + expect_false(class_inherits(NULL, ec)) +}) + +test_that("method registration outside a package errors when unresolved", { + foo <- new_generic("foo", "x") + expect_snapshot(error = TRUE, { + register_method( + foo, + new_external_class("not_loaded_pkg", "X"), + function(x) "x", + package = NULL + ) + }) +}) + +test_that("method registration with resolved external class works", { + foo <- new_generic("foo", "x") + # S7 is loaded, so this can resolve immediately + method(foo, new_external_class("S7", "S7_object")) <- function(x) "s7" + expect_equal(foo(S7_object()), "s7") +}) + +test_that("method_deps() collects the generic and external classes", { + gen <- new_external_generic("foo", "bar", "x") + sig <- list( + new_external_class("baz", "X"), + class_character, + new_external_class("qux", "Y", version = "1.0") + ) + deps <- method_deps(gen, sig) + expect_equal(vcapply(deps, `[[`, "package"), c("foo", "baz", "qux")) + expect_equal(deps[[3]]$version, "1.0") +}) + +test_that("method_deps_available() respects loaded + version", { + # S7 is loaded, so this dep is available + expect_true(method_deps_available(list( + new_external_generic("S7", "S7_inherits", "x") + ))) + # version too high → not available + expect_false(method_deps_available(list( + new_external_generic("S7", "S7_inherits", "x", version = "999.0") + ))) + # unloaded package → not available + expect_false(method_deps_available(list( + new_external_class("not_a_package", "X") + ))) +}) diff --git a/tests/testthat/test-external-generic.R b/tests/testthat/test-external-generic.R index 5d790215..c81da728 100644 --- a/tests/testthat/test-external-generic.R +++ b/tests/testthat/test-external-generic.R @@ -138,6 +138,13 @@ test_that("new_method works with both hard and soft dependencies", { expect_equal(another_s3_generic(t2::an_s7_class()), "foo") expect_equal(another_s7_generic("x"), "foo") + # Soft-dependency on a CLASS: t2's own generic with a t1 class signature. + expect_equal(t2::own_generic(t1::`Another S7 Class`()), "from t1 class") + + # Self-referential class works. + outer <- t2::nested(label = "outer", child = t2::nested(label = "inner")) + expect_equal(outer@child@label, "inner") + ## Check again in a fresh session, with everything installed expect_no_error(callr::r(function() { library(t2) diff --git a/vignettes/packages.Rmd b/vignettes/packages.Rmd index 3a8d427f..3f08cef4 100644 --- a/vignettes/packages.Rmd +++ b/vignettes/packages.Rmd @@ -45,16 +45,67 @@ If you export a class (i.e. its constructor), you must also set the `package` ar NB: if your package creates a hierarchy of classes, subclasses must be defined _after_ the parent classes. That means if you define the classes in separate files, you will need to use the `DESCRIPTION` Collate field (or the equivalent roxygen2 `@include` tag) to ensure the files are loaded in the correct order. -## Generics and methods +### Self-referential and mutually recursive classes + +A class can't refer to itself directly in its own property definitions, because the class object doesn't exist yet: + +```{r, eval = FALSE} +tree <- new_class("tree", properties = list(child = tree)) +#> Error in as_properties(properties): object 'tree' not found +``` + +Use `new_external_class()` to refer to the class by name instead. The name is resolved when the property is accessed, by which time the class is fully defined: + +```{r} +tree <- new_class("tree", + package = "mypkg", + properties = list( + label = class_character, + child = NULL | new_external_class("mypkg", "tree") + ) +) +tree(label = "outer", child = tree(label = "inner")) +``` + +The same approach works for mutually recursive classes (`A` references `B` and `B` references `A`), and for classes defined in different files where the file load order would otherwise force a forward reference. + +## Generics You should document generics like regular functions (since they are!). If you expect others to create their own methods for your generic, you may want to include a section describing the properties that you expect all methods to have. If you want to list all methods for a generic, you can use the [doclisting](https://doclisting.r-lib.org) package. +## Methods + If you use roxygen2, you can document S7 generics and methods by following the advice in [`vignette("rd-S7", package = "roxygen2")`](https://roxygen2.r-lib.org/articles/rd-S7.html). Note that methods can only be defined after both the class and generic have been defined. If generics/methods/classes live in different files, you will need to use the `DESCRIPTION` Collate field (or the equivalent roxygen2 `@include` tag) to ensure the files are loaded in the correct order. +### Methods for generics in suggested packages + +If you want to register a method for a generic defined in a package that you only suggest (rather than import), use `new_external_generic()` to refer to the generic without taking a hard dependency: + +```{r, eval = FALSE} +# In your package +median <- new_external_generic("stats", "median", "x") +method(median, MyClass) <- function(x, ...) { ... } +``` + +When the suggested package is loaded, S7 will register the method automatically. You must call `methods_register()` in `.onLoad()` (see the "Getting started" section above) for this to work. + +### Methods for classes in suggested packages + +Conversely, you may want to register a method for one of your own generics, dispatching on a class from a suggested package. Use `new_external_class()` to refer to the class by name: + +```{r, eval = FALSE} +# In your package +my_generic <- new_generic("my_generic", "x") +method(my_generic, new_external_class("ggplot2", "ggplot")) <- + function(x) { ... } +``` + +S7 will register the method when the suggested package (here, ggplot2) is loaded. As above, `methods_register()` must be called from `.onLoad()`. If the method requires both a soft-dependency generic and a soft-dependency class, it will be registered when both packages are loaded. + ## Backward compatibility ### S3 From 9d3a0db0a27462f4082622cf4bf5d16caf0b4f0d Mon Sep 17 00:00:00 2001 From: Hadley Wickham Date: Wed, 27 May 2026 17:24:56 -0500 Subject: [PATCH 02/25] Store full class name --- R/class-spec.R | 25 +++++-------------------- R/external-class.R | 11 ++--------- tests/testthat/_snaps/external-class.md | 9 +++++++++ tests/testthat/_snaps/property.md | 17 +---------------- 4 files changed, 17 insertions(+), 45 deletions(-) diff --git a/R/class-spec.R b/R/class-spec.R index 01c7a1c2..a59b162a 100644 --- a/R/class-spec.R +++ b/R/class-spec.R @@ -262,7 +262,7 @@ class_desc <- function(x) { S7_base = paste0("<", x$class, ">"), S7_union = oxford_or(unlist(lapply(x$classes, class_desc))), S7_S3 = paste0("S3<", paste0(x$class, collapse = "/"), ">"), - S7_external = paste0("<", external_class_name(x), ">"), + S7_external = paste0("<", x$class_name, ">"), ) } @@ -281,14 +281,7 @@ class_dispatch <- function(x) { S7 = c(S7_class_name(x), class_dispatch(x@parent)), S7_base = c(x$class, "S7_object"), S7_S3 = c(x$class, "S7_object"), - S7_external = { - resolved <- resolve_external_class(x) - if (is.null(resolved)) { - c(external_class_name(x), "S7_object") - } else { - class_dispatch(resolved) - } - }, + S7_external = class_dispatch(resolve_external_class(x)), stop("Unsupported class type.", call. = FALSE) ) } @@ -304,7 +297,7 @@ class_register <- function(x) { S7 = S7_class_name(x), S7_base = x$class, S7_S3 = x$class[[1]], - S7_external = external_class_name(x), + S7_external = x$class_name, stop("Unsupported class type.", call. = FALSE) ) } @@ -324,11 +317,7 @@ class_deparse <- function(x) { paste0("new_union(", paste(classes, collapse = ", "), ")") }, S7_S3 = paste0("new_S3_class(", deparse1(x$class), ")"), - S7_external = sprintf( - "new_external_class(%s, %s)", - deparse1(x$package), - deparse1(x$name) - ), + S7_external = sprintf("new_external_class(%s, %s)", x$package, x$name), ) } @@ -346,11 +335,7 @@ class_inherits <- function(x, what) { # order and contiguous, but it's probably close enough for practical # purposes S7_S3 = !isS4(x) && all(what$class %in% class(x)), - # An external class is identified by its combined "pkg::name" — S7 stamps - # this name onto every instance's class vector, so we can check inheritance - # without resolving the class itself. - S7_external = inherits(x, "S7_object") && - inherits(x, external_class_name(what)), + S7_external = inherits(x, "S7_object") && inherits(x, what$class_name), ) } diff --git a/R/external-class.R b/R/external-class.R index 3f661503..e6337b31 100644 --- a/R/external-class.R +++ b/R/external-class.R @@ -51,6 +51,7 @@ new_external_class <- function(package, name, version = NULL) { out <- list( package = package, name = name, + class_name = paste0(package, "::", name), version = version ) class(out) <- "S7_external_class" @@ -65,9 +66,7 @@ is_external_class <- function(x) { print.S7_external_class <- function(x, ...) { cat( " ", - x$package, - "::", - x$name, + x$class_name, if (!is.null(x$version)) paste0(" (>= ", x$version, ")"), "\n", sep = "" @@ -91,9 +90,3 @@ resolve_external_class <- function(x) { } get(x$name, envir = ns, inherits = FALSE) } - -# Combined "pkg::name" string used to identify the class in registries -# and S3 class vectors. -external_class_name <- function(x) { - paste0(x$package, "::", x$name) -} diff --git a/tests/testthat/_snaps/external-class.md b/tests/testthat/_snaps/external-class.md index d14a7133..8a1903f4 100644 --- a/tests/testthat/_snaps/external-class.md +++ b/tests/testthat/_snaps/external-class.md @@ -31,3 +31,12 @@ ! object properties are invalid: - @child must be or , not +# method registration outside a package errors when unresolved + + Code + register_method(foo, new_external_class("not_loaded_pkg", "X"), function(x) "x", + package = NULL) + Condition + Error: + ! External classes can only be used in method signatures inside a package, since deferred method registration requires `methods_register()`. + diff --git a/tests/testthat/_snaps/property.md b/tests/testthat/_snaps/property.md index 23e1e033..8524d185 100644 --- a/tests/testthat/_snaps/property.md +++ b/tests/testthat/_snaps/property.md @@ -6,22 +6,6 @@ Can't find property @x. -# property retrieval / reports dynamic getter errors as property calls - - Code - foo()@x - Condition - Error in `@x`: - ! nope - -# prop setting / reports dynamic setter errors as property calls - - Code - obj@x <- 1 - Condition - Error in `@x`: - ! nope - # prop setting / can't set read-only properties Code @@ -276,3 +260,4 @@ [tx] finished transmitting. Code expect_equal(receiver@message, "goodbye") + From 07e474f8366bfa7fbf8a5ad6e1a6fce7fe13d871 Mon Sep 17 00:00:00 2001 From: Hadley Wickham Date: Wed, 27 May 2026 17:26:39 -0500 Subject: [PATCH 03/25] Refactor dep helpers --- R/external-class.R | 10 ++++++---- R/external-generic.R | 18 +----------------- tests/testthat/test-external-class.R | 14 +++++--------- 3 files changed, 12 insertions(+), 30 deletions(-) diff --git a/R/external-class.R b/R/external-class.R index e6337b31..ea14bfa2 100644 --- a/R/external-class.R +++ b/R/external-class.R @@ -74,13 +74,15 @@ print.S7_external_class <- function(x, ...) { invisible(x) } +dep_available <- function(dep) { + isNamespaceLoaded(dep$package) && + (is.null(dep$version) || getNamespaceVersion(dep$package) >= dep$version) +} + # Resolve to a real class if the package is loaded (and the optional version # constraint is met). Returns `NULL` otherwise. resolve_external_class <- function(x) { - if (!isNamespaceLoaded(x$package)) { - return(NULL) - } - if (!is.null(x$version) && getNamespaceVersion(x$package) < x$version) { + if (!dep_available(x)) { return(NULL) } diff --git a/R/external-generic.R b/R/external-generic.R index 427a66bb..5d09a379 100644 --- a/R/external-generic.R +++ b/R/external-generic.R @@ -117,22 +117,6 @@ method_deps <- function(generic, signature) { c(list(generic), signature[ext]) } -# Are all dependency packages loaded, and do they meet any optional version -# constraints? -method_deps_available <- function(deps) { - for (dep in deps) { - if (!isNamespaceLoaded(dep$package)) { - return(FALSE) - } - if (!is.null(dep$version)) { - if (getNamespaceVersion(dep$package) < dep$version) { - return(FALSE) - } - } - } - TRUE -} - registrar <- function(deps, generic, signature, method, env) { # Force all arguments deps @@ -142,7 +126,7 @@ registrar <- function(deps, generic, signature, method, env) { env function(...) { - if (!method_deps_available(deps)) { + if (!all(vlapply(deps, dep_available))) { return(invisible()) } diff --git a/tests/testthat/test-external-class.R b/tests/testthat/test-external-class.R index 6283e9d4..4596921d 100644 --- a/tests/testthat/test-external-class.R +++ b/tests/testthat/test-external-class.R @@ -122,17 +122,13 @@ test_that("method_deps() collects the generic and external classes", { expect_equal(deps[[3]]$version, "1.0") }) -test_that("method_deps_available() respects loaded + version", { +test_that("dep_available() respects loaded + version", { # S7 is loaded, so this dep is available - expect_true(method_deps_available(list( - new_external_generic("S7", "S7_inherits", "x") - ))) + expect_true(dep_available(new_external_generic("S7", "S7_inherits", "x"))) # version too high → not available - expect_false(method_deps_available(list( + expect_false(dep_available( new_external_generic("S7", "S7_inherits", "x", version = "999.0") - ))) + )) # unloaded package → not available - expect_false(method_deps_available(list( - new_external_class("not_a_package", "X") - ))) + expect_false(dep_available(new_external_class("not_a_package", "X"))) }) From 9a8806aae95eef24928fee4f345a611e41baa2ee Mon Sep 17 00:00:00 2001 From: Hadley Wickham Date: Thu, 28 May 2026 07:44:50 -0500 Subject: [PATCH 04/25] Clarify optional/required resolution --- R/class-spec.R | 28 ++------------- R/external-class.R | 47 +++++++++++++++++++++++-- R/method-register.R | 17 ++------- tests/testthat/_snaps/external-class.md | 25 ++++++++----- tests/testthat/test-external-class.R | 43 ++++++++++------------ 5 files changed, 86 insertions(+), 74 deletions(-) diff --git a/R/class-spec.R b/R/class-spec.R index a59b162a..730f111d 100644 --- a/R/class-spec.R +++ b/R/class-spec.R @@ -188,41 +188,19 @@ class_constructor <- function(.x) { S7_base = .x$constructor, S7_union = class_constructor(.x$classes[[1]]), S7_S3 = .x$constructor, - S7_external = class_constructor(resolve_or_error(.x)), + S7_external = class_constructor(resolve_external_class_req(.x)), stop(sprintf("Can't construct %s.", class_friendly(.x)), call. = FALSE) ) } -# Resolve an external_class to its concrete class, or error. -resolve_or_error <- function(x) { - resolved <- resolve_external_class(x) - if (is.null(resolved)) { - msg <- sprintf( - "Can't resolve external class `%s::%s`: package %s is not loaded.", - x$package, - x$name, - x$package - ) - stop(msg, call. = FALSE) - } - resolved -} - class_validate <- function(class, object) { - if (class_type(class) == "S7_external") { - resolved <- resolve_external_class(class) - if (is.null(resolved)) { - return(NULL) - } - class <- resolved - } - validator <- switch( class_type(class), S4 = methods::validObject, S7 = class@validator, S7_base = class$validator, S7_S3 = class$validator, + S7_external = class_validate(resolve_external_class_req(class), object), NULL ) @@ -281,7 +259,7 @@ class_dispatch <- function(x) { S7 = c(S7_class_name(x), class_dispatch(x@parent)), S7_base = c(x$class, "S7_object"), S7_S3 = c(x$class, "S7_object"), - S7_external = class_dispatch(resolve_external_class(x)), + S7_external = class_dispatch(resolve_external_class_opt(x)), stop("Unsupported class type.", call. = FALSE) ) } diff --git a/R/external-class.R b/R/external-class.R index ea14bfa2..9beb0200 100644 --- a/R/external-class.R +++ b/R/external-class.R @@ -79,9 +79,9 @@ dep_available <- function(dep) { (is.null(dep$version) || getNamespaceVersion(dep$package) >= dep$version) } -# Resolve to a real class if the package is loaded (and the optional version +# Resolve to the real class if the package is loaded (and the optional version # constraint is met). Returns `NULL` otherwise. -resolve_external_class <- function(x) { +resolve_external_class_opt <- function(x) { if (!dep_available(x)) { return(NULL) } @@ -92,3 +92,46 @@ resolve_external_class <- function(x) { } get(x$name, envir = ns, inherits = FALSE) } + +# Resolve to the real class, loading the package if needed, erroring with a +# specific message for each failure mode. +resolve_external_class_req <- function(x) { + prefix <- sprintf("Can't find external class <%s>", x$class_name) + if (!requireNamespace(x$package, quietly = TRUE)) { + stop( + sprintf( + "%s: package '%s' is not installed.", + prefix, + x$package + ), + call. = FALSE + ) + } + + if (!is.null(x$version) && getNamespaceVersion(x$package) < x$version) { + stop( + sprintf( + "%s: package '%s' is version %s, but >= %s is required.", + prefix, + x$package, + getNamespaceVersion(x$package), + x$version + ), + call. = FALSE + ) + } + + ns <- asNamespace(x$package) + if (!exists(x$name, envir = ns, inherits = FALSE)) { + stop( + sprintf( + "%s: '%s' is not found in package '%s'.", + prefix, + x$name, + x$package + ), + call. = FALSE + ) + } + get(x$name, envir = ns, inherits = FALSE) +} diff --git a/R/method-register.R b/R/method-register.R index 39edd151..46914bee 100644 --- a/R/method-register.R +++ b/R/method-register.R @@ -73,22 +73,9 @@ register_method <- function( generic <- as_generic(getFromNamespace(generic$name, generic$package)) } - # Try to resolve any external classes whose packages are loaded. - signature <- resolve_signature(signature) + # Delay all external classes until onLoad has_unresolved <- any(vlapply(signature, is_external_class)) - if (has_unresolved) { - if (is.null(package)) { - stop( - paste0( - "External classes can only be used in method signatures inside a ", - "package, since deferred method registration requires ", - "`methods_register()`." - ), - call. = FALSE - ) - } - # Defer registration until all relevant packages are loaded. generic_ext <- as_external_generic(generic) external_methods_add(package, generic_ext, signature, method) return(invisible(generic)) @@ -120,7 +107,7 @@ register_method <- function( resolve_signature <- function(signature) { for (i in seq_along(signature)) { if (is_external_class(signature[[i]])) { - resolved <- resolve_external_class(signature[[i]]) + resolved <- resolve_external_class_opt(signature[[i]]) if (!is.null(resolved)) { signature[[i]] <- as_class(resolved) } diff --git a/tests/testthat/_snaps/external-class.md b/tests/testthat/_snaps/external-class.md index 8a1903f4..8df94e34 100644 --- a/tests/testthat/_snaps/external-class.md +++ b/tests/testthat/_snaps/external-class.md @@ -22,21 +22,30 @@ Output foo::Bar (>= 1.0) -# external class works as a property type for self-reference +# resolve_external_class_req() errors per failure mode Code - tree(label = "bad", child = 1) + resolve_external_class_req(new_external_class("not_a_pkg", "X")) Condition Error: - ! object properties are invalid: - - @child must be or , not + ! Can't find external class : package 'not_a_pkg' is not installed. + Code + resolve_external_class_req(new_external_class("S7", "S7_object", "999.0")) + Condition + Error: + ! Can't find external class : package 'S7' is version 0.2.2.9000, but >= 999.0 is required. + Code + resolve_external_class_req(new_external_class("S7", "not_a_class")) + Condition + Error: + ! Can't find external class : 'not_a_class' is not found in package 'S7'. -# method registration outside a package errors when unresolved +# external class works as a property type for self-reference Code - register_method(foo, new_external_class("not_loaded_pkg", "X"), function(x) "x", - package = NULL) + tree(label = "bad", child = 1) Condition Error: - ! External classes can only be used in method signatures inside a package, since deferred method registration requires `methods_register()`. + ! object properties are invalid: + - @child must be or , not diff --git a/tests/testthat/test-external-class.R b/tests/testthat/test-external-class.R index 4596921d..f05e4688 100644 --- a/tests/testthat/test-external-class.R +++ b/tests/testthat/test-external-class.R @@ -22,17 +22,31 @@ test_that("external class is a valid class spec", { expect_equal(S7_class_desc(ec), "") }) -test_that("external class can refer to a loaded package", { +test_that("resolve_external_class_opt() resolves a loaded class", { # S7 is itself loaded, S7_object exists in it ec <- new_external_class("S7", "S7_object") - resolved <- resolve_external_class(ec) + resolved <- resolve_external_class_opt(ec) expect_true(is_class(resolved)) expect_equal(resolved@name, "S7_object") }) -test_that("unresolved external class returns NULL", { - expect_null(resolve_external_class(new_external_class("not_a_pkg", "X"))) - expect_null(resolve_external_class(new_external_class("S7", "not_a_class"))) +test_that("resolve_external_class_opt() returns NULL when unavailable", { + expect_null(resolve_external_class_opt(new_external_class("not_a_pkg", "X"))) + expect_null(resolve_external_class_opt(new_external_class( + "S7", + "not_a_class" + ))) +}) + +test_that("resolve_external_class_req() errors per failure mode", { + expect_snapshot(error = TRUE, { + # package not installed + resolve_external_class_req(new_external_class("not_a_pkg", "X")) + # version too low + resolve_external_class_req(new_external_class("S7", "S7_object", "999.0")) + # class missing + resolve_external_class_req(new_external_class("S7", "not_a_class")) + }) }) test_that("external class can be used as a union arm", { @@ -91,25 +105,6 @@ test_that("class_inherits() works for external class", { expect_false(class_inherits(NULL, ec)) }) -test_that("method registration outside a package errors when unresolved", { - foo <- new_generic("foo", "x") - expect_snapshot(error = TRUE, { - register_method( - foo, - new_external_class("not_loaded_pkg", "X"), - function(x) "x", - package = NULL - ) - }) -}) - -test_that("method registration with resolved external class works", { - foo <- new_generic("foo", "x") - # S7 is loaded, so this can resolve immediately - method(foo, new_external_class("S7", "S7_object")) <- function(x) "s7" - expect_equal(foo(S7_object()), "s7") -}) - test_that("method_deps() collects the generic and external classes", { gen <- new_external_generic("foo", "bar", "x") sig <- list( From 9cbe334f6ab8cdcf08134a01761999bf7e1f49ef Mon Sep 17 00:00:00 2001 From: Hadley Wickham Date: Thu, 28 May 2026 07:53:36 -0500 Subject: [PATCH 05/25] Polish docs --- R/external-class.R | 44 ++++++++++++++++++++++----------------- man/new_external_class.Rd | 37 +++++++++++++++++++------------- 2 files changed, 47 insertions(+), 34 deletions(-) diff --git a/R/external-class.R b/R/external-class.R index 9beb0200..1e718345 100644 --- a/R/external-class.R +++ b/R/external-class.R @@ -2,50 +2,56 @@ #' #' @description #' An external class is a lightweight placeholder for an S7 class defined in -#' another package (or in your own package, but not yet defined). It carries -#' only the package and class name, and is resolved to the real S7 class -#' when needed. +#' 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: #' #' * To register a method for a generic in your package, dispatching on a class -#' from a soft dependency: `method(my_generic, new_external_class("pkg", -#' "SomeClass")) <- ...`. The method will be registered when `pkg` is loaded +#' from a soft dependency. The method will be registered when `pkg` is loaded #' (using the same machinery as [new_external_generic()]). #' -#' * To refer to a class that hasn't been defined yet, such as a self-referential -#' or mutually recursive class. For example, you can create a nested class -#' with `new_class("tree", properties = list(child = NULL | -#' new_external_class("mypkg", "tree")))`. +#' ```R +#' SomeClass <- new_external_class("pkg", "SomeClass") +#' method(my_generic, SomeClass) <- ... +#' ``` +#' +#' * To refer to a class that hasn't been defined yet, such as a +#' self-referential or mutually recursive class. +#' +#' ```R +#' tree_stub <- new_external_class("mypkg", "tree") +#' new_class("tree", properties = list(child = NULL | tree_stub)) +#' ``` #' #' Make sure to call [methods_register()] in your package's `.onLoad()` so that #' deferred method registrations fire when the relevant package is loaded. #' #' @param package Package the class is defined in. #' @param name Name of the class, as a string. -#' @param version An optional version that `package` must meet for any -#' deferred method registration to fire. -#' @returns An S7 external class, i.e. a list with class `S7_external_class`. +#' @inheritParams new_external_generic version +#' @returns An S7 external class, i.e. a list with S3 class `S7_external_class`. #' @export #' @examples -#' # Referring to a class in another package without taking a hard dependency: +#' # Refer to a class in another package without taking a hard dependency: #' Tibble <- new_external_class("tibble", "tbl_df") #' Tibble #' #' # Self-referential class: the `child` property can be another `tree`, #' # or `NULL` to terminate the chain. -#' tree <- new_class("tree", +#' tree_stub <- new_external_class("mypkg", "tree") +#' tree <- new_class( +#' name = "tree", #' package = "mypkg", -#' properties = list( -#' child = NULL | new_external_class("mypkg", "tree") -#' ) +#' properties = list(child = NULL | tree_stub) #' ) new_external_class <- function(package, name, version = NULL) { if (!is_string(package)) { - stop("`package` must be a string.", call. = FALSE) + stop("`package` must be a string.") } if (!is_string(name)) { - stop("`name` must be a string.", call. = FALSE) + stop("`name` must be a string.") } out <- list( diff --git a/man/new_external_class.Rd b/man/new_external_class.Rd index 1f4aabb1..8884c06d 100644 --- a/man/new_external_class.Rd +++ b/man/new_external_class.Rd @@ -11,42 +11,49 @@ new_external_class(package, name, version = NULL) \item{name}{Name of the class, as a string.} -\item{version}{An optional version that \code{package} must meet for any -deferred method registration to fire.} +\item{version}{An optional version the package must meet for the method to +be registered.} } \value{ -An S7 external class, i.e. a list with class \code{S7_external_class}. +An S7 external class, i.e. a list with S3 class \code{S7_external_class}. } \description{ An external class is a lightweight placeholder for an S7 class defined in -another package (or in your own package, but not yet defined). It carries -only the package and class name, and is resolved to the real S7 class -when needed. +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: \itemize{ \item To register a method for a generic in your package, dispatching on a class -from a soft dependency: \code{method(my_generic, new_external_class("pkg", "SomeClass")) <- ...}. The method will be registered when \code{pkg} is loaded +from a soft dependency. The method will be registered when \code{pkg} is loaded (using the same machinery as \code{\link[=new_external_generic]{new_external_generic()}}). -\item To refer to a class that hasn't been defined yet, such as a self-referential -or mutually recursive class. For example, you can create a nested class -with \code{new_class("tree", properties = list(child = NULL | new_external_class("mypkg", "tree")))}. + +\if{html}{\out{
}}\preformatted{SomeClass <- new_external_class("pkg", "SomeClass") +method(my_generic, SomeClass) <- ... +}\if{html}{\out{
}} +\item To refer to a class that hasn't been defined yet, such as a +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{
}} } Make sure to call \code{\link[=methods_register]{methods_register()}} in your package's \code{.onLoad()} so that deferred method registrations fire when the relevant package is loaded. } \examples{ -# Referring to a class in another package without taking a hard dependency: +# Refer to a class in another package without taking a hard dependency: Tibble <- new_external_class("tibble", "tbl_df") Tibble # Self-referential class: the `child` property can be another `tree`, # or `NULL` to terminate the chain. -tree <- new_class("tree", +tree_stub <- new_external_class("mypkg", "tree") +tree <- new_class( + name = "tree", package = "mypkg", - properties = list( - child = NULL | new_external_class("mypkg", "tree") - ) + properties = list(child = NULL | tree_stub) ) } From 0cecf0c1eea9c4b7299bdfcc3dc2c1ea6d77ba9b Mon Sep 17 00:00:00 2001 From: Hadley Wickham Date: Thu, 28 May 2026 07:59:34 -0500 Subject: [PATCH 06/25] Update snapshot --- tests/testthat/_snaps/external-class.md | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/tests/testthat/_snaps/external-class.md b/tests/testthat/_snaps/external-class.md index 8df94e34..cb7aa299 100644 --- a/tests/testthat/_snaps/external-class.md +++ b/tests/testthat/_snaps/external-class.md @@ -3,12 +3,12 @@ Code new_external_class(1, "x") Condition - Error: + Error in `new_external_class()`: ! `package` must be a string. Code new_external_class("pkg", 1) Condition - Error: + Error in `new_external_class()`: ! `name` must be a string. # print method works From 2e4c50f704d09cae90314f170719aa2612d93a05 Mon Sep 17 00:00:00 2001 From: Hadley Wickham Date: Thu, 28 May 2026 08:03:07 -0500 Subject: [PATCH 07/25] Refactoring to clarify intent --- R/external-class.R | 9 +++++++++ R/external-generic.R | 28 +++++++++++++++++++--------- R/method-register.R | 16 ++-------------- 3 files changed, 30 insertions(+), 23 deletions(-) diff --git a/R/external-class.R b/R/external-class.R index 1e718345..f21d04a0 100644 --- a/R/external-class.R +++ b/R/external-class.R @@ -85,6 +85,15 @@ dep_available <- function(dep) { (is.null(dep$version) || getNamespaceVersion(dep$package) >= dep$version) } +resolve_signature <- function(signature) { + for (i in seq_along(signature)) { + if (is_external_class(signature[[i]])) { + signature[[i]] <- resolve_external_class_req(signature[[i]]) + } + } + signature +} + # Resolve to the real class if the package is loaded (and the optional version # constraint is met). Returns `NULL` otherwise. resolve_external_class_opt <- function(x) { diff --git a/R/external-generic.R b/R/external-generic.R index 5d09a379..376515df 100644 --- a/R/external-generic.R +++ b/R/external-generic.R @@ -101,6 +101,7 @@ methods_register <- function() { for (x in tbl) { deps <- method_deps(x$generic, x$signature) register <- registrar(deps, x$generic, x$signature, x$method, ns) + register() for (pkg in unique(vcapply(deps, \(dep) dep$package))) { setHook(packageEvent(pkg, "onLoad"), register) @@ -130,23 +131,32 @@ registrar <- function(deps, generic, signature, method, env) { return(invisible()) } - ns <- asNamespace(generic$package) - if (!exists(generic$name, envir = ns, inherits = FALSE)) { - msg <- sprintf( - "[S7] Failed to find generic %s() in package %s", - generic$name, - generic$package - ) - warning(msg, call. = FALSE) + generic_fun <- resolve_generic(generic) + if (is.null(generic_fun)) { return(invisible()) } - generic_fun <- get(generic$name, envir = ns, inherits = FALSE) signature <- resolve_signature(signature) register_method(generic_fun, signature, method, env, package = NULL) } } +resolve_generic <- function(generic) { + ns <- asNamespace(generic$package) + if (!exists(generic$name, envir = ns, inherits = FALSE)) { + warning( + sprintf( + "[S7] Failed to find generic %s() in package %s", + generic$name, + generic$package + ), + call. = FALSE + ) + return(NULL) + } + get(generic$name, envir = ns, inherits = FALSE) +} + external_methods_reset <- function(package) { S7_methods_table(package) <- list() invisible() diff --git a/R/method-register.R b/R/method-register.R index 46914bee..d595f0f0 100644 --- a/R/method-register.R +++ b/R/method-register.R @@ -74,8 +74,8 @@ register_method <- function( } # Delay all external classes until onLoad - has_unresolved <- any(vlapply(signature, is_external_class)) - if (has_unresolved) { + is_external <- any(vlapply(signature, is_external_class)) + if (is_external) { generic_ext <- as_external_generic(generic) external_methods_add(package, generic_ext, signature, method) return(invisible(generic)) @@ -104,18 +104,6 @@ register_method <- function( invisible(generic) } -resolve_signature <- function(signature) { - for (i in seq_along(signature)) { - if (is_external_class(signature[[i]])) { - resolved <- resolve_external_class_opt(signature[[i]]) - if (!is.null(resolved)) { - signature[[i]] <- as_class(resolved) - } - } - } - signature -} - register_S3_method <- function( generic, signature, From 8ae6e5a0fd25432e41cc263f07504c87122fce33 Mon Sep 17 00:00:00 2001 From: Hadley Wickham Date: Thu, 28 May 2026 08:06:33 -0500 Subject: [PATCH 08/25] Test + vignette tidyup --- tests/testthat/_snaps/external-class.md | 6 ++-- tests/testthat/t2/NAMESPACE | 1 - tests/testthat/t2/R/t2.R | 11 ------- tests/testthat/test-external-class.R | 44 ++++++++++++------------- tests/testthat/test-external-generic.R | 4 --- vignettes/packages.Rmd | 24 -------------- 6 files changed, 25 insertions(+), 65 deletions(-) diff --git a/tests/testthat/_snaps/external-class.md b/tests/testthat/_snaps/external-class.md index cb7aa299..a79e4b2f 100644 --- a/tests/testthat/_snaps/external-class.md +++ b/tests/testthat/_snaps/external-class.md @@ -43,9 +43,9 @@ # external class works as a property type for self-reference Code - tree(label = "bad", child = 1) + Tree(label = "bad", child = 1) Condition Error: - ! object properties are invalid: - - @child must be or , not + ! object properties are invalid: + - @child must be or , not diff --git a/tests/testthat/t2/NAMESPACE b/tests/testthat/t2/NAMESPACE index 3484637f..ca8d96bb 100644 --- a/tests/testthat/t2/NAMESPACE +++ b/tests/testthat/t2/NAMESPACE @@ -2,7 +2,6 @@ export("An S7 Class 2") export(an_s7_class) -export(nested) export(own_generic) importFrom(t0, `An S7 Class`) importFrom(t0,an_s3_generic) diff --git a/tests/testthat/t2/R/t2.R b/tests/testthat/t2/R/t2.R index e4a78878..200f1fc9 100644 --- a/tests/testthat/t2/R/t2.R +++ b/tests/testthat/t2/R/t2.R @@ -40,17 +40,6 @@ own_generic <- S7::new_generic("own_generic", "x") S7::method(own_generic, S7::new_external_class("t1", "Another S7 Class")) <- function(x) "from t1 class" -# A self-referential class (forward reference via new_external_class). -#' @export -nested <- S7::new_class( - "nested", - package = "t2", - properties = list( - label = S7::class_character, - child = NULL | S7::new_external_class("t2", "nested") - ) -) - .onLoad <- function(libname, pkgname) { S7::methods_register() diff --git a/tests/testthat/test-external-class.R b/tests/testthat/test-external-class.R index f05e4688..0d82d4c2 100644 --- a/tests/testthat/test-external-class.R +++ b/tests/testthat/test-external-class.R @@ -57,50 +57,50 @@ test_that("external class can be used as a union arm", { }) test_that("external class works as a property type for self-reference", { - tree <- new_class( - "tree", + Tree <- new_class( + "Tree", package = "mypkg", properties = list( label = class_character, - child = NULL | new_external_class("mypkg", "tree") + child = NULL | new_external_class("mypkg", "Tree") ) ) - t1 <- tree(label = "leaf") - expect_null(t1@child) + leaf <- Tree(label = "leaf") + expect_null(leaf@child) - t2 <- tree(label = "root", child = t1) - expect_equal(t2@child@label, "leaf") + root <- Tree(label = "root", child = leaf) + expect_equal(root@child@label, "leaf") # type checking still rejects wrong types - expect_snapshot(error = TRUE, tree(label = "bad", child = 1)) + expect_snapshot(error = TRUE, Tree(label = "bad", child = 1)) }) test_that("external class works for mutually recursive classes", { - class_one <- new_class( - "class_one", + ClassOne <- new_class( + "ClassOne", package = "mypkg", - properties = list(x = NULL | new_external_class("mypkg", "class_two")) + properties = list(x = NULL | new_external_class("mypkg", "ClassTwo")) ) - class_two <- new_class( - "class_two", + ClassTwo <- new_class( + "ClassTwo", package = "mypkg", - properties = list(y = NULL | new_external_class("mypkg", "class_one")) + properties = list(y = NULL | new_external_class("mypkg", "ClassOne")) ) - obj <- class_one(x = class_two(y = class_one())) - expect_s3_class(obj@x, "mypkg::class_two") - expect_s3_class(obj@x@y, "mypkg::class_one") + obj <- ClassOne(x = ClassTwo(y = ClassOne())) + expect_s3_class(obj@x, "mypkg::ClassTwo") + expect_s3_class(obj@x@y, "mypkg::ClassOne") }) test_that("class_inherits() works for external class", { - tree <- new_class( - "tree", + Tree <- new_class( + "Tree", package = "mypkg", - properties = list(child = NULL | new_external_class("mypkg", "tree")) + properties = list(child = NULL | new_external_class("mypkg", "Tree")) ) - ec <- new_external_class("mypkg", "tree") - expect_true(class_inherits(tree(), ec)) + ec <- new_external_class("mypkg", "Tree") + expect_true(class_inherits(Tree(), ec)) expect_false(class_inherits(1, ec)) expect_false(class_inherits(NULL, ec)) }) diff --git a/tests/testthat/test-external-generic.R b/tests/testthat/test-external-generic.R index c81da728..d14d0341 100644 --- a/tests/testthat/test-external-generic.R +++ b/tests/testthat/test-external-generic.R @@ -141,10 +141,6 @@ test_that("new_method works with both hard and soft dependencies", { # Soft-dependency on a CLASS: t2's own generic with a t1 class signature. expect_equal(t2::own_generic(t1::`Another S7 Class`()), "from t1 class") - # Self-referential class works. - outer <- t2::nested(label = "outer", child = t2::nested(label = "inner")) - expect_equal(outer@child@label, "inner") - ## Check again in a fresh session, with everything installed expect_no_error(callr::r(function() { library(t2) diff --git a/vignettes/packages.Rmd b/vignettes/packages.Rmd index 3f08cef4..48324acb 100644 --- a/vignettes/packages.Rmd +++ b/vignettes/packages.Rmd @@ -45,30 +45,6 @@ If you export a class (i.e. its constructor), you must also set the `package` ar NB: if your package creates a hierarchy of classes, subclasses must be defined _after_ the parent classes. That means if you define the classes in separate files, you will need to use the `DESCRIPTION` Collate field (or the equivalent roxygen2 `@include` tag) to ensure the files are loaded in the correct order. -### Self-referential and mutually recursive classes - -A class can't refer to itself directly in its own property definitions, because the class object doesn't exist yet: - -```{r, eval = FALSE} -tree <- new_class("tree", properties = list(child = tree)) -#> Error in as_properties(properties): object 'tree' not found -``` - -Use `new_external_class()` to refer to the class by name instead. The name is resolved when the property is accessed, by which time the class is fully defined: - -```{r} -tree <- new_class("tree", - package = "mypkg", - properties = list( - label = class_character, - child = NULL | new_external_class("mypkg", "tree") - ) -) -tree(label = "outer", child = tree(label = "inner")) -``` - -The same approach works for mutually recursive classes (`A` references `B` and `B` references `A`), and for classes defined in different files where the file load order would otherwise force a forward reference. - ## Generics You should document generics like regular functions (since they are!). From 1cd46648b7b91efd6c25af686d630cdd3d59fb44 Mon Sep 17 00:00:00 2001 From: Hadley Wickham Date: Wed, 10 Jun 2026 08:29:54 -0500 Subject: [PATCH 09/25] Polishing --- NEWS.md | 2 +- R/external-class.R | 10 ++++++---- R/external-generic.R | 7 ++++--- 3 files changed, 11 insertions(+), 8 deletions(-) diff --git a/NEWS.md b/NEWS.md index 4560b1d6..03ace2a7 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,6 +1,5 @@ # S7 (development version) -* `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). * Internal changes to support R-devel (4.6) (#592, #593, #598, #600). * 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). @@ -19,6 +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_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/external-class.R b/R/external-class.R index 63dff5ca..ce7d2555 100644 --- a/R/external-class.R +++ b/R/external-class.R @@ -94,8 +94,9 @@ resolve_signature <- function(signature) { signature } -# Resolve to the real class if the package is loaded (and the optional version -# constraint is met). Returns `NULL` otherwise. +# Optional resolution: used by `class_dispatch()` when building the +# dispatch vector, where an unavailable external class should be silently +# skipped. resolve_external_class_opt <- function(x) { if (!dep_available(x)) { return(NULL) @@ -108,8 +109,9 @@ resolve_external_class_opt <- function(x) { get(x$name, envir = ns, inherits = FALSE) } -# Resolve to the real class, loading the package if needed, erroring with a -# specific message for each failure mode. +# Required resolution: used when registering a method, when extending +# (since the child constructor inlines the parent arguments) and when +# constructing or validating an instance. resolve_external_class_req <- function(x) { prefix <- sprintf("Can't find external class <%s>", x$class_name) if (!requireNamespace(x$package, quietly = TRUE)) { diff --git a/R/external-generic.R b/R/external-generic.R index 4c3abd4c..2bcfd9ae 100644 --- a/R/external-generic.R +++ b/R/external-generic.R @@ -108,7 +108,9 @@ registrar <- function(deps, generic, signature, method, env) { resolve_generic <- function(generic) { ns <- asNamespace(generic$package) - if (!exists(generic$name, envir = ns, inherits = FALSE)) { + if (exists(generic$name, envir = ns, inherits = FALSE)) { + get(generic$name, envir = ns, inherits = FALSE) + } else { warning( sprintf( "[S7] Failed to find generic %s() in package %s", @@ -117,9 +119,8 @@ resolve_generic <- function(generic) { ), call. = FALSE ) - return(NULL) + NULL } - get(generic$name, envir = ns, inherits = FALSE) } external_methods_reset <- function(package) { From 45a0d3b7c26caac76309108f91b879d778e6e213 Mon Sep 17 00:00:00 2001 From: Hadley Wickham Date: Wed, 10 Jun 2026 12:12:48 -0500 Subject: [PATCH 10/25] Polish errors --- R/external-class.R | 45 ++++++++++++------------- tests/testthat/_snaps/external-class.md | 11 +++--- tests/testthat/test-external-class.R | 6 ++-- 3 files changed, 31 insertions(+), 31 deletions(-) diff --git a/R/external-class.R b/R/external-class.R index ce7d2555..51591104 100644 --- a/R/external-class.R +++ b/R/external-class.R @@ -48,10 +48,10 @@ #' ) new_external_class <- function(package, name, version = NULL) { if (!is_string(package)) { - stop("`package` must be a string.") + stop2("`package` must be a string.") } if (!is_string(name)) { - stop("`name` must be a string.") + stop2("`name` must be a string.") } out <- list( @@ -85,6 +85,9 @@ dep_available <- function(dep) { (is.null(dep$version) || getNamespaceVersion(dep$package) >= dep$version) } +# Make it mockable +getNamespaceVersion <- NULL + resolve_signature <- function(signature) { for (i in seq_along(signature)) { if (is_external_class(signature[[i]])) { @@ -113,41 +116,37 @@ resolve_external_class_opt <- function(x) { # (since the child constructor inlines the parent arguments) and when # constructing or validating an instance. resolve_external_class_req <- function(x) { - prefix <- sprintf("Can't find external class <%s>", x$class_name) + prefix <- sprintf("Can't find external class <%s>:\n", x$class_name) if (!requireNamespace(x$package, quietly = TRUE)) { - stop( - sprintf( - "%s: package '%s' is not installed.", - prefix, - x$package - ), - call. = FALSE + stop2( + paste0(prefix, sprintf("* Package '%s' is not installed.", x$package)), + call = NULL ) } if (!is.null(x$version) && getNamespaceVersion(x$package) < x$version) { - stop( - sprintf( - "%s: package '%s' is version %s, but >= %s is required.", + stop2( + paste0( prefix, - x$package, - getNamespaceVersion(x$package), - x$version + sprintf( + "* Package '%s' needs version %s, but only %s is available.", + x$package, + x$version, + getNamespaceVersion(x$package) + ) ), - call. = FALSE + call = NULL ) } ns <- asNamespace(x$package) if (!exists(x$name, envir = ns, inherits = FALSE)) { - stop( - sprintf( - "%s: '%s' is not found in package '%s'.", + stop2( + paste0( prefix, - x$name, - x$package + sprintf("* Packages '%s' doesn't contain '%s'.", x$package, x$name) ), - call. = FALSE + call = NULL ) } get(x$name, envir = ns, inherits = FALSE) diff --git a/tests/testthat/_snaps/external-class.md b/tests/testthat/_snaps/external-class.md index 64dbe751..a37b1a22 100644 --- a/tests/testthat/_snaps/external-class.md +++ b/tests/testthat/_snaps/external-class.md @@ -28,17 +28,20 @@ resolve_external_class_req(new_external_class("not_a_pkg", "X")) Condition Error: - ! Can't find external class : package 'not_a_pkg' is not installed. + ! Can't find external class : + * Package 'not_a_pkg' is not installed. Code - resolve_external_class_req(new_external_class("S7", "S7_object", "999.0")) + resolve_external_class_req(new_external_class("S7", "S7_object", "2.0.0")) Condition Error: - ! Can't find external class : package 'S7' is version 0.2.2.9000, but >= 999.0 is required. + ! Can't find external class : + * Package 'S7' needs version 2.0.0, but only 1.0.0 is available. Code resolve_external_class_req(new_external_class("S7", "not_a_class")) Condition Error: - ! Can't find external class : 'not_a_class' is not found in package 'S7'. + ! Can't find external class : + * Packages 'S7' doesn't contain 'not_a_class'. # external class works as a property type for self-reference diff --git a/tests/testthat/test-external-class.R b/tests/testthat/test-external-class.R index 0d82d4c2..8b9cee0d 100644 --- a/tests/testthat/test-external-class.R +++ b/tests/testthat/test-external-class.R @@ -39,12 +39,10 @@ test_that("resolve_external_class_opt() returns NULL when unavailable", { }) test_that("resolve_external_class_req() errors per failure mode", { + local_mocked_bindings(getNamespaceVersion = function(package) "1.0.0") expect_snapshot(error = TRUE, { - # package not installed resolve_external_class_req(new_external_class("not_a_pkg", "X")) - # version too low - resolve_external_class_req(new_external_class("S7", "S7_object", "999.0")) - # class missing + resolve_external_class_req(new_external_class("S7", "S7_object", "2.0.0")) resolve_external_class_req(new_external_class("S7", "not_a_class")) }) }) From c665edcecf14a7304be51a441ed9dec65d5ed79e Mon Sep 17 00:00:00 2001 From: Hadley Wickham Date: Wed, 10 Jun 2026 12:14:03 -0500 Subject: [PATCH 11/25] Style --- R/external-generic.R | 14 +++++++------- 1 file changed, 7 insertions(+), 7 deletions(-) diff --git a/R/external-generic.R b/R/external-generic.R index 2bcfd9ae..da4e989e 100644 --- a/R/external-generic.R +++ b/R/external-generic.R @@ -76,13 +76,6 @@ is_external_generic <- function(x) { inherits(x, "S7_external_generic") } -# Collects all external dependencies (the generic + any external classes) -# into a single list. Each entry has at minimum `package` + `version`. -method_deps <- function(generic, signature) { - ext <- vlapply(signature, is_external_class) - c(list(generic), signature[ext]) -} - registrar <- function(deps, generic, signature, method, env) { # Force all arguments deps @@ -106,6 +99,13 @@ registrar <- function(deps, generic, signature, method, env) { } } +# Collects all external dependencies (the generic + any external classes) +# into a single list. Each entry has at minimum `package` + `version`. +method_deps <- function(generic, signature) { + ext <- vlapply(signature, is_external_class) + c(list(generic), signature[ext]) +} + resolve_generic <- function(generic) { ns <- asNamespace(generic$package) if (exists(generic$name, envir = ns, inherits = FALSE)) { From 7dd3dc43c07d53279326b0495d58e91400f6283f Mon Sep 17 00:00:00 2001 From: Hadley Wickham Date: Wed, 10 Jun 2026 12:16:52 -0500 Subject: [PATCH 12/25] Polish vignette --- vignettes/packages.Rmd | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/vignettes/packages.Rmd b/vignettes/packages.Rmd index 6fe52fd9..1d1fae3d 100644 --- a/vignettes/packages.Rmd +++ b/vignettes/packages.Rmd @@ -74,7 +74,7 @@ median <- new_external_generic("stats", "median", "x") method(median, MyClass) <- function(x, ...) { ... } ``` -When the suggested package is loaded, S7 will register the method automatically. You must call `methods_register()` in `.onLoad()` (see the "Getting started" section above) for this to work. +When the suggested package is loaded, S7 will register the method automatically (via `S7_on_load()` as described above). ### Methods for classes in suggested packages @@ -83,11 +83,11 @@ Conversely, you may want to register a method for one of your own generics, disp ```{r, eval = FALSE} # In your package my_generic <- new_generic("my_generic", "x") -method(my_generic, new_external_class("ggplot2", "ggplot")) <- - function(x) { ... } +ggplot <- new_external_class("ggplot2", "ggplot") +method(my_generic, ggplot) <- function(x) { ... } ``` -S7 will register the method when the suggested package (here, ggplot2) is loaded. As above, `methods_register()` must be called from `.onLoad()`. If the method requires both a soft-dependency generic and a soft-dependency class, it will be registered when both packages are loaded. +When the suggested package is loaded, S7 will register the method automatically (via `S7_on_load()` as described above). ## Backward compatibility From ae57980c3f63b0c0611fb23fe94ebf3725428b21 Mon Sep 17 00:00:00 2001 From: Hadley Wickham Date: Tue, 16 Jun 2026 07:17:28 -0500 Subject: [PATCH 13/25] Use `:=` --- tests/testthat/test-external-class.R | 12 ++++-------- 1 file changed, 4 insertions(+), 8 deletions(-) diff --git a/tests/testthat/test-external-class.R b/tests/testthat/test-external-class.R index 8b9cee0d..ae1c4641 100644 --- a/tests/testthat/test-external-class.R +++ b/tests/testthat/test-external-class.R @@ -55,8 +55,7 @@ test_that("external class can be used as a union arm", { }) test_that("external class works as a property type for self-reference", { - Tree <- new_class( - "Tree", + Tree := new_class( package = "mypkg", properties = list( label = class_character, @@ -75,13 +74,11 @@ test_that("external class works as a property type for self-reference", { }) test_that("external class works for mutually recursive classes", { - ClassOne <- new_class( - "ClassOne", + ClassOne := new_class( package = "mypkg", properties = list(x = NULL | new_external_class("mypkg", "ClassTwo")) ) - ClassTwo <- new_class( - "ClassTwo", + ClassTwo := new_class( package = "mypkg", properties = list(y = NULL | new_external_class("mypkg", "ClassOne")) ) @@ -92,8 +89,7 @@ test_that("external class works for mutually recursive classes", { }) test_that("class_inherits() works for external class", { - Tree <- new_class( - "Tree", + Tree := new_class( package = "mypkg", properties = list(child = NULL | new_external_class("mypkg", "Tree")) ) From fa997643af01fe399fdae043f2728960b58083ae Mon Sep 17 00:00:00 2001 From: Tomasz Kalinowski Date: Tue, 16 Jun 2026 09:20:00 -0400 Subject: [PATCH 14/25] test: cover external class method edge cases Add regression tests for method registration outside packages, external classes nested in union signatures, and unresolved external class introspection. --- tests/testthat/test-external-class.R | 2 +- tests/testthat/test-method-introspect.R | 8 ++++++ tests/testthat/test-method-register.R | 33 +++++++++++++++++++++++++ 3 files changed, 42 insertions(+), 1 deletion(-) diff --git a/tests/testthat/test-external-class.R b/tests/testthat/test-external-class.R index ae1c4641..70118413 100644 --- a/tests/testthat/test-external-class.R +++ b/tests/testthat/test-external-class.R @@ -104,7 +104,7 @@ test_that("method_deps() collects the generic and external classes", { sig <- list( new_external_class("baz", "X"), class_character, - new_external_class("qux", "Y", version = "1.0") + NULL | new_external_class("qux", "Y", version = "1.0") ) deps <- method_deps(gen, sig) expect_equal(vcapply(deps, `[[`, "package"), c("foo", "baz", "qux")) diff --git a/tests/testthat/test-method-introspect.R b/tests/testthat/test-method-introspect.R index 21affc22..225ed177 100644 --- a/tests/testthat/test-method-introspect.R +++ b/tests/testthat/test-method-introspect.R @@ -35,6 +35,14 @@ test_that("method introspection errors if no method found", { }) }) +test_that("method introspection skips unresolved external classes", { + foo := new_generic("x") + method(foo, NULL) <- function(x) "null" + + ext <- new_external_class("not_a_package", "X") + expect_error(method(foo, class = ext), "Can't find method") +}) + test_that("method explanation shows all possible methods along with matches", { foo1 := new_class(package = NULL) foo2 := new_class(foo1, package = NULL) diff --git a/tests/testthat/test-method-register.R b/tests/testthat/test-method-register.R index 9f6379b9..4e288eac 100644 --- a/tests/testthat/test-method-register.R +++ b/tests/testthat/test-method-register.R @@ -56,6 +56,19 @@ test_that("method registration returns the generic unchanged when not in a packa expect_identical(out, sum) }) +test_that("method registration resolves external classes outside packages", { + env <- new.env(parent = baseenv()) + env[["method<-"]] <- `method<-` + env$g <- new_generic("g", "x") + env$ext <- new_external_class("S7", "S7_object") + env$f <- function(x) "external" + + expect_null(packageName(env)) + evalq(method(g, ext) <- f, env) + + expect_equal(env$g(S7_object()), "external") +}) + test_that("method registration returns a strippable sentinel for foreign generics in a package (#364)", { external_methods_reset("S7") on.exit(external_methods_reset("S7"), add = TRUE) @@ -87,6 +100,26 @@ test_that("method registration returns a strippable sentinel for foreign generic expect_length(S7_methods_table("S7"), 2) }) +test_that("method registration defers external classes in union signatures", { + external_methods_reset("S7") + on.exit(external_methods_reset("S7"), add = TRUE) + + env <- new.env(parent = baseenv()) + env$.packageName <- "S7" + env[["method<-"]] <- `method<-` + env$new_generic <- new_generic + env$ext <- new_external_class("notloaded.pkg", "ext_class") + env$f <- function(x) "x" + + evalq({ + foo <- new_generic("foo", "x") + method(foo, NULL | ext) <- f + }, env) + + expect_length(methods(env$foo), 0) + expect_length(S7_methods_table("S7"), 1) +}) + test_that("method unregistration removes an S7 method via NULL assignment", { foo := new_generic("x") method(foo, class_character) <- function(x) "c" From def0f131da4bc04d904e18df9b924059705544bb Mon Sep 17 00:00:00 2001 From: Tomasz Kalinowski Date: Tue, 16 Jun 2026 09:32:13 -0400 Subject: [PATCH 15/25] Fix external class method registration edge cases --- R/class-spec.R | 5 ++++- R/external-class.R | 46 +++++++++++++++++++++++++++++++++++++++++--- R/external-generic.R | 3 +-- R/method-register.R | 16 +++++++++------ 4 files changed, 58 insertions(+), 12 deletions(-) diff --git a/R/class-spec.R b/R/class-spec.R index a486dd63..fc3a7ccf 100644 --- a/R/class-spec.R +++ b/R/class-spec.R @@ -263,7 +263,10 @@ class_dispatch <- function(x) { S7 = c(S7_class_name(x), class_dispatch(x@parent)), S7_base = c(x$class, "S7_object"), S7_S3 = c(x$class, "S7_object"), - S7_external = class_dispatch(resolve_external_class_opt(x)), + S7_external = { + class <- resolve_external_class_opt(x) + if (is.null(class)) character() else class_dispatch(class) + }, stop2("Unsupported class type.", call = NULL) ) } diff --git a/R/external-class.R b/R/external-class.R index 51591104..a574d774 100644 --- a/R/external-class.R +++ b/R/external-class.R @@ -68,6 +68,38 @@ is_external_class <- function(x) { inherits(x, "S7_external_class") } +class_has_external_class <- function(x) { + if (is_external_class(x)) { + TRUE + } else if (is_union(x)) { + any(vlapply(x$classes, class_has_external_class)) + } else { + FALSE + } +} + +signature_has_external_class <- function(signature) { + any(vlapply(signature, class_has_external_class)) +} + +class_external_deps <- function(x) { + if (is_external_class(x)) { + list(x) + } else if (is_union(x)) { + flatten_external_deps(lapply(x$classes, class_external_deps)) + } else { + list() + } +} + +signature_external_deps <- function(signature) { + flatten_external_deps(lapply(signature, class_external_deps)) +} + +flatten_external_deps <- function(x) { + unlist(x, recursive = FALSE, use.names = FALSE) +} + #' @export print.S7_external_class <- function(x, ...) { cat( @@ -90,13 +122,21 @@ getNamespaceVersion <- NULL resolve_signature <- function(signature) { for (i in seq_along(signature)) { - if (is_external_class(signature[[i]])) { - signature[[i]] <- resolve_external_class_req(signature[[i]]) - } + signature[[i]] <- resolve_class_req(signature[[i]]) } signature } +resolve_class_req <- function(x) { + if (is_external_class(x)) { + resolve_external_class_req(x) + } else if (is_union(x)) { + do.call(new_union, lapply(x$classes, resolve_class_req)) + } else { + x + } +} + # Optional resolution: used by `class_dispatch()` when building the # dispatch vector, where an unavailable external class should be silently # skipped. diff --git a/R/external-generic.R b/R/external-generic.R index 2584b93c..a838a5b9 100644 --- a/R/external-generic.R +++ b/R/external-generic.R @@ -102,8 +102,7 @@ registrar <- function(deps, generic, signature, method, env) { # Collects all external dependencies (the generic + any external classes) # into a single list. Each entry has at minimum `package` + `version`. method_deps <- function(generic, signature) { - ext <- vlapply(signature, is_external_class) - c(list(generic), signature[ext]) + c(list(generic), signature_external_deps(signature)) } resolve_generic <- function(generic) { diff --git a/R/method-register.R b/R/method-register.R index 5f5b500a..881a0f73 100644 --- a/R/method-register.R +++ b/R/method-register.R @@ -85,12 +85,16 @@ register_method <- function( ) } - # Delay all external classes until onLoad - is_external <- any(vlapply(signature, is_external_class)) - if (is_external) { - generic_ext <- as_external_generic(generic) - external_methods_add(package, generic_ext, signature, method) - return(invisible(generic)) + # Delay package methods with external classes until onLoad. Outside a package + # there is no deferred methods table, so resolve them before registering. + if (signature_has_external_class(signature)) { + if (is.null(package)) { + signature <- resolve_signature(signature) + } else { + generic_ext <- as_external_generic(generic, env) + external_methods_add(package, generic_ext, signature, method) + return(invisible(generic)) + } } # Register in current session From bfb4db55618fec4e6855247711cff437043d5b8c Mon Sep 17 00:00:00 2001 From: Tomasz Kalinowski Date: Tue, 16 Jun 2026 09:32:45 -0400 Subject: [PATCH 16/25] `air format .` --- tests/testthat/test-method-register.R | 11 +++++++---- 1 file changed, 7 insertions(+), 4 deletions(-) diff --git a/tests/testthat/test-method-register.R b/tests/testthat/test-method-register.R index 4e288eac..4c198919 100644 --- a/tests/testthat/test-method-register.R +++ b/tests/testthat/test-method-register.R @@ -111,10 +111,13 @@ test_that("method registration defers external classes in union signatures", { env$ext <- new_external_class("notloaded.pkg", "ext_class") env$f <- function(x) "x" - evalq({ - foo <- new_generic("foo", "x") - method(foo, NULL | ext) <- f - }, env) + evalq( + { + foo <- new_generic("foo", "x") + method(foo, NULL | ext) <- f + }, + env + ) expect_length(methods(env$foo), 0) expect_length(S7_methods_table("S7"), 1) From 5a2d37fc5a4810641240afb407f70b962e7fe640 Mon Sep 17 00:00:00 2001 From: Tomasz Kalinowski Date: Tue, 16 Jun 2026 12:24:07 -0400 Subject: [PATCH 17/25] Add regressions for external class edge cases Cover resolving external classes whose S7 name differs from their namespace binding, preserving generic sentinels for deferred foreign methods, and rejecting unprovable property overrides involving unresolved external classes. --- tests/testthat/t1/R/t1.R | 3 +++ tests/testthat/test-class.R | 28 +++++++++++++++++++++++++++ tests/testthat/test-external-class.R | 15 ++++++++++++++ tests/testthat/test-method-register.R | 17 ++++++++++++++++ 4 files changed, 63 insertions(+) diff --git a/tests/testthat/t1/R/t1.R b/tests/testthat/t1/R/t1.R index f4221091..2d8b3f89 100644 --- a/tests/testthat/t1/R/t1.R +++ b/tests/testthat/t1/R/t1.R @@ -7,6 +7,9 @@ another_s3_generic <- function(x) UseMethod("another_s3_generic") #' @export `Another S7 Class` <- S7::new_class("Another S7 Class", package = "t1") +renamed <- function() {} +class_renamed <- S7::new_class("renamed", package = "t1") + .onLoad <- function(...) { S7::S7_on_load() } diff --git a/tests/testthat/test-class.R b/tests/testthat/test-class.R index e31814cd..38145b5e 100644 --- a/tests/testthat/test-class.R +++ b/tests/testthat/test-class.R @@ -193,6 +193,34 @@ test_that("inheritance doesn't let child properties widen or change the parent's }) }) +test_that("inheritance doesn't widen properties with unresolved external classes", { + Ext <- new_external_class("notloaded.pkg", "Cls") + Parent <- new_class( + "Parent", + properties = list(x = NULL | Ext), + package = NULL + ) + + expect_no_error( + new_class( + "SameTypeChild", + Parent, + properties = list(x = Ext), + package = NULL + ) + ) + + expect_error( + new_class( + "Child", + Parent, + properties = list(x = class_character), + package = NULL + ), + "must narrow" + ) +}) + test_that("inheritance lets dynamic child properties override any parent type", { foo1 <- new_class("foo1", properties = list(x = class_integer)) readonly <- new_property(class_character, getter = function(self) "x") diff --git a/tests/testthat/test-external-class.R b/tests/testthat/test-external-class.R index 70118413..91fe1dc1 100644 --- a/tests/testthat/test-external-class.R +++ b/tests/testthat/test-external-class.R @@ -30,6 +30,21 @@ test_that("resolve_external_class_opt() resolves a loaded class", { expect_equal(resolved@name, "S7_object") }) +test_that("external class resolution uses the S7 class name", { + skip_if(getRversion() < "4.1" && Sys.info()[["sysname"]] == "Windows") + skip_if(quick_test()) + + tmp_lib <- local_libpath() + local_install_and_attach(test_path("t1"), tmp_lib) + + ec <- new_external_class("t1", "renamed") + resolved <- resolve_external_class_req(ec) + + expect_true(is_class(resolved)) + expect_equal(S7_class_name(resolved), "t1::renamed") + expect_identical(resolve_external_class_opt(ec), resolved) +}) + test_that("resolve_external_class_opt() returns NULL when unavailable", { expect_null(resolve_external_class_opt(new_external_class("not_a_pkg", "X"))) expect_null(resolve_external_class_opt(new_external_class( diff --git a/tests/testthat/test-method-register.R b/tests/testthat/test-method-register.R index 4c198919..b49c71af 100644 --- a/tests/testthat/test-method-register.R +++ b/tests/testthat/test-method-register.R @@ -100,6 +100,23 @@ test_that("method registration returns a strippable sentinel for foreign generic expect_length(S7_methods_table("S7"), 2) }) +test_that("deferred external-class methods preserve sentinel for foreign generics", { + external_methods_reset("S7") + on.exit(external_methods_reset("S7"), add = TRUE) + + out <- register_method( + sum, + new_external_class("notloaded.pkg", "ext_class"), + function(x, ...) "x", + env = asNamespace("S7"), + package = "S7" + ) + + expect_s3_class(out, "S7_generic_sentinel") + expect_s3_class(out, "S7_external_generic") + expect_length(S7_methods_table("S7"), 1) +}) + test_that("method registration defers external classes in union signatures", { external_methods_reset("S7") on.exit(external_methods_reset("S7"), add = TRUE) From 9e83fd7ca6f9f80d11ab6168d48fec5832fec92d Mon Sep 17 00:00:00 2001 From: Tomasz Kalinowski Date: Tue, 16 Jun 2026 12:24:54 -0400 Subject: [PATCH 18/25] Fix external class resolution and deferred method cleanup Resolve external classes by S7 class name, preserve generic sentinels when deferring methods for foreign generics with external-class signatures, and avoid treating unresolved external classes as an empty inheritance hierarchy. --- R/class-spec.R | 25 +++++++++++++++++++++++++ R/external-class.R | 38 ++++++++++++++++++++++++++++++++------ R/method-register.R | 5 ++++- 3 files changed, 61 insertions(+), 7 deletions(-) diff --git a/R/class-spec.R b/R/class-spec.R index fc3a7ccf..eda59fd5 100644 --- a/R/class-spec.R +++ b/R/class-spec.R @@ -348,12 +348,37 @@ class_extends <- function(child, parent) { methods::extends(child@className, parent@className) } else if (is_class(parent) && parent@name == "S7_object") { is_class(child) + } else if (is_external_class(child) || is_external_class(parent)) { + class_extends_external(child, parent) } else { # handle S7, S3, and base types. class_dispatch_extends(class_dispatch(parent), class_dispatch(child)) } } +class_extends_external <- function(child, parent) { + if (is_external_class(child)) { + child_resolved <- resolve_external_class_opt(child) + if (is.null(child_resolved)) { + return( + is_external_class(parent) && + identical(child$class_name, parent$class_name) + ) + } + child <- child_resolved + } + + if (is_external_class(parent)) { + parent_resolved <- resolve_external_class_opt(parent) + if (is.null(parent_resolved)) { + return(FALSE) + } + parent <- parent_resolved + } + + class_extends(child, parent) +} + obj_type <- function(x) { if (identical(x, quote(expr = ))) { "missing" diff --git a/R/external-class.R b/R/external-class.R index a574d774..045d1967 100644 --- a/R/external-class.R +++ b/R/external-class.R @@ -145,11 +145,37 @@ resolve_external_class_opt <- function(x) { return(NULL) } + find_external_class(x) +} + +find_external_class <- function(x) { ns <- asNamespace(x$package) - if (!exists(x$name, envir = ns, inherits = FALSE)) { - return(NULL) + if (exists(x$name, envir = ns, inherits = FALSE)) { + obj <- get(x$name, envir = ns, inherits = FALSE) + if (is_external_class_match(obj, x)) { + return(obj) + } } - get(x$name, envir = ns, inherits = FALSE) + + for (name in ls(ns, all.names = TRUE)) { + obj <- get(name, envir = ns, inherits = FALSE) + if (is_external_class_match(obj, x)) { + return(obj) + } + } + + NULL +} + +is_external_class_match <- function(obj, x) { + is_class(obj) && + ( + identical(S7_class_name(obj), x$class_name) || + ( + identical(obj@name, x$name) && + (is.null(obj@package) || identical(obj@package, x$package)) + ) + ) } # Required resolution: used when registering a method, when extending @@ -179,8 +205,8 @@ resolve_external_class_req <- function(x) { ) } - ns <- asNamespace(x$package) - if (!exists(x$name, envir = ns, inherits = FALSE)) { + class <- find_external_class(x) + if (is.null(class)) { stop2( paste0( prefix, @@ -189,5 +215,5 @@ resolve_external_class_req <- function(x) { call = NULL ) } - get(x$name, envir = ns, inherits = FALSE) + class } diff --git a/R/method-register.R b/R/method-register.R index 881a0f73..ddfffc90 100644 --- a/R/method-register.R +++ b/R/method-register.R @@ -93,7 +93,10 @@ register_method <- function( } else { generic_ext <- as_external_generic(generic, env) external_methods_add(package, generic_ext, signature, method) - return(invisible(generic)) + if (!is_local_generic(generic, package)) { + return(generic_sentinel(generic_ext)) + } + return(invisible(original)) } } From a6922ee599db6df53399a5e42bdbd066171c7394 Mon Sep 17 00:00:00 2001 From: Hadley Wickham Date: Thu, 18 Jun 2026 11:28:08 -0500 Subject: [PATCH 19/25] Reformat --- R/external-class.R | 10 +++------- 1 file changed, 3 insertions(+), 7 deletions(-) diff --git a/R/external-class.R b/R/external-class.R index 045d1967..175c6023 100644 --- a/R/external-class.R +++ b/R/external-class.R @@ -169,13 +169,9 @@ find_external_class <- function(x) { is_external_class_match <- function(obj, x) { is_class(obj) && - ( - identical(S7_class_name(obj), x$class_name) || - ( - identical(obj@name, x$name) && - (is.null(obj@package) || identical(obj@package, x$package)) - ) - ) + (identical(S7_class_name(obj), x$class_name) || + (identical(obj@name, x$name) && + (is.null(obj@package) || identical(obj@package, x$package)))) } # Required resolution: used when registering a method, when extending From f747a04e3f8173f724b42a650eb772981246fba2 Mon Sep 17 00:00:00 2001 From: Hadley Wickham Date: Thu, 18 Jun 2026 12:09:08 -0500 Subject: [PATCH 20/25] This PR does not handle subclassing --- R/class-spec.R | 24 ++++-------------- R/external-class.R | 19 +++++--------- R/property.R | 11 +------- man/new_external_class.Rd | 3 +++ tests/testthat/_snaps/class.md | 9 +++++++ tests/testthat/_snaps/method-introspect.md | 15 +++++++++++ tests/testthat/test-class.R | 29 +++++----------------- tests/testthat/test-external-class.R | 17 ------------- tests/testthat/test-method-introspect.R | 7 ++++-- 9 files changed, 50 insertions(+), 84 deletions(-) diff --git a/R/class-spec.R b/R/class-spec.R index eda59fd5..77826450 100644 --- a/R/class-spec.R +++ b/R/class-spec.R @@ -263,10 +263,7 @@ class_dispatch <- function(x) { S7 = c(S7_class_name(x), class_dispatch(x@parent)), S7_base = c(x$class, "S7_object"), S7_S3 = c(x$class, "S7_object"), - S7_external = { - class <- resolve_external_class_opt(x) - if (is.null(class)) character() else class_dispatch(class) - }, + S7_external = class_dispatch(resolve_external_class_req(x)), stop2("Unsupported class type.", call = NULL) ) } @@ -356,26 +353,15 @@ class_extends <- function(child, parent) { } } +# Subclassing an external class requires its package to be loaded, so we can +# always resolve it here (erroring clearly if it's unavailable). class_extends_external <- function(child, parent) { if (is_external_class(child)) { - child_resolved <- resolve_external_class_opt(child) - if (is.null(child_resolved)) { - return( - is_external_class(parent) && - identical(child$class_name, parent$class_name) - ) - } - child <- child_resolved + child <- resolve_external_class_req(child) } - if (is_external_class(parent)) { - parent_resolved <- resolve_external_class_opt(parent) - if (is.null(parent_resolved)) { - return(FALSE) - } - parent <- parent_resolved + parent <- resolve_external_class_req(parent) } - class_extends(child, parent) } diff --git a/R/external-class.R b/R/external-class.R index 175c6023..0b239590 100644 --- a/R/external-class.R +++ b/R/external-class.R @@ -28,6 +28,9 @@ #' 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 @@ -137,17 +140,6 @@ resolve_class_req <- function(x) { } } -# Optional resolution: used by `class_dispatch()` when building the -# dispatch vector, where an unavailable external class should be silently -# skipped. -resolve_external_class_opt <- function(x) { - if (!dep_available(x)) { - return(NULL) - } - - find_external_class(x) -} - find_external_class <- function(x) { ns <- asNamespace(x$package) if (exists(x$name, envir = ns, inherits = FALSE)) { @@ -174,8 +166,9 @@ is_external_class_match <- function(obj, x) { (is.null(obj@package) || identical(obj@package, x$package)))) } -# Required resolution: used when registering a method, when extending -# (since the child constructor inlines the parent arguments) and when +# Required resolution: errors if the external class can't be resolved (e.g. +# its package isn't loaded). Used wherever we need the real class: registering +# or looking up methods, checking property overrides in a subclass, and # constructing or validating an instance. resolve_external_class_req <- function(x) { prefix <- sprintf("Can't find external class <%s>:\n", x$class_name) diff --git a/R/property.R b/R/property.R index 3f68a318..dc3d62ba 100644 --- a/R/property.R +++ b/R/property.R @@ -216,16 +216,7 @@ str.S7_property <- function(object, ..., nest.lev = 0) { } prop_default <- function(prop, envir, package) { - if (!is.null(prop$default)) { - return(prop$default) - } - # An unresolved external class has no constructor, so it can't supply a - # default; use a missing argument and let the value come from the parent. - cls <- prop$class - if (is_external_class(cls) && is.null(resolve_external_class_opt(cls))) { - return(quote(expr = )) - } - class_construct_expr(cls, envir, package) + prop$default %||% class_construct_expr(prop$class, envir, package) } prop_default_desc <- function(prop, package = NULL) { diff --git a/man/new_external_class.Rd b/man/new_external_class.Rd index b1816605..b3e6b616 100644 --- a/man/new_external_class.Rd +++ b/man/new_external_class.Rd @@ -42,6 +42,9 @@ new_class("tree", properties = list(child = NULL | tree_stub)) 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 a class in another package without taking a hard dependency: diff --git a/tests/testthat/_snaps/class.md b/tests/testthat/_snaps/class.md index 941c207a..5e44a215 100644 --- a/tests/testthat/_snaps/class.md +++ b/tests/testthat/_snaps/class.md @@ -149,6 +149,15 @@ - @x is . - @x is . +# subclassing an external class requires its package to be loaded + + Code + new_class("Child", Parent, properties = list(x = Ext)) + Condition + Error: + ! Can't find external class : + * Package 'notloaded.pkg' is not installed. + # abstract classes can't be instantiated Code diff --git a/tests/testthat/_snaps/method-introspect.md b/tests/testthat/_snaps/method-introspect.md index 2307f793..72924a45 100644 --- a/tests/testthat/_snaps/method-introspect.md +++ b/tests/testthat/_snaps/method-introspect.md @@ -60,6 +60,21 @@ - x: - y: +# method introspection requires external class's package to be loaded + + Code + method(foo, class = ext) + Condition + Error: + ! Can't find external class : + * Package 'not_a_package' is not installed. + Code + method_explain(foo, class = ext) + Condition + Error: + ! Can't find external class : + * Package 'not_a_package' is not installed. + # method explanation shows all possible methods along with matches add([foo2], [foo2]) diff --git a/tests/testthat/test-class.R b/tests/testthat/test-class.R index 38145b5e..8ae0672a 100644 --- a/tests/testthat/test-class.R +++ b/tests/testthat/test-class.R @@ -193,31 +193,14 @@ test_that("inheritance doesn't let child properties widen or change the parent's }) }) -test_that("inheritance doesn't widen properties with unresolved external classes", { - Ext <- new_external_class("notloaded.pkg", "Cls") - Parent <- new_class( - "Parent", - properties = list(x = NULL | Ext), - package = NULL - ) - expect_no_error( - new_class( - "SameTypeChild", - Parent, - properties = list(x = Ext), - package = NULL - ) - ) +test_that("subclassing an external class requires its package to be loaded", { + Ext <- new_external_class("notloaded.pkg", "Cls") + Parent := new_class(properties = list(x = NULL | Ext), package = NULL) - expect_error( - new_class( - "Child", - Parent, - properties = list(x = class_character), - package = NULL - ), - "must narrow" + expect_snapshot( + new_class("Child", Parent, properties = list(x = Ext)), + error = TRUE ) }) diff --git a/tests/testthat/test-external-class.R b/tests/testthat/test-external-class.R index 91fe1dc1..9c5f5724 100644 --- a/tests/testthat/test-external-class.R +++ b/tests/testthat/test-external-class.R @@ -22,14 +22,6 @@ test_that("external class is a valid class spec", { expect_equal(S7_class_desc(ec), "") }) -test_that("resolve_external_class_opt() resolves a loaded class", { - # S7 is itself loaded, S7_object exists in it - ec <- new_external_class("S7", "S7_object") - resolved <- resolve_external_class_opt(ec) - expect_true(is_class(resolved)) - expect_equal(resolved@name, "S7_object") -}) - test_that("external class resolution uses the S7 class name", { skip_if(getRversion() < "4.1" && Sys.info()[["sysname"]] == "Windows") skip_if(quick_test()) @@ -42,15 +34,6 @@ test_that("external class resolution uses the S7 class name", { expect_true(is_class(resolved)) expect_equal(S7_class_name(resolved), "t1::renamed") - expect_identical(resolve_external_class_opt(ec), resolved) -}) - -test_that("resolve_external_class_opt() returns NULL when unavailable", { - expect_null(resolve_external_class_opt(new_external_class("not_a_pkg", "X"))) - expect_null(resolve_external_class_opt(new_external_class( - "S7", - "not_a_class" - ))) }) test_that("resolve_external_class_req() errors per failure mode", { diff --git a/tests/testthat/test-method-introspect.R b/tests/testthat/test-method-introspect.R index 225ed177..f1a68067 100644 --- a/tests/testthat/test-method-introspect.R +++ b/tests/testthat/test-method-introspect.R @@ -35,12 +35,15 @@ test_that("method introspection errors if no method found", { }) }) -test_that("method introspection skips unresolved external classes", { +test_that("method introspection requires external class's package to be loaded", { foo := new_generic("x") method(foo, NULL) <- function(x) "null" ext <- new_external_class("not_a_package", "X") - expect_error(method(foo, class = ext), "Can't find method") + expect_snapshot(error = TRUE, { + method(foo, class = ext) + method_explain(foo, class = ext) + }) }) test_that("method explanation shows all possible methods along with matches", { From 96574d53693db8931eb0e4fb3003e2ebba4c0bb1 Mon Sep 17 00:00:00 2001 From: Hadley Wickham Date: Thu, 18 Jun 2026 12:33:06 -0500 Subject: [PATCH 21/25] Drop class_extends_external helper --- R/class-spec.R | 20 ++++++-------------- 1 file changed, 6 insertions(+), 14 deletions(-) diff --git a/R/class-spec.R b/R/class-spec.R index 77826450..62e2d843 100644 --- a/R/class-spec.R +++ b/R/class-spec.R @@ -345,26 +345,18 @@ class_extends <- function(child, parent) { methods::extends(child@className, parent@className) } else if (is_class(parent) && parent@name == "S7_object") { is_class(child) - } else if (is_external_class(child) || is_external_class(parent)) { - class_extends_external(child, parent) + } else if (is_external_class(child)) { + child <- resolve_external_class_req(child) + class_extends(child, parent) + } else if (is_external_class(parent)) { + parent <- resolve_external_class_req(parent) + class_extends(child, parent) } else { # handle S7, S3, and base types. class_dispatch_extends(class_dispatch(parent), class_dispatch(child)) } } -# Subclassing an external class requires its package to be loaded, so we can -# always resolve it here (erroring clearly if it's unavailable). -class_extends_external <- function(child, parent) { - if (is_external_class(child)) { - child <- resolve_external_class_req(child) - } - if (is_external_class(parent)) { - parent <- resolve_external_class_req(parent) - } - class_extends(child, parent) -} - obj_type <- function(x) { if (identical(x, quote(expr = ))) { "missing" From 16ca6a2749b081a83f9e88310ca33a77dfb85790 Mon Sep 17 00:00:00 2001 From: Hadley Wickham Date: Thu, 18 Jun 2026 12:57:37 -0500 Subject: [PATCH 22/25] Use `local_package()` in tests --- R/external-generic.R | 5 -- tests/testthat/t1/NAMESPACE | 1 - tests/testthat/t1/R/t1.R | 6 -- tests/testthat/t2/NAMESPACE | 1 - tests/testthat/t2/R/t2.R | 7 --- tests/testthat/test-external-class.R | 19 +++---- tests/testthat/test-external-generic.R | 3 - tests/testthat/test-hooks.R | 16 ++++++ tests/testthat/test-method-register.R | 79 ++++++++------------------ 9 files changed, 50 insertions(+), 87 deletions(-) diff --git a/R/external-generic.R b/R/external-generic.R index d439eb07..14955b25 100644 --- a/R/external-generic.R +++ b/R/external-generic.R @@ -134,11 +134,6 @@ resolve_generic <- function(generic) { } } -external_methods_reset <- function(package) { - S7_methods_table(package) <- list() - invisible() -} - external_methods_add <- function( package, generic, diff --git a/tests/testthat/t1/NAMESPACE b/tests/testthat/t1/NAMESPACE index ec360154..d28a2ae2 100644 --- a/tests/testthat/t1/NAMESPACE +++ b/tests/testthat/t1/NAMESPACE @@ -1,5 +1,4 @@ # Generated by roxygen2: do not edit by hand -export("Another S7 Class") 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 2d8b3f89..a4ffdd7e 100644 --- a/tests/testthat/t1/R/t1.R +++ b/tests/testthat/t1/R/t1.R @@ -4,12 +4,6 @@ another_s7_generic <- S7::new_generic("another_s7_generic", "x") #' @export another_s3_generic <- function(x) UseMethod("another_s3_generic") -#' @export -`Another S7 Class` <- S7::new_class("Another S7 Class", package = "t1") - -renamed <- function() {} -class_renamed <- S7::new_class("renamed", package = "t1") - .onLoad <- function(...) { S7::S7_on_load() } diff --git a/tests/testthat/t2/NAMESPACE b/tests/testthat/t2/NAMESPACE index ca8d96bb..0fb0c4c0 100644 --- a/tests/testthat/t2/NAMESPACE +++ b/tests/testthat/t2/NAMESPACE @@ -2,7 +2,6 @@ export("An S7 Class 2") export(an_s7_class) -export(own_generic) importFrom(t0, `An S7 Class`) importFrom(t0,an_s3_generic) importFrom(t0,an_s7_generic) diff --git a/tests/testthat/t2/R/t2.R b/tests/testthat/t2/R/t2.R index 02fb1aa3..5acb70a3 100644 --- a/tests/testthat/t2/R/t2.R +++ b/tests/testthat/t2/R/t2.R @@ -33,13 +33,6 @@ S7::method(another_s7_generic, an_s7_class) <- function(x) "foo" another_s3_generic <- S7::new_external_generic("t1", "another_s3_generic", "x") S7::method(another_s3_generic, an_s7_class) <- function(x) "foo" -# A local generic with a method dispatched on a class from a soft dep (t1). -# Must register lazily, after t1 is loaded. -#' @export -own_generic <- S7::new_generic("own_generic", "x") -S7::method(own_generic, S7::new_external_class("t1", "Another S7 Class")) <- - function(x) "from t1 class" - .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 9c5f5724..d25fd0dc 100644 --- a/tests/testthat/test-external-class.R +++ b/tests/testthat/test-external-class.R @@ -23,17 +23,16 @@ test_that("external class is a valid class spec", { }) test_that("external class resolution uses the S7 class name", { - skip_if(getRversion() < "4.1" && Sys.info()[["sysname"]] == "Windows") - skip_if(quick_test()) - - tmp_lib <- local_libpath() - local_install_and_attach(test_path("t1"), tmp_lib) - - ec <- new_external_class("t1", "renamed") - resolved <- resolve_external_class_req(ec) + # The class is bound to `class_renamed`, but its S7 name is "renamed", so + # resolution must find it by scanning for a matching S7 class name. + pkg := local_package( + renamed <- new_class("named") + ) + named := new_external_class("pkg") + resolved <- resolve_external_class_req(named) - expect_true(is_class(resolved)) - expect_equal(S7_class_name(resolved), "t1::renamed") + expect_s3_class(resolved, "S7_class") + expect_equal(S7_class_name(resolved), "pkg::named") }) test_that("resolve_external_class_req() errors per failure mode", { diff --git a/tests/testthat/test-external-generic.R b/tests/testthat/test-external-generic.R index 8bf7ba79..3a423189 100644 --- a/tests/testthat/test-external-generic.R +++ b/tests/testthat/test-external-generic.R @@ -144,9 +144,6 @@ test_that("new_method works with both hard and soft dependencies", { expect_equal(another_s3_generic(t2::an_s7_class()), "foo") expect_equal(another_s7_generic("x"), "foo") - # Soft-dependency on a CLASS: t2's own generic with a t1 class signature. - expect_equal(t2::own_generic(t1::`Another S7 Class`()), "from t1 class") - ## Check again in a fresh session, with everything installed expect_no_error(callr::r(function() { library(t2) diff --git a/tests/testthat/test-hooks.R b/tests/testthat/test-hooks.R index e48f1306..1f8a62ce 100644 --- a/tests/testthat/test-hooks.R +++ b/tests/testthat/test-hooks.R @@ -14,6 +14,22 @@ test_that("S7_on_load() doesn't accumulate hooks across repeated loads", { expect_length(package_hooks("upstream"), 1) }) +test_that("S7_on_load() registers methods dispatching on an external class", { + upstream := local_package( + Foo := new_class() + ) + downstream := local_package( + own_generic := new_generic("x"), + Foo := new_external_class("upstream"), + method(own_generic, Foo) <- \(x) "from external class" + ) + # The method is deferred (its signature has an external class), not yet live + expect_length(methods(downstream$own_generic), 0) + + S7_on_load_(downstream) + expect_equal(downstream$own_generic(upstream$Foo()), "from external class") +}) + test_that("S7_on_unload() unregisters methods and removes hooks", { upstream <- local_package("upstream", gen := new_generic("x")) downstream <- local_package( diff --git a/tests/testthat/test-method-register.R b/tests/testthat/test-method-register.R index 80abd5d0..2fe06880 100644 --- a/tests/testthat/test-method-register.R +++ b/tests/testthat/test-method-register.R @@ -78,74 +78,45 @@ test_that("method registration resolves external classes outside packages", { }) test_that("method registration returns a strippable sentinel for foreign generics in a package (#364)", { - external_methods_reset("S7") - on.exit(external_methods_reset("S7"), add = TRUE) - - foo := new_class(package = NULL) - ext <- new_external_generic("notloaded.pkg", "ext_gen", "x") - - out <- register_method( - ext, - foo, - function(x) "x", - env = asNamespace("S7"), - package = "S7" + pkg := local_package( + ext := new_external_generic("notloaded.pkg", "x"), + foo := new_class(), + foo2 := new_class() ) - expect_s3_class(out, "S7_generic_sentinel") - expect_s3_class(out, "S7_external_generic") + + # In a package, `method<-` writes a sentinel back into the binding + evalq(method(ext, foo) <- function(x) "x", pkg) + expect_s3_class(pkg$ext, "S7_generic_sentinel") + expect_s3_class(pkg$ext, "S7_external_generic") # the sentinel is still a usable generic, so further methods can be # registered through the same binding (as in the t2 test package) - foo2 := new_class(package = NULL) - out <- register_method( - out, - foo2, - function(x) "y", - env = asNamespace("S7"), - package = "S7" - ) - expect_s3_class(out, "S7_generic_sentinel") - expect_length(S7_methods_table("S7"), 2) + evalq(method(ext, foo2) <- function(x) "y", pkg) + expect_s3_class(pkg$ext, "S7_generic_sentinel") + expect_length(S7_methods_table("pkg"), 2) }) test_that("deferred external-class methods preserve sentinel for foreign generics", { - external_methods_reset("S7") - on.exit(external_methods_reset("S7"), add = TRUE) - - out <- register_method( - sum, - new_external_class("notloaded.pkg", "ext_class"), - function(x, ...) "x", - env = asNamespace("S7"), - package = "S7" + pkg := local_package( + ext := new_external_class("notloaded.pkg") ) - expect_s3_class(out, "S7_generic_sentinel") - expect_s3_class(out, "S7_external_generic") - expect_length(S7_methods_table("S7"), 1) + # In a package, `method<-` writes a sentinel back into the binding + evalq(method(sum, ext) <- function(x, ...) "x", pkg) + expect_s3_class(pkg$sum, "S7_generic_sentinel") + expect_s3_class(pkg$sum, "S7_external_generic") + expect_length(S7_methods_table("pkg"), 1) }) test_that("method registration defers external classes in union signatures", { - external_methods_reset("S7") - on.exit(external_methods_reset("S7"), add = TRUE) - - env <- new.env(parent = baseenv()) - env$.packageName <- "S7" - env[["method<-"]] <- `method<-` - env$new_generic <- new_generic - env$ext <- new_external_class("notloaded.pkg", "ext_class") - env$f <- function(x) "x" - - evalq( - { - foo <- new_generic("foo", "x") - method(foo, NULL | ext) <- f - }, - env + pkg := local_package( + foo := new_generic("x"), + ext := new_external_class("notloaded.pkg"), + method(foo, NULL | ext) <- function(x) "x" ) - expect_length(methods(env$foo), 0) - expect_length(S7_methods_table("S7"), 1) + expect_length(methods(pkg$foo), 0) + expect_length(S7_methods_table("pkg"), 1) }) test_that("method unregistration removes an S7 method via NULL assignment", { From a831c178bde5b409a6d4b97c6c32b21c13bf22b8 Mon Sep 17 00:00:00 2001 From: Hadley Wickham Date: Thu, 18 Jun 2026 13:01:01 -0500 Subject: [PATCH 23/25] Add comment --- R/external-class.R | 1 + 1 file changed, 1 insertion(+) diff --git a/R/external-class.R b/R/external-class.R index 0b239590..f102762b 100644 --- a/R/external-class.R +++ b/R/external-class.R @@ -149,6 +149,7 @@ find_external_class <- function(x) { } } + # Also consider cases where the constructor isn't named the same as the class for (name in ls(ns, all.names = TRUE)) { obj <- get(name, envir = ns, inherits = FALSE) if (is_external_class_match(obj, x)) { From 111f82fcc535728ff3d02bc0ebea8a1afb312c88 Mon Sep 17 00:00:00 2001 From: Hadley Wickham Date: Thu, 18 Jun 2026 13:03:22 -0500 Subject: [PATCH 24/25] Revert roxygen2 changes --- tests/testthat/t1/DESCRIPTION | 2 +- tests/testthat/t2/DESCRIPTION | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/tests/testthat/t1/DESCRIPTION b/tests/testthat/t1/DESCRIPTION index fad67487..bd9ecdb0 100644 --- a/tests/testthat/t1/DESCRIPTION +++ b/tests/testthat/t1/DESCRIPTION @@ -15,4 +15,4 @@ License: MIT + file LICENSE Encoding: UTF-8 LazyData: true Roxygen: list(markdown = TRUE) -Config/roxygen2/version: 8.0.0 +RoxygenNote: 7.3.2 diff --git a/tests/testthat/t2/DESCRIPTION b/tests/testthat/t2/DESCRIPTION index 26e3ab27..07c4290d 100644 --- a/tests/testthat/t2/DESCRIPTION +++ b/tests/testthat/t2/DESCRIPTION @@ -16,4 +16,4 @@ License: MIT + file LICENSE Encoding: UTF-8 LazyData: true Roxygen: list(markdown = TRUE) -Config/roxygen2/version: 8.0.0 +RoxygenNote: 7.3.2 From 5fdfc29c96253443983a54063723cd1e70f3a2cc Mon Sep 17 00:00:00 2001 From: Hadley Wickham Date: Thu, 18 Jun 2026 13:59:18 -0500 Subject: [PATCH 25/25] Refactor hooks logic --- R/external-generic.R | 3 ++ R/hooks.R | 86 +++++++++++++++++++++----------------------- 2 files changed, 43 insertions(+), 46 deletions(-) diff --git a/R/external-generic.R b/R/external-generic.R index 14955b25..1537620a 100644 --- a/R/external-generic.R +++ b/R/external-generic.R @@ -116,6 +116,9 @@ registrar <- function(deps, generic, signature, method, env) { method_deps <- function(generic, signature) { c(list(generic), signature_external_deps(signature)) } +method_deps_packages <- function(deps) { + unique(vcapply(deps, function(dep) dep$package)) +} resolve_generic <- function(generic) { ns <- asNamespace(generic$package) diff --git a/R/hooks.R b/R/hooks.R index d1f9aa8a..468d8f3c 100644 --- a/R/hooks.R +++ b/R/hooks.R @@ -48,12 +48,7 @@ methods_register <- function() { } S7_on_load_ <- function(env) { - package <- packageName(env) - - hooks_remove(package) # always start from a clean slate - hooks <- hooks_add(package) - hooks_run_loaded(hooks) # run hooks for loaded packages - + hooks_set_and_run(packageName(env)) invisible() } @@ -97,58 +92,57 @@ S7_on_unload_ <- function(env) { invisible() } -# Add a hook for each method that registers it when one of its dependency -# packages (the generic's package, or an external class's package) is loaded. -# Returns the added hooks. -hooks_add <- function(package) { +# Start from a clean slate, then register each method whose dependency packages +# are already loaded, and add a hook so it (re)registers whenever one of those +# packages is loaded in the future. +hooks_set_and_run <- function(package) { + hooks_remove(package) + + pkgs <- character() + for (x in S7_methods_table(package)) { + hook <- hook_add(package, x) + hook$run() + pkgs <- c(pkgs, hook$pkgs) + } + + # Record packages with hooks so we can remove them on unload + hooks_packages(package) <- unique(pkgs) + invisible() +} + +# Add a hook that (re)registers method `x` whenever one of its dependency +# packages is loaded, and return its registrar so it can also be run now. +hook_add <- function(package, x) { ns <- asNamespace(package) - tbl <- S7_methods_table(package) - all_pkgs <- character() - hooks <- list() - for (x in tbl) { - deps <- method_deps(x$generic, x$signature) - register <- registrar(deps, x$generic, x$signature, x$method, ns) - hook <- S7_hook(register, package) + deps <- method_deps(x$generic, x$signature) + register <- registrar(deps, x$generic, x$signature, x$method, ns) + hook <- S7_hook(register, package) - dep_pkgs <- unique(vcapply(deps, function(dep) dep$package)) - for (pkg in dep_pkgs) { - setHook(packageEvent(pkg, "onLoad"), hook) - } - all_pkgs <- union(all_pkgs, dep_pkgs) - append1(hooks) <- hook + pkgs <- method_deps_packages(deps) + for (pkg in pkgs) { + setHook(packageEvent(pkg, "onLoad"), hook) } - hooks_packages(package) <- union(hooks_packages(package), all_pkgs) - hooks + + list(run = register, pkgs = pkgs) } -# Remove our hooks for `package`. +# Remove all of our hooks for `package`. `hooks_packages()` records every +# package event we've added a hook to, so we don't need to re-derive them here. hooks_remove <- function(package) { - tbl <- S7_methods_table(package) - pkgs <- unique(c( - hooks_packages(package), - vcapply(tbl, function(x) x$generic$package) - )) - - for (pkg in pkgs) { - event <- packageEvent(pkg, "onLoad") - hooks <- getHook(event) - ours <- vlapply(hooks, is_S7_hook, package = package) - if (any(ours)) { - setHook(event, hooks[!ours], action = "replace") - } + for (pkg in hooks_packages(package)) { + hook_remove(package, pkg) } hooks_packages(package) <- character() invisible() } - -hooks_run_loaded <- function(hooks) { - # Each hook is a registrar that no-ops until all of its dependency packages - # are loaded, so it's safe to run them all here. - for (hook in hooks) { - hook() +hook_remove <- function(package, pkg) { + event <- packageEvent(pkg, "onLoad") + hooks <- getHook(event) + ours <- vlapply(hooks, is_S7_hook, package = package) + if (any(ours)) { + setHook(event, hooks[!ours], action = "replace") } - invisible() } #' @export