From 69672a6f35f4195db19c708d0fd88c557e7fdf5b Mon Sep 17 00:00:00 2001 From: Hadley Wickham Date: Fri, 12 Jun 2026 15:30:51 -0500 Subject: [PATCH 01/20] Implement `S7_on_unload()` Perform the opposite role as `S7_on_load()`. Fixes #316. --- NAMESPACE | 1 + NEWS.md | 4 +- R/external-generic.R | 2 + R/generic.R | 3 +- R/hooks.R | 68 +++++++++++++++++++- man/S7_on_load.Rd | 16 ++++- tests/testthat/_snaps/method-register.md | 2 +- tests/testthat/test-external-generic.R | 11 ++++ tests/testthat/test-hooks.R | 79 ++++++++++++++++++++++++ tests/testthat/test-method-register.R | 10 ++- vignettes/packages.Rmd | 8 ++- 11 files changed, 195 insertions(+), 9 deletions(-) diff --git a/NAMESPACE b/NAMESPACE index 8f9fa4c3..effbaf9c 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -46,6 +46,7 @@ export(S7_inherits) export(S7_object) export(S7_on_build) export(S7_on_load) +export(S7_on_unload) export(as_class) export(check_is_S7) export(class_Date) diff --git a/NEWS.md b/NEWS.md index 0f174ea0..6e153a29 100644 --- a/NEWS.md +++ b/NEWS.md @@ -16,6 +16,7 @@ * `method<-` now gives a clear error when assigning a primitive function (e.g. `log`) as a method (#608). * `method<-` and `method()` now accept a length-1 list as `signature` for single-dispatch generics, matching the list-of-classes form required for multi-dispatch (#555). * `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). +* `method<-` no longer emits an "Overwriting method" message when re-registering an identical method, eliminating spurious messages from `devtools::load_all()` (#474). * `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_object()` now gives an informative error when `.parent` is a class specification rather than an instance of the parent class (#409). @@ -36,7 +37,8 @@ * `S7_data<-()` now preserves attributes (like `names` or `dim`) from the replacement data instead of carrying over the originals, so resizing the underlying data works correctly (#478). * `S7_error_method_not_found` now has a correct class vector without a duplicate `"error"` entry (@jjjermiah, #604). * `S7_inherits()` and `check_is_S7()` now accept any class specification (S7 class, S7 union, S3 class, S4 class, or base type wrapper like `class_integer`), not just S7 classes (#556). -* `S7_on_load()` is the new name for `methods_register()`, giving it a nicer symmetry with `S7_on_build()`; `methods_register()` remains available for backward compatibility (#615). +* `S7_on_load()` is the new name for `methods_register()`, giving it a nicer symmetry with `S7_on_build()`; `methods_register()` remains available for backward compatibility (#615). It no longer accumulates duplicate registration hooks when a package is loaded repeatedly (#316). +* New `S7_on_unload()`, to be called from `.onUnload()`, unregisters the methods that your package registered for S7 generics in other packages and removes the hooks that `S7_on_load()` added (#316). * `str()` on S7 objects that inherit from data.frame (or other S3 classes whose underlying data has a `dim` attribute incompatible with the bare base type) no longer errors (#494). * `super()` now works with S3 and S4 objects, not just S7 objects (#500). * `validate()` now signals validation errors with class `S7_error_validation_failed`, so they can be caught with `tryCatch()` (#602, #605). diff --git a/R/external-generic.R b/R/external-generic.R index 6e72ecca..dc374d9e 100644 --- a/R/external-generic.R +++ b/R/external-generic.R @@ -109,6 +109,8 @@ external_methods_reset <- function(package) { } external_methods_add <- function(package, generic, signature, method) { + # Re-registering a method replaces the existing entry + external_methods_remove(package, generic, signature) tbl <- S7_methods_table(package) append1(tbl) <- list( diff --git a/R/generic.R b/R/generic.R index abef58ac..0ad3574c 100644 --- a/R/generic.R +++ b/R/generic.R @@ -226,7 +226,8 @@ generic_add_method <- function(generic, signature, method) { } p_tbl <- tbl } else { - if (!is.null(p_tbl[[class_name]])) { + existing <- p_tbl[[class_name]] + if (!is.null(existing) && !identical(existing, method)) { message("Overwriting method ", method_name(generic, signature)) } p_tbl[[class_name]] <- method diff --git a/R/hooks.R b/R/hooks.R index da966524..3bb52431 100644 --- a/R/hooks.R +++ b/R/hooks.R @@ -1,7 +1,7 @@ #' Package hooks for S7 methods #' #' @description -#' When using S7 in a package, add two hooks to your `zzz.R`: +#' When using S7 in a package, add three hooks to your `zzz.R`: #' #' * Call `S7_on_load()` from `.onLoad()`. This is S7's way of #' registering methods, rather than using `NAMESPACE` directives like S3 and @@ -11,6 +11,13 @@ #' packages, but there's no harm in always including it and it ensures you #' won't forget later. #' +#' * Call `S7_on_unload()` from `.onUnload()`. This undoes the work of +#' `S7_on_load()`: it unregisters the methods that your package registered +#' for S7 generics in other packages and removes any hooks that +#' `S7_on_load()` added. This matters mostly during development, where it +#' ensures that reloading your package (e.g. with `devtools::load_all()`) +#' doesn't leave stale methods behind. +#' #' * Call `S7_on_build()` at the top level (i.e. *not* inside `.onLoad()`) #' after all method registration is complete. This avoids embedding copies #' of external generics in your package when you use `method<-`. @@ -21,12 +28,15 @@ #' See `vignette("packages")` for more details. #' #' @importFrom utils getFromNamespace packageName -#' @returns Nothing; both functions are called for their side-effects. +#' @returns Nothing; these functions are called for their side-effects. #' @examples #' # In zzz.R: #' .onLoad <- function(...) { #' S7::S7_on_load() #' } +#' .onUnload <- function(...) { +#' S7::S7_on_unload() +#' } #' S7::S7_on_build() #' @export S7_on_load <- function() { @@ -46,8 +56,12 @@ S7_on_load_ <- function(env) { tbl <- S7_methods_table(package) + # Remove any hooks left behind by a previous load of this package + registrar_hooks_remove(tbl, package) + for (x in tbl) { register <- registrar(x$generic, x$signature, x$method, ns) + attr(register, "S7_package") <- package if (isNamespaceLoaded(x$generic$package)) { register() @@ -58,6 +72,56 @@ S7_on_load_ <- function(env) { invisible() } +#' @export +#' @rdname S7_on_load +S7_on_unload <- function() { + S7_on_unload_(parent.frame()) +} + +S7_on_unload_ <- function(env) { + package <- packageName(env) + + tbl <- S7_methods_table(package) + registrar_hooks_remove(tbl, package) + + for (x in tbl) { + if (!isNamespaceLoaded(x$generic$package)) { + next + } + + generic <- get0( + x$generic$name, + envir = asNamespace(x$generic$package), + inherits = FALSE + ) + # Methods registered for S3 and S4 generics can't be unregistered + if (is_S7_generic(generic)) { + unregister_S7_method(generic, x$signature) + } + } + + invisible() +} + +# Remove the hooks that S7_on_load_() added on behalf of `package`, +# identified by their "S7_package" attribute. +registrar_hooks_remove <- function(tbl, package) { + pkgs <- unique(vcapply(tbl, function(x) x$generic$package)) + + for (pkg in pkgs) { + event <- packageEvent(pkg, "onLoad") + hooks <- getHook(event) + ours <- vlapply(hooks, function(hook) { + identical(attr(hook, "S7_package", TRUE), package) + }) + if (any(ours)) { + setHook(event, hooks[!ours], action = "replace") + } + } + + invisible() +} + #' @export #' @rdname S7_on_load S7_on_build <- function() { diff --git a/man/S7_on_load.Rd b/man/S7_on_load.Rd index 80321a48..13a587d9 100644 --- a/man/S7_on_load.Rd +++ b/man/S7_on_load.Rd @@ -3,6 +3,7 @@ \name{S7_on_load} \alias{S7_on_load} \alias{methods_register} +\alias{S7_on_unload} \alias{S7_on_build} \title{Package hooks for S7 methods} \usage{ @@ -10,13 +11,15 @@ S7_on_load() methods_register() +S7_on_unload() + S7_on_build() } \value{ -Nothing; both functions are called for their side-effects. +Nothing; these functions are called for their side-effects. } \description{ -When using S7 in a package, add two hooks to your \code{zzz.R}: +When using S7 in a package, add three hooks to your \code{zzz.R}: \itemize{ \item Call \code{S7_on_load()} from \code{.onLoad()}. This is S7's way of registering methods, rather than using \code{NAMESPACE} directives like S3 and @@ -25,6 +28,12 @@ other packages are registered as needed when your package is loaded. This is only strictly necessary if you register methods for generics in other packages, but there's no harm in always including it and it ensures you won't forget later. +\item Call \code{S7_on_unload()} from \code{.onUnload()}. This undoes the work of +\code{S7_on_load()}: it unregisters the methods that your package registered +for S7 generics in other packages and removes any hooks that +\code{S7_on_load()} added. This matters mostly during development, where it +ensures that reloading your package (e.g. with \code{devtools::load_all()}) +doesn't leave stale methods behind. \item Call \code{S7_on_build()} at the top level (i.e. \emph{not} inside \code{.onLoad()}) after all method registration is complete. This avoids embedding copies of external generics in your package when you use \verb{method<-}. @@ -40,5 +49,8 @@ See \code{vignette("packages")} for more details. .onLoad <- function(...) { S7::S7_on_load() } +.onUnload <- function(...) { + S7::S7_on_unload() +} S7::S7_on_build() } diff --git a/tests/testthat/_snaps/method-register.md b/tests/testthat/_snaps/method-register.md index 0b971e64..b4e4c400 100644 --- a/tests/testthat/_snaps/method-register.md +++ b/tests/testthat/_snaps/method-register.md @@ -2,7 +2,7 @@ Code method(foo, class_character) <- (function(x) "c") - method(foo, class_character) <- (function(x) "c") + method(foo, class_character) <- (function(x) "C") Message Overwriting method foo() diff --git a/tests/testthat/test-external-generic.R b/tests/testthat/test-external-generic.R index c4710908..f1fd4f6d 100644 --- a/tests/testthat/test-external-generic.R +++ b/tests/testthat/test-external-generic.R @@ -18,6 +18,17 @@ test_that("can get and append methods", { ) }) +test_that("re-adding a method replaces the existing entry", { + external_methods_reset("S7") + on.exit(external_methods_reset("S7"), add = TRUE) + + bar <- new_external_generic("foo", "bar", "x") + external_methods_add("S7", bar, list("A"), function() "a") + external_methods_add("S7", bar, list("A"), function() "b") + expect_length(S7_methods_table("S7"), 1) + expect_equal(S7_methods_table("S7")[[1]]$method(), "b") +}) + test_that("can remove methods", { external_methods_reset("S7") on.exit(external_methods_reset("S7"), add = TRUE) diff --git a/tests/testthat/test-hooks.R b/tests/testthat/test-hooks.R index ac34c955..b2f79937 100644 --- a/tests/testthat/test-hooks.R +++ b/tests/testthat/test-hooks.R @@ -1,3 +1,82 @@ +describe("S7_on_load()", { + it("doesn't accumulate hooks across repeated loads", { + external_methods_reset("S7") + on.exit(external_methods_reset("S7"), add = TRUE) + + Foo <- new_class("Foo") + Bar <- new_class("Bar") + external <- new_external_generic("S7", "convert", c("from", "to")) + external_methods_add( + "S7", + external, + new_signature(list(Foo, Bar)), + function(from, to, ...) "converted" + ) + on.exit( + unregister_S7_method(convert, new_signature(list(Foo, Bar))), + add = TRUE + ) + + ns <- asNamespace("S7") + n_hooks <- length(getHook(packageEvent("S7", "onLoad"))) + + S7_on_load_(ns) + S7_on_load_(ns) + expect_length(getHook(packageEvent("S7", "onLoad")), n_hooks + 1) + + S7_on_unload_(ns) + }) +}) + +describe("S7_on_unload()", { + it("unregisters methods and removes hooks", { + external_methods_reset("S7") + on.exit(external_methods_reset("S7"), add = TRUE) + + Foo <- new_class("Foo") + Bar <- new_class("Bar") + external <- new_external_generic("S7", "convert", c("from", "to")) + external_methods_add( + "S7", + external, + new_signature(list(Foo, Bar)), + function(from, to, ...) "converted" + ) + on.exit( + unregister_S7_method(convert, new_signature(list(Foo, Bar))), + add = TRUE + ) + + ns <- asNamespace("S7") + n_hooks <- length(getHook(packageEvent("S7", "onLoad"))) + + S7_on_load_(ns) + expect_length(getHook(packageEvent("S7", "onLoad")), n_hooks + 1) + expect_equal(convert(Foo(), Bar), "converted") + + S7_on_unload_(ns) + expect_length(getHook(packageEvent("S7", "onLoad")), n_hooks) + expect_null(convert@methods[["Foo"]][["Bar"]]) + }) + + it("unregisters methods when a real package is unloaded (#316)", { + skip_if(getRversion() < "4.1" && Sys.info()[["sysname"]] == "Windows") + skip_if(quick_test()) + + tmp_lib <- local_libpath() + local_install_and_attach(test_path("t0"), tmp_lib) + local_install_and_attach(test_path("t2"), tmp_lib) + + expect_equal(t0::an_s7_generic("x"), "foo") + + # t2's .onUnload() calls S7_on_unload(), which unregisters the methods + # it registered for t0's generics and removes its hooks for t1 + unloadNamespace("t2") + expect_null(t0::an_s7_generic@methods[["character"]]) + expect_length(getHook(packageEvent("t1", "onLoad")), 0) + }) +}) + describe("S7_on_build()", { it("removes only generic sentinels from the namespace", { ns <- new.env(parent = emptyenv()) diff --git a/tests/testthat/test-method-register.R b/tests/testthat/test-method-register.R index 993a160f..1a470bd6 100644 --- a/tests/testthat/test-method-register.R +++ b/tests/testthat/test-method-register.R @@ -10,11 +10,19 @@ describe("method registration", { foo := new_generic("x") expect_snapshot({ method(foo, class_character) <- function(x) "c" - method(foo, class_character) <- function(x) "c" + method(foo, class_character) <- function(x) "C" }) expect_length(methods(foo), 1) }) + it("re-registering an identical method is silent (#474)", { + foo <- new_generic("foo", "x") + fn <- function(x) "c" + method(foo, class_character) <- fn + expect_no_message(method(foo, class_character) <- fn) + expect_length(methods(foo), 1) + }) + it("adds method for each element of a union", { foo := new_generic("x") method(foo, class_numeric) <- function(x) "x" diff --git a/vignettes/packages.Rmd b/vignettes/packages.Rmd index 66f56598..027c770d 100644 --- a/vignettes/packages.Rmd +++ b/vignettes/packages.Rmd @@ -26,19 +26,25 @@ library(S7) First, add `S7` to the `Imports` field of your `DESCRIPTION`. We then recommend importing all S7 functions into your package `NAMESPACE` with `import(S7)`, or, if you're using roxygen2, `@import S7`. -Next, create a `zzz.R` with a `.onLoad()` that calls `S7_on_load()` and a top-level call to `S7_on_build()`: +Next, create a `zzz.R` with a `.onLoad()` that calls `S7_on_load()`, an `.onUnload()` that calls `S7_on_unload()`, and a top-level call to `S7_on_build()`: ```{r} .onLoad <- function(...) { S7::S7_on_load() } +.onUnload <- function(...) { + S7::S7_on_unload() +} + S7::S7_on_build() ``` `S7_on_load()` is S7's way of registering methods, rather than using export directives in your `NAMESPACE` like S3 and S4 do. This is only strictly necessary if you are registering methods for generics in other packages, but there's no harm in adding it and it ensures that you won't forget later. +`S7_on_unload()` undoes the work of `S7_on_load()`: it unregisters the methods that your package registered for generics in other packages and removes the hooks that `S7_on_load()` added, so unloading your package doesn't leave stale methods behind. + `S7_on_build()` cleans up after `method<-`. Because `method<-` is a replacement function, `method(generic, class) <- fun` is evaluated as `generic <- method<-(generic, class, fun)`, which would otherwise leave a copy of `generic` in your namespace. When `generic` belongs to another package, `method<-` returns a sentinel value instead of the generic, and `S7_on_build()` removes these sentinels from your namespace when the package is built. From 74754ff6ab84ae902eb5a04180d19a58cad6b19f Mon Sep 17 00:00:00 2001 From: Hadley Wickham Date: Tue, 16 Jun 2026 07:36:29 -0500 Subject: [PATCH 02/20] Polish --- R/external-generic.R | 4 ++-- R/hooks.R | 4 +--- man/S7_on_load.Rd | 4 +--- 3 files changed, 4 insertions(+), 8 deletions(-) diff --git a/R/external-generic.R b/R/external-generic.R index dc374d9e..597230ac 100644 --- a/R/external-generic.R +++ b/R/external-generic.R @@ -109,10 +109,10 @@ external_methods_reset <- function(package) { } external_methods_add <- function(package, generic, signature, method) { - # Re-registering a method replaces the existing entry + # Remove any existing entries external_methods_remove(package, generic, signature) - tbl <- S7_methods_table(package) + tbl <- S7_methods_table(package) append1(tbl) <- list( generic = generic, signature = signature, diff --git a/R/hooks.R b/R/hooks.R index 3bb52431..4a3f4855 100644 --- a/R/hooks.R +++ b/R/hooks.R @@ -14,9 +14,7 @@ #' * Call `S7_on_unload()` from `.onUnload()`. This undoes the work of #' `S7_on_load()`: it unregisters the methods that your package registered #' for S7 generics in other packages and removes any hooks that -#' `S7_on_load()` added. This matters mostly during development, where it -#' ensures that reloading your package (e.g. with `devtools::load_all()`) -#' doesn't leave stale methods behind. +#' `S7_on_load()` added. #' #' * Call `S7_on_build()` at the top level (i.e. *not* inside `.onLoad()`) #' after all method registration is complete. This avoids embedding copies diff --git a/man/S7_on_load.Rd b/man/S7_on_load.Rd index 13a587d9..d2c29f39 100644 --- a/man/S7_on_load.Rd +++ b/man/S7_on_load.Rd @@ -31,9 +31,7 @@ won't forget later. \item Call \code{S7_on_unload()} from \code{.onUnload()}. This undoes the work of \code{S7_on_load()}: it unregisters the methods that your package registered for S7 generics in other packages and removes any hooks that -\code{S7_on_load()} added. This matters mostly during development, where it -ensures that reloading your package (e.g. with \code{devtools::load_all()}) -doesn't leave stale methods behind. +\code{S7_on_load()} added. \item Call \code{S7_on_build()} at the top level (i.e. \emph{not} inside \code{.onLoad()}) after all method registration is complete. This avoids embedding copies of external generics in your package when you use \verb{method<-}. From 02f603c7d7f60dae75463dbb03bfac835606e59e Mon Sep 17 00:00:00 2001 From: Hadley Wickham Date: Tue, 16 Jun 2026 07:38:59 -0500 Subject: [PATCH 03/20] Better hook restoration --- tests/testthat/helper.R | 6 ++++++ tests/testthat/test-hooks.R | 6 ++---- 2 files changed, 8 insertions(+), 4 deletions(-) diff --git a/tests/testthat/helper.R b/tests/testthat/helper.R index 56787f77..ac9a69a3 100644 --- a/tests/testthat/helper.R +++ b/tests/testthat/helper.R @@ -55,6 +55,12 @@ local_methods <- function(..., frame = parent.frame()) { invisible() } +local_external_methods <- function(package = "S7", frame = parent.frame()) { + old <- S7_methods_table(package) + defer(S7_methods_table(package) <- old, frame = frame) + invisible() +} + local_S4_class <- function( name, ..., diff --git a/tests/testthat/test-hooks.R b/tests/testthat/test-hooks.R index 70e56180..31ab55ce 100644 --- a/tests/testthat/test-hooks.R +++ b/tests/testthat/test-hooks.R @@ -1,6 +1,5 @@ test_that("S7_on_load() doesn't accumulate hooks across repeated loads", { - external_methods_reset("S7") - on.exit(external_methods_reset("S7"), add = TRUE) + local_external_methods() Foo := new_class() Bar := new_class() @@ -27,8 +26,7 @@ test_that("S7_on_load() doesn't accumulate hooks across repeated loads", { }) test_that("S7_on_unload() unregisters methods and removes hooks", { - external_methods_reset("S7") - on.exit(external_methods_reset("S7"), add = TRUE) + local_external_methods() Foo := new_class() Bar := new_class() From 36662ca09c1aa41ad28aab45fc67ac0aea7e1fad Mon Sep 17 00:00:00 2001 From: Hadley Wickham Date: Tue, 16 Jun 2026 07:44:52 -0500 Subject: [PATCH 04/20] Make hook class more explicit --- R/external-generic.R | 6 ++++-- R/hooks.R | 21 ++++++++++++++------- 2 files changed, 18 insertions(+), 9 deletions(-) diff --git a/R/external-generic.R b/R/external-generic.R index 597230ac..819b1eee 100644 --- a/R/external-generic.R +++ b/R/external-generic.R @@ -76,14 +76,15 @@ is_external_generic <- function(x) { inherits(x, "S7_external_generic") } -registrar <- function(generic, signature, method, env) { +registrar <- function(generic, signature, method, env, package) { # Force all arguments generic signature method env + package - function(...) { + fun <- function(...) { ns <- asNamespace(generic$package) if ( is.null(generic$version) || getNamespaceVersion(ns) >= generic$version @@ -101,6 +102,7 @@ registrar <- function(generic, signature, method, env) { } } } + S7_hook(fun, package) } external_methods_reset <- function(package) { diff --git a/R/hooks.R b/R/hooks.R index 4a3f4855..0aa4aa5d 100644 --- a/R/hooks.R +++ b/R/hooks.R @@ -58,8 +58,7 @@ S7_on_load_ <- function(env) { registrar_hooks_remove(tbl, package) for (x in tbl) { - register <- registrar(x$generic, x$signature, x$method, ns) - attr(register, "S7_package") <- package + register <- registrar(x$generic, x$signature, x$method, ns, package) if (isNamespaceLoaded(x$generic$package)) { register() @@ -101,17 +100,14 @@ S7_on_unload_ <- function(env) { invisible() } -# Remove the hooks that S7_on_load_() added on behalf of `package`, -# identified by their "S7_package" attribute. +# Remove the hooks that S7_on_load_() added on behalf of `package` registrar_hooks_remove <- function(tbl, package) { pkgs <- unique(vcapply(tbl, function(x) x$generic$package)) for (pkg in pkgs) { event <- packageEvent(pkg, "onLoad") hooks <- getHook(event) - ours <- vlapply(hooks, function(hook) { - identical(attr(hook, "S7_package", TRUE), package) - }) + ours <- vlapply(hooks, is_S7_hook, package = package) if (any(ours)) { setHook(event, hooks[!ours], action = "replace") } @@ -142,3 +138,14 @@ generic_sentinel <- function(generic) { } is_generic_sentinel <- function(x) inherits(x, "S7_generic_sentinel") + + +# Tag our hooks so we can remove later +S7_hook <- function(fun, package) { + attr(fun, "S7_package") <- package + class(fun) <- "S7_hook" + fun +} +is_S7_hook <- function(x, package) { + inherits(x, "S7_hook") && identical(attr(x, "S7_package", TRUE), package) +} From d1aa774bdc8880ff70cd60607cc6ae071a641d88 Mon Sep 17 00:00:00 2001 From: Hadley Wickham Date: Tue, 16 Jun 2026 08:37:41 -0500 Subject: [PATCH 05/20] Some more refactoring --- R/external-generic.R | 6 ++--- R/hooks.R | 52 ++++++++++++++++++++++++++++---------------- 2 files changed, 35 insertions(+), 23 deletions(-) diff --git a/R/external-generic.R b/R/external-generic.R index 819b1eee..597230ac 100644 --- a/R/external-generic.R +++ b/R/external-generic.R @@ -76,15 +76,14 @@ is_external_generic <- function(x) { inherits(x, "S7_external_generic") } -registrar <- function(generic, signature, method, env, package) { +registrar <- function(generic, signature, method, env) { # Force all arguments generic signature method env - package - fun <- function(...) { + function(...) { ns <- asNamespace(generic$package) if ( is.null(generic$version) || getNamespaceVersion(ns) >= generic$version @@ -102,7 +101,6 @@ registrar <- function(generic, signature, method, env, package) { } } } - S7_hook(fun, package) } external_methods_reset <- function(package) { diff --git a/R/hooks.R b/R/hooks.R index 0aa4aa5d..d2442ac5 100644 --- a/R/hooks.R +++ b/R/hooks.R @@ -49,22 +49,10 @@ methods_register <- function() { S7_on_load_ <- function(env) { package <- packageName(env) - ns <- topenv(env) - # TODO?: check/enforce that S7_on_load() is being called from .onLoad() - tbl <- S7_methods_table(package) - - # Remove any hooks left behind by a previous load of this package - registrar_hooks_remove(tbl, package) - - for (x in tbl) { - register <- registrar(x$generic, x$signature, x$method, ns, package) - - if (isNamespaceLoaded(x$generic$package)) { - register() - } - setHook(packageEvent(x$generic$package, "onLoad"), register) - } + hooks_remove(package) # always start from a clean slate + hooks <- hooks_add(package) + hooks_run_loaded(hooks) invisible() } @@ -77,10 +65,9 @@ S7_on_unload <- function() { S7_on_unload_ <- function(env) { package <- packageName(env) + hooks_remove(package) tbl <- S7_methods_table(package) - registrar_hooks_remove(tbl, package) - for (x in tbl) { if (!isNamespaceLoaded(x$generic$package)) { next @@ -100,8 +87,26 @@ S7_on_unload_ <- function(env) { invisible() } -# Remove the hooks that S7_on_load_() added on behalf of `package` -registrar_hooks_remove <- function(tbl, package) { +# Add a hook for each method that registers it when its generic's package is +# loaded. Returns the added hooks, named by the package they're attached to. +hooks_add <- function(package) { + ns <- asNamespace(package) + tbl <- S7_methods_table(package) + + hooks <- lapply(tbl, function(x) { + register <- registrar(x$generic, x$signature, x$method, ns) + hook <- S7_hook(register, package) + setHook(packageEvent(x$generic$package, "onLoad"), hook) + hook + }) + names(hooks) <- vcapply(tbl, function(x) x$generic$package) + hooks +} + +# Remove our hooks for `package`. Returns the removed hooks, named by the +# package they were attached to. +hooks_remove <- function(package) { + tbl <- S7_methods_table(package) pkgs <- unique(vcapply(tbl, function(x) x$generic$package)) for (pkg in pkgs) { @@ -112,7 +117,16 @@ registrar_hooks_remove <- function(tbl, package) { setHook(event, hooks[!ours], action = "replace") } } + invisible() +} +# onLoad hooks don't fire for packages that are already loaded, so fire our +# hooks now to register methods for any generic packages already available. +hooks_run_loaded <- function(hooks) { + is_loaded <- vlapply(names(hooks), isNamespaceLoaded) + for (hook in hooks[is_loaded]) { + hook() + } invisible() } From 3e654fefe9c5119949293a7fbfe81bec44af1b46 Mon Sep 17 00:00:00 2001 From: Hadley Wickham Date: Wed, 17 Jun 2026 08:02:06 -0500 Subject: [PATCH 06/20] Polishing --- R/hooks.R | 14 ++++---------- tests/testthat/test-external-generic.R | 13 +++++-------- 2 files changed, 9 insertions(+), 18 deletions(-) diff --git a/R/hooks.R b/R/hooks.R index d2442ac5..68f679b4 100644 --- a/R/hooks.R +++ b/R/hooks.R @@ -52,7 +52,7 @@ S7_on_load_ <- function(env) { hooks_remove(package) # always start from a clean slate hooks <- hooks_add(package) - hooks_run_loaded(hooks) + hooks_run_loaded(hooks) # run hooks for loaded packages invisible() } @@ -73,11 +73,8 @@ S7_on_unload_ <- function(env) { next } - generic <- get0( - x$generic$name, - envir = asNamespace(x$generic$package), - inherits = FALSE - ) + ns <- asNamespace(x$generic$package) + generic <- get0(x$generic$name, envir = ns, inherits = FALSE) # Methods registered for S3 and S4 generics can't be unregistered if (is_S7_generic(generic)) { unregister_S7_method(generic, x$signature) @@ -103,8 +100,7 @@ hooks_add <- function(package) { hooks } -# Remove our hooks for `package`. Returns the removed hooks, named by the -# package they were attached to. +# Remove our hooks for `package`. hooks_remove <- function(package) { tbl <- S7_methods_table(package) pkgs <- unique(vcapply(tbl, function(x) x$generic$package)) @@ -120,8 +116,6 @@ hooks_remove <- function(package) { invisible() } -# onLoad hooks don't fire for packages that are already loaded, so fire our -# hooks now to register methods for any generic packages already available. hooks_run_loaded <- function(hooks) { is_loaded <- vlapply(names(hooks), isNamespaceLoaded) for (hook in hooks[is_loaded]) { diff --git a/tests/testthat/test-external-generic.R b/tests/testthat/test-external-generic.R index f1fd4f6d..1c09f807 100644 --- a/tests/testthat/test-external-generic.R +++ b/tests/testthat/test-external-generic.R @@ -1,6 +1,5 @@ test_that("can get and append methods", { - external_methods_reset("S7") - on.exit(external_methods_reset("S7"), add = TRUE) + local_external_methods() expect_equal(S7_methods_table("S7"), list()) @@ -19,8 +18,7 @@ test_that("can get and append methods", { }) test_that("re-adding a method replaces the existing entry", { - external_methods_reset("S7") - on.exit(external_methods_reset("S7"), add = TRUE) + local_external_methods() bar <- new_external_generic("foo", "bar", "x") external_methods_add("S7", bar, list("A"), function() "a") @@ -30,8 +28,7 @@ test_that("re-adding a method replaces the existing entry", { }) test_that("can remove methods", { - external_methods_reset("S7") - on.exit(external_methods_reset("S7"), add = TRUE) + local_external_methods() bar <- new_external_generic("foo", "bar", "x") baz <- new_external_generic("foo", "baz", "x") @@ -49,9 +46,9 @@ test_that("can remove methods", { }) test_that("displays nicely", { - bar <- new_external_generic("foo", "bar", "x") - on.exit(external_methods_reset("S7"), add = TRUE) + local_external_methods() + bar <- new_external_generic("foo", "bar", "x") expect_snapshot({ print(bar) }) From b51f3d0af40a376dbb47556b6aa5186a31ce9bf2 Mon Sep 17 00:00:00 2001 From: Hadley Wickham Date: Wed, 17 Jun 2026 11:43:47 -0500 Subject: [PATCH 07/20] Better testing infrastructure --- tests/testthat/helper.R | 31 +++++++++++ tests/testthat/test-external-generic.R | 7 +-- tests/testthat/test-hooks.R | 74 +++++++++----------------- 3 files changed, 59 insertions(+), 53 deletions(-) diff --git a/tests/testthat/helper.R b/tests/testthat/helper.R index ac9a69a3..4982ca62 100644 --- a/tests/testthat/helper.R +++ b/tests/testthat/helper.R @@ -61,6 +61,37 @@ local_external_methods <- function(package = "S7", frame = parent.frame()) { invisible() } +# Simulate a package with namesapce +local_package <- function(name, ..., frame = parent.frame()) { + ns <- new.env(parent = asNamespace("S7")) + + info <- new.env(parent = emptyenv()) + info$spec <- c(name = name, version = "0.0.0") + ns[[".__NAMESPACE__."]] <- info + ns[[".packageName"]] <- name + ns[[".__S3MethodsTable__."]] <- new.env(parent = emptyenv()) + + # register namespace so asNamespace(pkg) works + internal <- get(".Internal", envir = baseenv()) + internal(registerNamespace(name, ns)) + defer(internal(unregisterNamespace(name)), frame = frame) + defer(S7_on_unload_(ns), frame = frame) + + for (expr in eval(substitute(alist(...)))) { + eval(expr, ns) + } + + ns +} + +# Filter out any IDE hooks added interactively (e.g. Positron registers an +# "ark_onload_hook" for every package), leaving only the hooks S7 manages. +package_hooks <- function(package, event = "onLoad") { + hooks <- getHook(packageEvent(package, event)) + is_ide_hook <- function(hook) any(startsWith(class(hook), "ark_")) + Filter(function(hook) !is_ide_hook(hook), hooks) +} + local_S4_class <- function( name, ..., diff --git a/tests/testthat/test-external-generic.R b/tests/testthat/test-external-generic.R index 1c09f807..be6cd660 100644 --- a/tests/testthat/test-external-generic.R +++ b/tests/testthat/test-external-generic.R @@ -55,13 +55,10 @@ test_that("displays nicely", { }) test_that("can convert existing generics to external", { - foo_S7 := new_generic("x") - env <- new.env() - env$.packageName <- "test" - environment(foo_S7) <- env + ns <- local_package("test", foo_S7 := new_generic("x")) expect_equal( - as_external_generic(foo_S7), + as_external_generic(ns$foo_S7), new_external_generic("test", "foo_S7", "x") ) diff --git a/tests/testthat/test-hooks.R b/tests/testthat/test-hooks.R index 31ab55ce..c2520953 100644 --- a/tests/testthat/test-hooks.R +++ b/tests/testthat/test-hooks.R @@ -1,57 +1,35 @@ test_that("S7_on_load() doesn't accumulate hooks across repeated loads", { - local_external_methods() - - Foo := new_class() - Bar := new_class() - external <- new_external_generic("S7", "convert", c("from", "to")) - external_methods_add( - "S7", - external, - new_signature(list(Foo, Bar)), - function(from, to, ...) "converted" - ) - on.exit( - unregister_S7_method(convert, new_signature(list(Foo, Bar))), - add = TRUE + upstream <- local_package("upstream", gen := new_generic("x")) + expect_length(package_hooks("upstream"), 0) + + downstream <- local_package( + "downstream", + Foo := new_class(), + gen := new_external_generic("upstream", dispatch_args = "x"), + method(gen, Foo) <- \(x) "dispatched" ) - - ns <- asNamespace("S7") - n_hooks <- length(getHook(packageEvent("S7", "onLoad"))) - - S7_on_load_(ns) - S7_on_load_(ns) - expect_length(getHook(packageEvent("S7", "onLoad")), n_hooks + 1) - - S7_on_unload_(ns) + S7_on_load_(downstream) + expect_length(package_hooks("upstream"), 1) + S7_on_load_(downstream) + expect_length(package_hooks("upstream"), 1) }) test_that("S7_on_unload() unregisters methods and removes hooks", { - local_external_methods() - - Foo := new_class() - Bar := new_class() - external <- new_external_generic("S7", "convert", c("from", "to")) - external_methods_add( - "S7", - external, - new_signature(list(Foo, Bar)), - function(from, to, ...) "converted" - ) - on.exit( - unregister_S7_method(convert, new_signature(list(Foo, Bar))), - add = TRUE + upstream <- local_package("upstream", gen := new_generic("x")) + downstream <- local_package( + "downstream", + Foo := new_class(), + gen := new_external_generic("upstream", dispatch_args = "x"), + method(gen, Foo) <- \(x) "dispatched" ) + S7_on_load_(downstream) - ns <- asNamespace("S7") - n_hooks <- length(getHook(packageEvent("S7", "onLoad"))) - - S7_on_load_(ns) - expect_length(getHook(packageEvent("S7", "onLoad")), n_hooks + 1) - expect_equal(convert(Foo(), Bar), "converted") - - S7_on_unload_(ns) - expect_length(getHook(packageEvent("S7", "onLoad")), n_hooks) - expect_null(convert@methods[["Foo"]][["Bar"]]) + S7_on_unload_(downstream) + expect_length(package_hooks("upstream"), 0) + expect_error( + upstream$gen(downstream$Foo()), + class = "S7_error_method_not_found" + ) }) test_that("S7_on_unload() unregisters methods when a real package is unloaded (#316)", { @@ -68,7 +46,7 @@ test_that("S7_on_unload() unregisters methods when a real package is unloaded (# # it registered for t0's generics and removes its hooks for t1 unloadNamespace("t2") expect_null(t0::an_s7_generic@methods[["character"]]) - expect_length(getHook(packageEvent("t1", "onLoad")), 0) + expect_length(package_hooks("t1"), 0) }) test_that("S7_on_build() removes only generic sentinels from the namespace", { From c2746240fd3e736d97c02f015506dea0bdb3a9d7 Mon Sep 17 00:00:00 2001 From: Hadley Wickham Date: Wed, 17 Jun 2026 12:05:29 -0500 Subject: [PATCH 08/20] Use helper in more places --- R/hooks.R | 2 +- tests/testthat/helper.R | 6 ---- tests/testthat/test-external-generic.R | 38 ++++++++++++-------------- 3 files changed, 19 insertions(+), 27 deletions(-) diff --git a/R/hooks.R b/R/hooks.R index 68f679b4..30afc09e 100644 --- a/R/hooks.R +++ b/R/hooks.R @@ -75,7 +75,7 @@ S7_on_unload_ <- function(env) { ns <- asNamespace(x$generic$package) generic <- get0(x$generic$name, envir = ns, inherits = FALSE) - # Methods registered for S3 and S4 generics can't be unregistered + # Methods registered for S3 and S4 generics can't be unregistered yet if (is_S7_generic(generic)) { unregister_S7_method(generic, x$signature) } diff --git a/tests/testthat/helper.R b/tests/testthat/helper.R index 4982ca62..912c657d 100644 --- a/tests/testthat/helper.R +++ b/tests/testthat/helper.R @@ -55,12 +55,6 @@ local_methods <- function(..., frame = parent.frame()) { invisible() } -local_external_methods <- function(package = "S7", frame = parent.frame()) { - old <- S7_methods_table(package) - defer(S7_methods_table(package) <- old, frame = frame) - invisible() -} - # Simulate a package with namesapce local_package <- function(name, ..., frame = parent.frame()) { ns <- new.env(parent = asNamespace("S7")) diff --git a/tests/testthat/test-external-generic.R b/tests/testthat/test-external-generic.R index be6cd660..3a423189 100644 --- a/tests/testthat/test-external-generic.R +++ b/tests/testthat/test-external-generic.R @@ -1,12 +1,12 @@ test_that("can get and append methods", { - local_external_methods() + local_package("testpkg") - expect_equal(S7_methods_table("S7"), list()) + expect_equal(S7_methods_table("testpkg"), list()) bar <- new_external_generic("foo", "bar", "x") - external_methods_add("S7", bar, list(), function() {}) + external_methods_add("testpkg", bar, list(), function() {}) expect_equal( - S7_methods_table("S7"), + S7_methods_table("testpkg"), list( list( generic = bar, @@ -18,36 +18,34 @@ test_that("can get and append methods", { }) test_that("re-adding a method replaces the existing entry", { - local_external_methods() + local_package("testpkg") bar <- new_external_generic("foo", "bar", "x") - external_methods_add("S7", bar, list("A"), function() "a") - external_methods_add("S7", bar, list("A"), function() "b") - expect_length(S7_methods_table("S7"), 1) - expect_equal(S7_methods_table("S7")[[1]]$method(), "b") + external_methods_add("testpkg", bar, list("A"), function() "a") + external_methods_add("testpkg", bar, list("A"), function() "b") + expect_length(S7_methods_table("testpkg"), 1) + expect_equal(S7_methods_table("testpkg")[[1]]$method(), "b") }) test_that("can remove methods", { - local_external_methods() + local_package("testpkg") bar <- new_external_generic("foo", "bar", "x") baz <- new_external_generic("foo", "baz", "x") - external_methods_add("S7", bar, list("A"), function() "a") - external_methods_add("S7", baz, list("B"), function() "b") - expect_length(S7_methods_table("S7"), 2) + external_methods_add("testpkg", bar, list("A"), function() "a") + external_methods_add("testpkg", baz, list("B"), function() "b") + expect_length(S7_methods_table("testpkg"), 2) - external_methods_remove("S7", bar, list("A")) - expect_length(S7_methods_table("S7"), 1) - expect_equal(S7_methods_table("S7")[[1]]$generic, baz) + external_methods_remove("testpkg", bar, list("A")) + expect_length(S7_methods_table("testpkg"), 1) + expect_equal(S7_methods_table("testpkg")[[1]]$generic, baz) # No-op when entry doesn't exist - external_methods_remove("S7", bar, list("A")) - expect_length(S7_methods_table("S7"), 1) + external_methods_remove("testpkg", bar, list("A")) + expect_length(S7_methods_table("testpkg"), 1) }) test_that("displays nicely", { - local_external_methods() - bar <- new_external_generic("foo", "bar", "x") expect_snapshot({ print(bar) From 56813a609395eea2fbcdc98f95f444bc30617f5a Mon Sep 17 00:00:00 2001 From: Hadley Wickham Date: Wed, 17 Jun 2026 12:07:12 -0500 Subject: [PATCH 09/20] Tweak vignette --- vignettes/packages.Rmd | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/vignettes/packages.Rmd b/vignettes/packages.Rmd index 027c770d..f23e07c0 100644 --- a/vignettes/packages.Rmd +++ b/vignettes/packages.Rmd @@ -43,7 +43,7 @@ S7::S7_on_build() `S7_on_load()` is S7's way of registering methods, rather than using export directives in your `NAMESPACE` like S3 and S4 do. This is only strictly necessary if you are registering methods for generics in other packages, but there's no harm in adding it and it ensures that you won't forget later. -`S7_on_unload()` undoes the work of `S7_on_load()`: it unregisters the methods that your package registered for generics in other packages and removes the hooks that `S7_on_load()` added, so unloading your package doesn't leave stale methods behind. +`S7_on_unload()` undoes the work of `S7_on_load()`: it unregisters the methods and removes hooks, so unloading your package doesn't leave stale state behind. `S7_on_build()` cleans up after `method<-`. Because `method<-` is a replacement function, `method(generic, class) <- fun` is evaluated as `generic <- method<-(generic, class, fun)`, which would otherwise leave a copy of `generic` in your namespace. From 09dfb7aabce6b4975d0b3238282b9aa3bb1bf170 Mon Sep 17 00:00:00 2001 From: Hadley Wickham Date: Wed, 17 Jun 2026 12:07:38 -0500 Subject: [PATCH 10/20] Tweak news --- NEWS.md | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/NEWS.md b/NEWS.md index 7c175b01..39e1ec83 100644 --- a/NEWS.md +++ b/NEWS.md @@ -43,7 +43,7 @@ * `S7_error_method_not_found` now has a correct class vector without a duplicate `"error"` entry (@jjjermiah, #604). * `S7_inherits()` and `check_is_S7()` now accept any class specification (S7 class, S7 union, S3 class, S4 class, or base type wrapper like `class_integer`), not just S7 classes (#556). * `S7_on_load()` is the new name for `methods_register()`, giving it a nicer symmetry with `S7_on_build()`; `methods_register()` remains available for backward compatibility (#615). It no longer accumulates duplicate registration hooks when a package is loaded repeatedly (#316). -* New `S7_on_unload()`, to be called from `.onUnload()`, unregisters the methods that your package registered for S7 generics in other packages and removes the hooks that `S7_on_load()` added (#316). +* New `S7_on_unload()`, to be called from `.onUnload()`, reverts the changes made by `S7_on_load()` (#316). * `set_props()` now names its first argument `_object` to minimise the chances of a clash with a property (#423). It also accepts a single unnamed named list as a shortcut for splicing property values, making it easier to set properties programmatically (#497). * `str()` on S7 objects that inherit from data.frame (or other S3 classes whose underlying data has a `dim` attribute incompatible with the bare base type) no longer errors (#494). * `super()` now works with S3 and S4 objects, not just S7 objects (#500). From 21678add7a1bbfb9539fd33f500acd30f75f319a Mon Sep 17 00:00:00 2001 From: Tomasz Kalinowski Date: Wed, 17 Jun 2026 13:38:56 -0400 Subject: [PATCH 11/20] Fix external method unload ownership --- R/generic.R | 14 +++++++++ R/hooks.R | 39 +++++++++++++++++++++++-- tests/testthat/test-hooks.R | 57 +++++++++++++++++++++++++++++++++++++ 3 files changed, 107 insertions(+), 3 deletions(-) diff --git a/R/generic.R b/R/generic.R index 0ad3574c..a9f510b6 100644 --- a/R/generic.R +++ b/R/generic.R @@ -253,3 +253,17 @@ generic_remove_method <- function(generic, signature) { } invisible() } + +generic_get_method <- function(generic, signature) { + p_tbl <- generic@methods + chr_signature <- vcapply(signature, class_register) + + for (class_name in chr_signature) { + p_tbl <- p_tbl[[class_name]] + if (is.null(p_tbl)) { + return(NULL) + } + } + + p_tbl +} diff --git a/R/hooks.R b/R/hooks.R index 30afc09e..9d7f08b4 100644 --- a/R/hooks.R +++ b/R/hooks.R @@ -77,7 +77,7 @@ S7_on_unload_ <- function(env) { generic <- get0(x$generic$name, envir = ns, inherits = FALSE) # Methods registered for S3 and S4 generics can't be unregistered yet if (is_S7_generic(generic)) { - unregister_S7_method(generic, x$signature) + unregister_own_S7_method(generic, x$signature, x$method) } } @@ -89,6 +89,7 @@ S7_on_unload_ <- function(env) { hooks_add <- function(package) { ns <- asNamespace(package) tbl <- S7_methods_table(package) + pkgs <- vcapply(tbl, function(x) x$generic$package) hooks <- lapply(tbl, function(x) { register <- registrar(x$generic, x$signature, x$method, ns) @@ -96,14 +97,18 @@ hooks_add <- function(package) { setHook(packageEvent(x$generic$package, "onLoad"), hook) hook }) - names(hooks) <- vcapply(tbl, function(x) x$generic$package) + names(hooks) <- pkgs + hooks_packages(package) <- union(hooks_packages(package), pkgs) hooks } # Remove our hooks for `package`. hooks_remove <- function(package) { tbl <- S7_methods_table(package) - pkgs <- unique(vcapply(tbl, function(x) x$generic$package)) + pkgs <- unique(c( + hooks_packages(package), + vcapply(tbl, function(x) x$generic$package) + )) for (pkg in pkgs) { event <- packageEvent(pkg, "onLoad") @@ -113,6 +118,7 @@ hooks_remove <- function(package) { setHook(event, hooks[!ours], action = "replace") } } + hooks_packages(package) <- character() invisible() } @@ -157,3 +163,30 @@ S7_hook <- function(fun, package) { is_S7_hook <- function(x, package) { inherits(x, "S7_hook") && identical(attr(x, "S7_package", TRUE), package) } + +hooks_packages <- function(package) { + ns <- asNamespace(package) + tbl <- ns[[".__S3MethodsTable__."]] + attr(tbl, "S7hooks") %||% character() +} +`hooks_packages<-` <- function(package, value) { + ns <- asNamespace(package) + tbl <- ns[[".__S3MethodsTable__."]] + attr(tbl, "S7hooks") <- value + invisible() +} + +unregister_own_S7_method <- function(generic, signature, method) { + signatures <- flatten_signature(signature) + for (sig in signatures) { + current <- generic_get_method(generic, sig) + own <- S7_method(method, generic = generic, signature = sig) + if (is.null(attr(own, "name", TRUE))) { + attr(own, "name") <- as.name(method_signature(generic, sig)) + } + if (identical(current, own)) { + generic_remove_method(generic, sig) + } + } + invisible() +} diff --git a/tests/testthat/test-hooks.R b/tests/testthat/test-hooks.R index c2520953..e53b3a81 100644 --- a/tests/testthat/test-hooks.R +++ b/tests/testthat/test-hooks.R @@ -32,6 +32,63 @@ test_that("S7_on_unload() unregisters methods and removes hooks", { ) }) +test_that("S7_on_unload() doesn't remove methods registered by another package", { + upstream <- local_package("upstream_conflict", gen := new_generic("x")) + first <- local_package( + "downstream_first", + .onLoad <- function(...) S7_on_load(), + .onUnload <- function(...) S7_on_unload(), + gen := new_external_generic("upstream_conflict", dispatch_args = "x"), + method(gen, class_character) <- function(x) "first" + ) + first$.onLoad() + expect_equal(upstream$gen("x"), "first") + + second <- NULL + expect_message( + second <- local_package( + "downstream_second", + .onLoad <- function(...) S7_on_load(), + .onUnload <- function(...) S7_on_unload(), + gen := new_external_generic("upstream_conflict", dispatch_args = "x"), + method(gen, class_character) <- function(x) "second" + ), + "Overwriting method" + ) + second$.onLoad() + expect_equal(upstream$gen("x"), "second") + + first$.onUnload() + expect_equal(upstream$gen("x"), "second") +}) + +test_that("S7_on_load() removes hooks for deleted external methods", { + upstream <- local_package("upstream_deleted", gen := new_generic("x")) + downstream <- local_package( + "downstream_deleted", + .onLoad <- function(...) S7_on_load(), + .onUnload <- function(...) S7_on_unload(), + Foo := new_class(), + gen := new_external_generic("upstream_deleted", dispatch_args = "x"), + method(gen, Foo) <- function(x) "dispatched" + ) + downstream$.onLoad() + expect_length(package_hooks("upstream_deleted"), 1) + + eval(quote(method(gen, Foo) <- NULL), downstream) + expect_error( + upstream$gen(downstream$Foo()), + class = "S7_error_method_not_found" + ) + + downstream$.onLoad() + expect_length(package_hooks("upstream_deleted"), 0) + expect_error( + upstream$gen(downstream$Foo()), + class = "S7_error_method_not_found" + ) +}) + test_that("S7_on_unload() unregisters methods when a real package is unloaded (#316)", { skip_if(getRversion() < "4.1" && Sys.info()[["sysname"]] == "Windows") skip_if(quick_test()) From c1c9e6dec2025e39f5b72b2f27fac508b58bf2b3 Mon Sep 17 00:00:00 2001 From: Tomasz Kalinowski Date: Wed, 17 Jun 2026 13:48:35 -0400 Subject: [PATCH 12/20] Restore overwritten S7 methods on unload --- R/hooks.R | 34 ++++++++++++++++++++++++++++------ tests/testthat/test-hooks.R | 30 ++++++++++++++++++++++++++++++ 2 files changed, 58 insertions(+), 6 deletions(-) diff --git a/R/hooks.R b/R/hooks.R index 9d7f08b4..7bd78fb4 100644 --- a/R/hooks.R +++ b/R/hooks.R @@ -77,7 +77,10 @@ S7_on_unload_ <- function(env) { generic <- get0(x$generic$name, envir = ns, inherits = FALSE) # Methods registered for S3 and S4 generics can't be unregistered yet if (is_S7_generic(generic)) { - unregister_own_S7_method(generic, x$signature, x$method) + removed <- unregister_own_S7_method(generic, x$signature, x$method) + if (removed) { + hooks_restore_loaded(x$generic$package) + } } } @@ -124,8 +127,22 @@ hooks_remove <- function(package) { hooks_run_loaded <- function(hooks) { is_loaded <- vlapply(names(hooks), isNamespaceLoaded) - for (hook in hooks[is_loaded]) { - hook() + hooks_run(hooks[is_loaded]) +} + +hooks_restore_loaded <- function(package) { + hooks <- getHook(packageEvent(package, "onLoad")) + hooks <- hooks[vlapply(hooks, is_S7_hook)] + hooks_run(hooks, quiet = TRUE) +} + +hooks_run <- function(hooks, quiet = FALSE) { + for (hook in hooks) { + if (quiet) { + suppressMessages(hook()) + } else { + hook() + } } invisible() } @@ -160,8 +177,11 @@ S7_hook <- function(fun, package) { class(fun) <- "S7_hook" fun } -is_S7_hook <- function(x, package) { - inherits(x, "S7_hook") && identical(attr(x, "S7_package", TRUE), package) +is_S7_hook <- function(x, package = NULL) { + if (!inherits(x, "S7_hook")) { + return(FALSE) + } + is.null(package) || identical(attr(x, "S7_package", TRUE), package) } hooks_packages <- function(package) { @@ -178,6 +198,7 @@ hooks_packages <- function(package) { unregister_own_S7_method <- function(generic, signature, method) { signatures <- flatten_signature(signature) + removed <- FALSE for (sig in signatures) { current <- generic_get_method(generic, sig) own <- S7_method(method, generic = generic, signature = sig) @@ -186,7 +207,8 @@ unregister_own_S7_method <- function(generic, signature, method) { } if (identical(current, own)) { generic_remove_method(generic, sig) + removed <- TRUE } } - invisible() + invisible(removed) } diff --git a/tests/testthat/test-hooks.R b/tests/testthat/test-hooks.R index e53b3a81..2e306048 100644 --- a/tests/testthat/test-hooks.R +++ b/tests/testthat/test-hooks.R @@ -62,6 +62,36 @@ test_that("S7_on_unload() doesn't remove methods registered by another package", expect_equal(upstream$gen("x"), "second") }) +test_that("S7_on_unload() restores overwritten methods from another package", { + upstream <- local_package("upstream_restore", gen := new_generic("x")) + first <- local_package( + "downstream_restore_first", + .onLoad <- function(...) S7_on_load(), + .onUnload <- function(...) S7_on_unload(), + gen := new_external_generic("upstream_restore", dispatch_args = "x"), + method(gen, class_character) <- function(x) "first" + ) + first$.onLoad() + expect_equal(upstream$gen("x"), "first") + + second <- NULL + expect_message( + second <- local_package( + "downstream_restore_second", + .onLoad <- function(...) S7_on_load(), + .onUnload <- function(...) S7_on_unload(), + gen := new_external_generic("upstream_restore", dispatch_args = "x"), + method(gen, class_character) <- function(x) "second" + ), + "Overwriting method" + ) + second$.onLoad() + expect_equal(upstream$gen("x"), "second") + + second$.onUnload() + expect_equal(upstream$gen("x"), "first") +}) + test_that("S7_on_load() removes hooks for deleted external methods", { upstream <- local_package("upstream_deleted", gen := new_generic("x")) downstream <- local_package( From d761f073bfd73ab31ab75c5c46e82f76f6e4f523 Mon Sep 17 00:00:00 2001 From: Tomasz Kalinowski Date: Wed, 17 Jun 2026 14:02:55 -0400 Subject: [PATCH 13/20] Restore upstream S7 methods on unload --- R/external-generic.R | 74 +++++++++++++++++++++++++++++++++++-- R/hooks.R | 25 +++++++++---- R/method-register.R | 27 ++++++++++++-- tests/testthat/test-hooks.R | 22 +++++++++++ 4 files changed, 135 insertions(+), 13 deletions(-) diff --git a/R/external-generic.R b/R/external-generic.R index 597230ac..ac41b4a6 100644 --- a/R/external-generic.R +++ b/R/external-generic.R @@ -97,6 +97,22 @@ registrar <- function(generic, signature, method, env) { warning(msg, call. = FALSE) } else { generic_fun <- get(generic$name, envir = ns, inherits = FALSE) + if (is_S7_generic(generic_fun)) { + previous <- external_methods_capture_previous( + generic, + signature, + method, + generic_fun + ) + if (!is.null(previous)) { + external_methods_set_previous( + packageName(env), + generic, + signature, + previous + ) + } + } register_method(generic_fun, signature, method, env, package = NULL) } } @@ -108,16 +124,27 @@ external_methods_reset <- function(package) { invisible() } -external_methods_add <- function(package, generic, signature, method) { +external_methods_add <- function( + package, + generic, + signature, + method, + previous = NULL +) { # Remove any existing entries external_methods_remove(package, generic, signature) - tbl <- S7_methods_table(package) - append1(tbl) <- list( + entry <- list( generic = generic, signature = signature, method = method ) + if (!is.null(previous)) { + entry$previous <- previous + } + + tbl <- S7_methods_table(package) + append1(tbl) <- entry S7_methods_table(package) <- tbl invisible() @@ -136,6 +163,47 @@ external_methods_remove <- function(package, generic, signature) { invisible() } +external_methods_capture_previous <- function(generic, signature, method, generic_fun) { + signatures <- flatten_signature(signature) + previous <- vector("list", length(signatures)) + found <- FALSE + + for (i in seq_along(signatures)) { + sig <- signatures[[i]] + current <- generic_get_method(generic_fun, sig) + own <- S7_method_for_signature(method, generic_fun, sig) + + if ( + is_S7_method_from_package(current, generic$package) && + !identical(current, own) + ) { + previous[[i]] <- current + found <- TRUE + } + } + + if (found) previous else NULL +} + +external_methods_set_previous <- function(package, generic, signature, previous) { + tbl <- S7_methods_table(package) + for (i in seq_along(tbl)) { + x <- tbl[[i]] + if (identical(x$generic, generic) && identical(x$signature, signature)) { + tbl[[i]]$previous <- previous + S7_methods_table(package) <- tbl + return(invisible()) + } + } + + invisible() +} + +is_S7_method_from_package <- function(method, package) { + inherits(method, "S7_method") && + identical(packageName(environment(method)), package) +} + # Store external methods in an attribute of the S3 methods table since # this mutable object is present in all packages. diff --git a/R/hooks.R b/R/hooks.R index 7bd78fb4..447f79b5 100644 --- a/R/hooks.R +++ b/R/hooks.R @@ -77,7 +77,12 @@ S7_on_unload_ <- function(env) { generic <- get0(x$generic$name, envir = ns, inherits = FALSE) # Methods registered for S3 and S4 generics can't be unregistered yet if (is_S7_generic(generic)) { - removed <- unregister_own_S7_method(generic, x$signature, x$method) + removed <- unregister_own_S7_method( + generic, + x$signature, + x$method, + x$previous + ) if (removed) { hooks_restore_loaded(x$generic$package) } @@ -196,17 +201,23 @@ hooks_packages <- function(package) { invisible() } -unregister_own_S7_method <- function(generic, signature, method) { +unregister_own_S7_method <- function( + generic, + signature, + method, + previous = NULL +) { signatures <- flatten_signature(signature) removed <- FALSE - for (sig in signatures) { + for (i in seq_along(signatures)) { + sig <- signatures[[i]] current <- generic_get_method(generic, sig) - own <- S7_method(method, generic = generic, signature = sig) - if (is.null(attr(own, "name", TRUE))) { - attr(own, "name") <- as.name(method_signature(generic, sig)) - } + own <- S7_method_for_signature(method, generic, sig) if (identical(current, own)) { generic_remove_method(generic, sig) + if (length(previous) >= i && !is.null(previous[[i]])) { + generic_add_method(generic, sig, previous[[i]]) + } removed <- TRUE } } diff --git a/R/method-register.R b/R/method-register.R index 6d2ee4c3..7987d8d2 100644 --- a/R/method-register.R +++ b/R/method-register.R @@ -85,6 +85,20 @@ register_method <- function( ) } + external <- NULL + previous <- NULL + if (!is.null(package) && !is_local_generic(generic, package)) { + external <- as_external_generic(generic, env) + if (is_S7_generic(generic)) { + previous <- external_methods_capture_previous( + external, + signature, + method, + generic + ) + } + } + # Register in current session signatures <- flatten_signature(signature) if (is_S7_generic(generic)) { @@ -105,8 +119,7 @@ register_method <- function( # if we're inside a package, we also need to be able register methods # when the package is loaded if (!is.null(package) && !is_local_generic(generic, package)) { - external <- as_external_generic(generic, env) - external_methods_add(package, external, signature, method) + external_methods_add(package, external, signature, method, previous) return(generic_sentinel(external)) } @@ -163,12 +176,20 @@ register_S7_method <- function( name = method_name(generic, signature), call = call ) - method <- S7_method(method, generic = generic, signature = signature) + method <- S7_method_for_signature(method, generic, signature) generic_add_method(generic, signature, method) invisible() } +S7_method_for_signature <- function(method, generic, signature) { + method <- S7_method(method, generic = generic, signature = signature) + if (is.null(attr(method, "name", TRUE))) { + attr(method, "name") <- as.name(method_signature(generic, signature)) + } + method +} + unregister_S7_method <- function(generic, signature) { signatures <- flatten_signature(signature) for (signature in signatures) { diff --git a/tests/testthat/test-hooks.R b/tests/testthat/test-hooks.R index 2e306048..f434a248 100644 --- a/tests/testthat/test-hooks.R +++ b/tests/testthat/test-hooks.R @@ -92,6 +92,28 @@ test_that("S7_on_unload() restores overwritten methods from another package", { expect_equal(upstream$gen("x"), "first") }) +test_that("S7_on_unload() restores overwritten methods from the generic package", { + upstream <- local_package( + "upstream_restore_local", + gen := new_generic("x"), + method(gen, class_character) <- function(x) "upstream" + ) + expect_equal(upstream$gen("x"), "upstream") + + downstream <- local_package( + "downstream_restore_local", + .onLoad <- function(...) S7_on_load(), + .onUnload <- function(...) S7_on_unload(), + gen := new_external_generic("upstream_restore_local", dispatch_args = "x"), + method(gen, class_character) <- function(x) "downstream" + ) + downstream$.onLoad() + expect_equal(upstream$gen("x"), "downstream") + + downstream$.onUnload() + expect_equal(upstream$gen("x"), "upstream") +}) + test_that("S7_on_load() removes hooks for deleted external methods", { upstream <- local_package("upstream_deleted", gen := new_generic("x")) downstream <- local_package( From e98c28d4440b2e84966b2ba11f7018629f748a9f Mon Sep 17 00:00:00 2001 From: Tomasz Kalinowski Date: Wed, 17 Jun 2026 14:14:02 -0400 Subject: [PATCH 14/20] Preserve external method restoration chains --- R/external-generic.R | 80 ++++++++++++++++++++++++++++++++++--- tests/testthat/test-hooks.R | 69 ++++++++++++++++++++++++++++++++ 2 files changed, 144 insertions(+), 5 deletions(-) diff --git a/R/external-generic.R b/R/external-generic.R index ac41b4a6..d073caff 100644 --- a/R/external-generic.R +++ b/R/external-generic.R @@ -131,6 +131,9 @@ external_methods_add <- function( method, previous = NULL ) { + existing <- external_methods_find(package, generic, signature) + previous <- external_methods_merge_previous(previous, existing$previous) + # Remove any existing entries external_methods_remove(package, generic, signature) @@ -150,6 +153,33 @@ external_methods_add <- function( invisible() } +external_methods_find <- function(package, generic, signature) { + tbl <- S7_methods_table(package) + for (x in tbl) { + if (identical(x$generic, generic) && identical(x$signature, signature)) { + return(x) + } + } + + NULL +} + +external_methods_merge_previous <- function(previous, existing) { + if (is.null(previous)) { + return(existing) + } + if (is.null(existing)) { + return(previous) + } + + n <- max(length(previous), length(existing)) + length(previous) <- n + length(existing) <- n + missing <- vlapply(previous, is.null) + previous[missing] <- existing[missing] + previous +} + external_methods_remove <- function(package, generic, signature) { tbl <- S7_methods_table(package) if (length(tbl) == 0) { @@ -173,11 +203,9 @@ external_methods_capture_previous <- function(generic, signature, method, generi current <- generic_get_method(generic_fun, sig) own <- S7_method_for_signature(method, generic_fun, sig) - if ( - is_S7_method_from_package(current, generic$package) && - !identical(current, own) - ) { - previous[[i]] <- current + restored <- external_method_restoration(current, generic, sig, generic_fun) + if (!identical(current, own) && !is.null(restored)) { + previous[[i]] <- restored found <- TRUE } } @@ -199,6 +227,48 @@ external_methods_set_previous <- function(package, generic, signature, previous) invisible() } +external_method_restoration <- function(method, generic, signature, generic_fun) { + if (is.null(method)) { + return(NULL) + } + if (is_S7_method_from_package(method, generic$package)) { + return(method) + } + + package <- packageName(environment(method)) + if (is.null(package) || !isNamespaceLoaded(package)) { + return(NULL) + } + + tbl <- S7_methods_table(package) + for (x in tbl) { + if (!external_generics_match(x$generic, generic)) { + next + } + + signatures <- flatten_signature(x$signature) + for (i in seq_along(signatures)) { + sig <- signatures[[i]] + own <- S7_method_for_signature(x$method, generic_fun, sig) + if ( + identical(signature, sig) && + identical(method, own) && + length(x$previous) >= i + ) { + return(x$previous[[i]]) + } + } + } + + NULL +} + +external_generics_match <- function(x, y) { + identical(x$package, y$package) && + identical(x$name, y$name) && + identical(x$dispatch_args, y$dispatch_args) +} + is_S7_method_from_package <- function(method, package) { inherits(method, "S7_method") && identical(packageName(environment(method)), package) diff --git a/tests/testthat/test-hooks.R b/tests/testthat/test-hooks.R index f434a248..78557c94 100644 --- a/tests/testthat/test-hooks.R +++ b/tests/testthat/test-hooks.R @@ -114,6 +114,75 @@ test_that("S7_on_unload() restores overwritten methods from the generic package" expect_equal(upstream$gen("x"), "upstream") }) +test_that("S7_on_unload() preserves restoration after repeated registration", { + upstream <- local_package( + "upstream_restore_reregister", + gen := new_generic("x"), + method(gen, class_character) <- function(x) "upstream" + ) + downstream <- local_package( + "downstream_restore_reregister", + .onLoad <- function(...) S7_on_load(), + .onUnload <- function(...) S7_on_unload(), + gen := new_external_generic( + "upstream_restore_reregister", + dispatch_args = "x" + ), + method(gen, class_character) <- function(x) "downstream" + ) + expect_equal(upstream$gen("x"), "downstream") + + expect_message( + eval( + quote(method(gen, class_character) <- function(x) "downstream again"), + downstream + ), + "Overwriting method" + ) + expect_equal(upstream$gen("x"), "downstream again") + + downstream$.onUnload() + expect_equal(upstream$gen("x"), "upstream") +}) + +test_that("S7_on_unload() preserves restoration across unload order", { + upstream <- local_package( + "upstream_restore_chain", + gen := new_generic("x"), + method(gen, class_character) <- function(x) "upstream" + ) + first <- local_package( + "downstream_restore_chain_first", + .onLoad <- function(...) S7_on_load(), + .onUnload <- function(...) S7_on_unload(), + gen := new_external_generic("upstream_restore_chain", dispatch_args = "x"), + method(gen, class_character) <- function(x) "first" + ) + expect_equal(upstream$gen("x"), "first") + + second <- NULL + expect_message( + second <- local_package( + "downstream_restore_chain_second", + .onLoad <- function(...) S7_on_load(), + .onUnload <- function(...) S7_on_unload(), + gen := new_external_generic( + "upstream_restore_chain", + dispatch_args = "x" + ), + method(gen, class_character) <- function(x) "second" + ), + "Overwriting method" + ) + expect_equal(upstream$gen("x"), "second") + + first$.onUnload() + expect_equal(upstream$gen("x"), "second") + + second$.onUnload() + expect_equal(upstream$gen("x"), "upstream") +}) + test_that("S7_on_load() removes hooks for deleted external methods", { upstream <- local_package("upstream_deleted", gen := new_generic("x")) downstream <- local_package( From a1c147bf76055b1ae5b73d8e4ba81dd216190246 Mon Sep 17 00:00:00 2001 From: Tomasz Kalinowski Date: Wed, 17 Jun 2026 14:27:32 -0400 Subject: [PATCH 15/20] Fix external method unload restoration --- R/external-generic.R | 2 +- R/hooks.R | 4 +++ tests/testthat/test-hooks.R | 66 +++++++++++++++++++++++++++++++++++++ 3 files changed, 71 insertions(+), 1 deletion(-) diff --git a/R/external-generic.R b/R/external-generic.R index d073caff..444d8bff 100644 --- a/R/external-generic.R +++ b/R/external-generic.R @@ -218,7 +218,7 @@ external_methods_set_previous <- function(package, generic, signature, previous) for (i in seq_along(tbl)) { x <- tbl[[i]] if (identical(x$generic, generic) && identical(x$signature, signature)) { - tbl[[i]]$previous <- previous + tbl[[i]]$previous <- external_methods_merge_previous(previous, x$previous) S7_methods_table(package) <- tbl return(invisible()) } diff --git a/R/hooks.R b/R/hooks.R index 447f79b5..62ad3a39 100644 --- a/R/hooks.R +++ b/R/hooks.R @@ -75,6 +75,10 @@ S7_on_unload_ <- function(env) { ns <- asNamespace(x$generic$package) generic <- get0(x$generic$name, envir = ns, inherits = FALSE) + if (is.null(generic)) { + next + } + generic <- as_generic(generic) # Methods registered for S3 and S4 generics can't be unregistered yet if (is_S7_generic(generic)) { removed <- unregister_own_S7_method( diff --git a/tests/testthat/test-hooks.R b/tests/testthat/test-hooks.R index 78557c94..2c7a1f9c 100644 --- a/tests/testthat/test-hooks.R +++ b/tests/testthat/test-hooks.R @@ -32,6 +32,26 @@ test_that("S7_on_unload() unregisters methods and removes hooks", { ) }) +test_that("S7_on_unload() unregisters base operator methods", { + local_methods(base_ops[["+"]]) + + downstream <- local_package( + "downstream_base_ops_unload", + .onLoad <- function(...) S7_on_load(), + .onUnload <- function(...) S7_on_unload(), + Foo := new_class(), + method(`+`, list(Foo, Foo)) <- function(e1, e2) "dispatched" + ) + downstream$.onLoad() + expect_equal(downstream$Foo() + downstream$Foo(), "dispatched") + + downstream$.onUnload() + expect_error( + downstream$Foo() + downstream$Foo(), + class = "S7_error_method_not_found" + ) +}) + test_that("S7_on_unload() doesn't remove methods registered by another package", { upstream <- local_package("upstream_conflict", gen := new_generic("x")) first <- local_package( @@ -183,6 +203,52 @@ test_that("S7_on_unload() preserves restoration across unload order", { expect_equal(upstream$gen("x"), "upstream") }) +test_that("S7_on_unload() preserves union restorations after partial overwrite", { + upstream <- local_package( + "upstream_restore_union", + gen := new_generic("x"), + method(gen, class_character) <- function(x) "upstream-character", + method(gen, class_integer) <- function(x) "upstream-integer" + ) + first <- local_package( + "downstream_restore_union_first", + .onLoad <- function(...) S7_on_load(), + .onUnload <- function(...) S7_on_unload(), + gen := new_external_generic("upstream_restore_union", dispatch_args = "x"), + method(gen, new_union(class_character, class_integer)) <- + function(x) "first" + ) + first$.onLoad() + expect_equal(upstream$gen("x"), "first") + expect_equal(upstream$gen(1L), "first") + + second <- NULL + expect_message( + second <- local_package( + "downstream_restore_union_second", + .onLoad <- function(...) S7_on_load(), + .onUnload <- function(...) S7_on_unload(), + gen := new_external_generic( + "upstream_restore_union", + dispatch_args = "x" + ), + method(gen, class_character) <- function(x) "second" + ), + "Overwriting method" + ) + second$.onLoad() + expect_equal(upstream$gen("x"), "second") + expect_equal(upstream$gen(1L), "first") + + expect_message(first$.onLoad(), "Overwriting method") + expect_equal(upstream$gen("x"), "first") + expect_equal(upstream$gen(1L), "first") + + first$.onUnload() + expect_equal(upstream$gen("x"), "second") + expect_equal(upstream$gen(1L), "upstream-integer") +}) + test_that("S7_on_load() removes hooks for deleted external methods", { upstream <- local_package("upstream_deleted", gen := new_generic("x")) downstream <- local_package( From 81962afb7920c79eac0aa9628047d8c1daef1167 Mon Sep 17 00:00:00 2001 From: Tomasz Kalinowski Date: Wed, 17 Jun 2026 14:39:30 -0400 Subject: [PATCH 16/20] Fix external method unload edge cases --- R/external-generic.R | 48 ++++++++++++++++++++++++++++++------- R/hooks.R | 12 +++++++--- R/method-register.R | 34 +++++++++++++++++++++----- tests/testthat/test-hooks.R | 47 ++++++++++++++++++++++++++++++++++++ 4 files changed, 123 insertions(+), 18 deletions(-) diff --git a/R/external-generic.R b/R/external-generic.R index 444d8bff..1c7a50bc 100644 --- a/R/external-generic.R +++ b/R/external-generic.R @@ -76,6 +76,18 @@ is_external_generic <- function(x) { inherits(x, "S7_external_generic") } +external_generic_available <- function(generic) { + is_external_generic(generic) && + isNamespaceLoaded(generic$package) && + external_generic_version_ok(generic, asNamespace(generic$package)) +} + +external_generic_version_ok <- function(generic, ns) { + stopifnot(is_external_generic(generic), is.environment(ns)) + + is.null(generic$version) || getNamespaceVersion(ns) >= generic$version +} + registrar <- function(generic, signature, method, env) { # Force all arguments generic @@ -85,9 +97,7 @@ registrar <- function(generic, signature, method, env) { function(...) { ns <- asNamespace(generic$package) - if ( - is.null(generic$version) || getNamespaceVersion(ns) >= generic$version - ) { + if (external_generic_version_ok(generic, ns)) { if (!exists(generic$name, envir = ns, inherits = FALSE)) { msg <- sprintf( "[S7] Failed to find generic %s() in package %s", @@ -102,7 +112,8 @@ registrar <- function(generic, signature, method, env) { generic, signature, method, - generic_fun + generic_fun, + packageName(env) ) if (!is.null(previous)) { external_methods_set_previous( @@ -193,7 +204,13 @@ external_methods_remove <- function(package, generic, signature) { invisible() } -external_methods_capture_previous <- function(generic, signature, method, generic_fun) { +external_methods_capture_previous <- function( + generic, + signature, + method, + generic_fun, + package = NULL +) { signatures <- flatten_signature(signature) previous <- vector("list", length(signatures)) found <- FALSE @@ -201,7 +218,7 @@ external_methods_capture_previous <- function(generic, signature, method, generi for (i in seq_along(signatures)) { sig <- signatures[[i]] current <- generic_get_method(generic_fun, sig) - own <- S7_method_for_signature(method, generic_fun, sig) + own <- S7_method_for_signature(method, generic_fun, sig, package = package) restored <- external_method_restoration(current, generic, sig, generic_fun) if (!identical(current, own) && !is.null(restored)) { @@ -235,7 +252,7 @@ external_method_restoration <- function(method, generic, signature, generic_fun) return(method) } - package <- packageName(environment(method)) + package <- S7_method_package(method) if (is.null(package) || !isNamespaceLoaded(package)) { return(NULL) } @@ -249,7 +266,12 @@ external_method_restoration <- function(method, generic, signature, generic_fun) signatures <- flatten_signature(x$signature) for (i in seq_along(signatures)) { sig <- signatures[[i]] - own <- S7_method_for_signature(x$method, generic_fun, sig) + own <- S7_method_for_signature( + x$method, + generic_fun, + sig, + package = package + ) if ( identical(signature, sig) && identical(method, own) && @@ -271,7 +293,15 @@ external_generics_match <- function(x, y) { is_S7_method_from_package <- function(method, package) { inherits(method, "S7_method") && - identical(packageName(environment(method)), package) + identical(S7_method_package(method), package) +} + +S7_method_package <- function(method) { + if (!inherits(method, "S7_method")) { + return(NULL) + } + + attr(method, "S7_package", TRUE) %||% packageName(environment(method)) } # Store external methods in an attribute of the S3 methods table since diff --git a/R/hooks.R b/R/hooks.R index 62ad3a39..712d611c 100644 --- a/R/hooks.R +++ b/R/hooks.R @@ -74,6 +74,10 @@ S7_on_unload_ <- function(env) { } ns <- asNamespace(x$generic$package) + if (!external_generic_version_ok(x$generic, ns)) { + next + } + generic <- get0(x$generic$name, envir = ns, inherits = FALSE) if (is.null(generic)) { next @@ -85,7 +89,8 @@ S7_on_unload_ <- function(env) { generic, x$signature, x$method, - x$previous + x$previous, + package ) if (removed) { hooks_restore_loaded(x$generic$package) @@ -209,14 +214,15 @@ unregister_own_S7_method <- function( generic, signature, method, - previous = NULL + previous = NULL, + package = NULL ) { signatures <- flatten_signature(signature) removed <- FALSE for (i in seq_along(signatures)) { sig <- signatures[[i]] current <- generic_get_method(generic, sig) - own <- S7_method_for_signature(method, generic, sig) + own <- S7_method_for_signature(method, generic, sig, package = package) if (identical(current, own)) { generic_remove_method(generic, sig) if (length(previous) >= i && !is.null(previous[[i]])) { diff --git a/R/method-register.R b/R/method-register.R index 7987d8d2..20d52170 100644 --- a/R/method-register.R +++ b/R/method-register.R @@ -77,8 +77,9 @@ register_method <- function( original <- generic generic <- as_generic(generic, call = call) signature <- as_signature(signature, generic, call = call) + method_package <- packageName(env) - if (is_external_generic(generic) && isNamespaceLoaded(generic$package)) { + if (external_generic_available(generic)) { generic <- as_generic( getFromNamespace(generic$name, generic$package), call = call @@ -94,7 +95,8 @@ register_method <- function( external, signature, method, - generic + generic, + method_package ) } } @@ -103,7 +105,13 @@ register_method <- function( signatures <- flatten_signature(signature) if (is_S7_generic(generic)) { for (sig in signatures) { - register_S7_method(generic, sig, method, call = call) + register_S7_method( + generic, + sig, + method, + package = method_package, + call = call + ) } register_ops_bridge(generic, signatures, env) } else if (is_S3_generic(generic)) { @@ -137,7 +145,7 @@ unregister_method <- function( generic <- as_generic(generic, call = call) signature <- as_signature(signature, generic, call = call) - if (is_external_generic(generic) && isNamespaceLoaded(generic$package)) { + if (external_generic_available(generic)) { generic <- as_generic( getFromNamespace(generic$name, generic$package), call = call @@ -168,6 +176,7 @@ register_S7_method <- function( generic, signature, method, + package = NULL, call = sys.call(-1L) ) { check_method( @@ -176,17 +185,30 @@ register_S7_method <- function( name = method_name(generic, signature), call = call ) - method <- S7_method_for_signature(method, generic, signature) + method <- S7_method_for_signature( + method, + generic, + signature, + package = package + ) generic_add_method(generic, signature, method) invisible() } -S7_method_for_signature <- function(method, generic, signature) { +S7_method_for_signature <- function( + method, + generic, + signature, + package = NULL +) { method <- S7_method(method, generic = generic, signature = signature) if (is.null(attr(method, "name", TRUE))) { attr(method, "name") <- as.name(method_signature(generic, signature)) } + if (!is.null(package)) { + attr(method, "S7_package") <- package + } method } diff --git a/tests/testthat/test-hooks.R b/tests/testthat/test-hooks.R index 2c7a1f9c..b1a7952f 100644 --- a/tests/testthat/test-hooks.R +++ b/tests/testthat/test-hooks.R @@ -134,6 +134,31 @@ test_that("S7_on_unload() restores overwritten methods from the generic package" expect_equal(upstream$gen("x"), "upstream") }) +test_that("S7_on_unload() restores upstream methods from base functions", { + upstream <- local_package( + "upstream_restore_base_function", + gen := new_generic("x"), + method(gen, class_character) <- identity + ) + expect_equal(upstream$gen("x"), "x") + + downstream <- local_package( + "downstream_restore_base_function", + .onLoad <- function(...) S7_on_load(), + .onUnload <- function(...) S7_on_unload(), + gen := new_external_generic( + "upstream_restore_base_function", + dispatch_args = "x" + ), + method(gen, class_character) <- function(x) "downstream" + ) + downstream$.onLoad() + expect_equal(upstream$gen("x"), "downstream") + + downstream$.onUnload() + expect_equal(upstream$gen("x"), "x") +}) + test_that("S7_on_unload() preserves restoration after repeated registration", { upstream <- local_package( "upstream_restore_reregister", @@ -276,6 +301,28 @@ test_that("S7_on_load() removes hooks for deleted external methods", { ) }) +test_that("S7_on_unload() honors external generic version gates", { + downstream <- local_package( + "downstream_version_gate_unload", + .onLoad <- function(...) S7_on_load(), + .onUnload <- function(...) S7_on_unload(), + gen := new_external_generic( + "upstream_version_gate_unload", + dispatch_args = "x", + version = "1.0.0" + ), + method(gen, class_character) <- function(x) "downstream" + ) + upstream <- local_package( + "upstream_version_gate_unload", + gen <- function(x) "not an S7 generic" + ) + + downstream$.onLoad() + expect_equal(upstream$gen("x"), "not an S7 generic") + expect_no_error(downstream$.onUnload()) +}) + test_that("S7_on_unload() unregisters methods when a real package is unloaded (#316)", { skip_if(getRversion() < "4.1" && Sys.info()[["sysname"]] == "Windows") skip_if(quick_test()) From e4695977a78733b8a9408e82975641e467ad46dc Mon Sep 17 00:00:00 2001 From: Tomasz Kalinowski Date: Wed, 17 Jun 2026 14:53:16 -0400 Subject: [PATCH 17/20] Restore session external methods on unload --- R/external-generic.R | 5 ++++- tests/testthat/test-hooks.R | 29 +++++++++++++++++++++++++++++ 2 files changed, 33 insertions(+), 1 deletion(-) diff --git a/R/external-generic.R b/R/external-generic.R index 1c7a50bc..08874be8 100644 --- a/R/external-generic.R +++ b/R/external-generic.R @@ -253,7 +253,10 @@ external_method_restoration <- function(method, generic, signature, generic_fun) } package <- S7_method_package(method) - if (is.null(package) || !isNamespaceLoaded(package)) { + if (is.null(package)) { + return(method) + } + if (!isNamespaceLoaded(package)) { return(NULL) } diff --git a/tests/testthat/test-hooks.R b/tests/testthat/test-hooks.R index b1a7952f..1ec8bd3d 100644 --- a/tests/testthat/test-hooks.R +++ b/tests/testthat/test-hooks.R @@ -134,6 +134,35 @@ test_that("S7_on_unload() restores overwritten methods from the generic package" expect_equal(upstream$gen("x"), "upstream") }) +test_that("S7_on_unload() restores overwritten methods from the session", { + upstream <- local_package("upstream_restore_session", gen := new_generic("x")) + local_methods(upstream$gen) + + session <- new.env(parent = globalenv()) + session$upstream <- upstream + eval( + quote(method(upstream$gen, class_character) <- function(x) "session"), + session + ) + expect_equal(upstream$gen("x"), "session") + + downstream <- local_package( + "downstream_restore_session", + .onLoad <- function(...) S7_on_load(), + .onUnload <- function(...) S7_on_unload(), + gen := new_external_generic( + "upstream_restore_session", + dispatch_args = "x" + ), + method(gen, class_character) <- function(x) "downstream" + ) + downstream$.onLoad() + expect_equal(upstream$gen("x"), "downstream") + + downstream$.onUnload() + expect_equal(upstream$gen("x"), "session") +}) + test_that("S7_on_unload() restores upstream methods from base functions", { upstream <- local_package( "upstream_restore_base_function", From 94549e25c217e0294e0931a691cba1b5422baeae Mon Sep 17 00:00:00 2001 From: Tomasz Kalinowski Date: Wed, 17 Jun 2026 15:28:19 -0400 Subject: [PATCH 18/20] Limit unload cleanup to active methods --- NEWS.md | 2 +- R/external-generic.R | 156 +-------------------------- R/hooks.R | 40 ++----- R/method-register.R | 12 +-- man/S7_on_load.Rd | 8 +- tests/testthat/test-hooks.R | 209 +----------------------------------- vignettes/packages.Rmd | 2 +- 7 files changed, 21 insertions(+), 408 deletions(-) diff --git a/NEWS.md b/NEWS.md index 39e1ec83..3f154556 100644 --- a/NEWS.md +++ b/NEWS.md @@ -43,7 +43,7 @@ * `S7_error_method_not_found` now has a correct class vector without a duplicate `"error"` entry (@jjjermiah, #604). * `S7_inherits()` and `check_is_S7()` now accept any class specification (S7 class, S7 union, S3 class, S4 class, or base type wrapper like `class_integer`), not just S7 classes (#556). * `S7_on_load()` is the new name for `methods_register()`, giving it a nicer symmetry with `S7_on_build()`; `methods_register()` remains available for backward compatibility (#615). It no longer accumulates duplicate registration hooks when a package is loaded repeatedly (#316). -* New `S7_on_unload()`, to be called from `.onUnload()`, reverts the changes made by `S7_on_load()` (#316). +* New `S7_on_unload()`, to be called from `.onUnload()`, unregisters active methods and removes hooks added by `S7_on_load()` (#316). * `set_props()` now names its first argument `_object` to minimise the chances of a clash with a property (#423). It also accepts a single unnamed named list as a shortcut for splicing property values, making it easier to set properties programmatically (#497). * `str()` on S7 objects that inherit from data.frame (or other S3 classes whose underlying data has a `dim` attribute incompatible with the bare base type) no longer errors (#494). * `super()` now works with S3 and S4 objects, not just S7 objects (#500). diff --git a/R/external-generic.R b/R/external-generic.R index 08874be8..fab97db3 100644 --- a/R/external-generic.R +++ b/R/external-generic.R @@ -107,23 +107,6 @@ registrar <- function(generic, signature, method, env) { warning(msg, call. = FALSE) } else { generic_fun <- get(generic$name, envir = ns, inherits = FALSE) - if (is_S7_generic(generic_fun)) { - previous <- external_methods_capture_previous( - generic, - signature, - method, - generic_fun, - packageName(env) - ) - if (!is.null(previous)) { - external_methods_set_previous( - packageName(env), - generic, - signature, - previous - ) - } - } register_method(generic_fun, signature, method, env, package = NULL) } } @@ -139,12 +122,8 @@ external_methods_add <- function( package, generic, signature, - method, - previous = NULL + method ) { - existing <- external_methods_find(package, generic, signature) - previous <- external_methods_merge_previous(previous, existing$previous) - # Remove any existing entries external_methods_remove(package, generic, signature) @@ -153,9 +132,6 @@ external_methods_add <- function( signature = signature, method = method ) - if (!is.null(previous)) { - entry$previous <- previous - } tbl <- S7_methods_table(package) append1(tbl) <- entry @@ -164,33 +140,6 @@ external_methods_add <- function( invisible() } -external_methods_find <- function(package, generic, signature) { - tbl <- S7_methods_table(package) - for (x in tbl) { - if (identical(x$generic, generic) && identical(x$signature, signature)) { - return(x) - } - } - - NULL -} - -external_methods_merge_previous <- function(previous, existing) { - if (is.null(previous)) { - return(existing) - } - if (is.null(existing)) { - return(previous) - } - - n <- max(length(previous), length(existing)) - length(previous) <- n - length(existing) <- n - missing <- vlapply(previous, is.null) - previous[missing] <- existing[missing] - previous -} - external_methods_remove <- function(package, generic, signature) { tbl <- S7_methods_table(package) if (length(tbl) == 0) { @@ -204,109 +153,6 @@ external_methods_remove <- function(package, generic, signature) { invisible() } -external_methods_capture_previous <- function( - generic, - signature, - method, - generic_fun, - package = NULL -) { - signatures <- flatten_signature(signature) - previous <- vector("list", length(signatures)) - found <- FALSE - - for (i in seq_along(signatures)) { - sig <- signatures[[i]] - current <- generic_get_method(generic_fun, sig) - own <- S7_method_for_signature(method, generic_fun, sig, package = package) - - restored <- external_method_restoration(current, generic, sig, generic_fun) - if (!identical(current, own) && !is.null(restored)) { - previous[[i]] <- restored - found <- TRUE - } - } - - if (found) previous else NULL -} - -external_methods_set_previous <- function(package, generic, signature, previous) { - tbl <- S7_methods_table(package) - for (i in seq_along(tbl)) { - x <- tbl[[i]] - if (identical(x$generic, generic) && identical(x$signature, signature)) { - tbl[[i]]$previous <- external_methods_merge_previous(previous, x$previous) - S7_methods_table(package) <- tbl - return(invisible()) - } - } - - invisible() -} - -external_method_restoration <- function(method, generic, signature, generic_fun) { - if (is.null(method)) { - return(NULL) - } - if (is_S7_method_from_package(method, generic$package)) { - return(method) - } - - package <- S7_method_package(method) - if (is.null(package)) { - return(method) - } - if (!isNamespaceLoaded(package)) { - return(NULL) - } - - tbl <- S7_methods_table(package) - for (x in tbl) { - if (!external_generics_match(x$generic, generic)) { - next - } - - signatures <- flatten_signature(x$signature) - for (i in seq_along(signatures)) { - sig <- signatures[[i]] - own <- S7_method_for_signature( - x$method, - generic_fun, - sig, - package = package - ) - if ( - identical(signature, sig) && - identical(method, own) && - length(x$previous) >= i - ) { - return(x$previous[[i]]) - } - } - } - - NULL -} - -external_generics_match <- function(x, y) { - identical(x$package, y$package) && - identical(x$name, y$name) && - identical(x$dispatch_args, y$dispatch_args) -} - -is_S7_method_from_package <- function(method, package) { - inherits(method, "S7_method") && - identical(S7_method_package(method), package) -} - -S7_method_package <- function(method) { - if (!inherits(method, "S7_method")) { - return(NULL) - } - - attr(method, "S7_package", TRUE) %||% packageName(environment(method)) -} - # Store external methods in an attribute of the S3 methods table since # this mutable object is present in all packages. diff --git a/R/hooks.R b/R/hooks.R index 712d611c..a9aaecee 100644 --- a/R/hooks.R +++ b/R/hooks.R @@ -11,10 +11,10 @@ #' packages, but there's no harm in always including it and it ensures you #' won't forget later. #' -#' * Call `S7_on_unload()` from `.onUnload()`. This undoes the work of -#' `S7_on_load()`: it unregisters the methods that your package registered -#' for S7 generics in other packages and removes any hooks that -#' `S7_on_load()` added. +#' * Call `S7_on_unload()` from `.onUnload()`. This cleans up after +#' `S7_on_load()`: it unregisters methods that your package registered for +#' S7 generics in other packages, if they are still active, and removes any +#' hooks that `S7_on_load()` added. #' #' * Call `S7_on_build()` at the top level (i.e. *not* inside `.onLoad()`) #' after all method registration is complete. This avoids embedding copies @@ -85,16 +85,12 @@ S7_on_unload_ <- function(env) { generic <- as_generic(generic) # Methods registered for S3 and S4 generics can't be unregistered yet if (is_S7_generic(generic)) { - removed <- unregister_own_S7_method( + unregister_own_S7_method( generic, x$signature, x$method, - x$previous, package ) - if (removed) { - hooks_restore_loaded(x$generic$package) - } } } @@ -141,22 +137,8 @@ hooks_remove <- function(package) { hooks_run_loaded <- function(hooks) { is_loaded <- vlapply(names(hooks), isNamespaceLoaded) - hooks_run(hooks[is_loaded]) -} - -hooks_restore_loaded <- function(package) { - hooks <- getHook(packageEvent(package, "onLoad")) - hooks <- hooks[vlapply(hooks, is_S7_hook)] - hooks_run(hooks, quiet = TRUE) -} - -hooks_run <- function(hooks, quiet = FALSE) { - for (hook in hooks) { - if (quiet) { - suppressMessages(hook()) - } else { - hook() - } + for (hook in hooks[is_loaded]) { + hook() } invisible() } @@ -214,22 +196,16 @@ unregister_own_S7_method <- function( generic, signature, method, - previous = NULL, package = NULL ) { signatures <- flatten_signature(signature) - removed <- FALSE for (i in seq_along(signatures)) { sig <- signatures[[i]] current <- generic_get_method(generic, sig) own <- S7_method_for_signature(method, generic, sig, package = package) if (identical(current, own)) { generic_remove_method(generic, sig) - if (length(previous) >= i && !is.null(previous[[i]])) { - generic_add_method(generic, sig, previous[[i]]) - } - removed <- TRUE } } - invisible(removed) + invisible() } diff --git a/R/method-register.R b/R/method-register.R index 20d52170..2afd6ea3 100644 --- a/R/method-register.R +++ b/R/method-register.R @@ -87,18 +87,8 @@ register_method <- function( } external <- NULL - previous <- NULL if (!is.null(package) && !is_local_generic(generic, package)) { external <- as_external_generic(generic, env) - if (is_S7_generic(generic)) { - previous <- external_methods_capture_previous( - external, - signature, - method, - generic, - method_package - ) - } } # Register in current session @@ -127,7 +117,7 @@ register_method <- function( # if we're inside a package, we also need to be able register methods # when the package is loaded if (!is.null(package) && !is_local_generic(generic, package)) { - external_methods_add(package, external, signature, method, previous) + external_methods_add(package, external, signature, method) return(generic_sentinel(external)) } diff --git a/man/S7_on_load.Rd b/man/S7_on_load.Rd index d2c29f39..7560b184 100644 --- a/man/S7_on_load.Rd +++ b/man/S7_on_load.Rd @@ -28,10 +28,10 @@ other packages are registered as needed when your package is loaded. This is only strictly necessary if you register methods for generics in other packages, but there's no harm in always including it and it ensures you won't forget later. -\item Call \code{S7_on_unload()} from \code{.onUnload()}. This undoes the work of -\code{S7_on_load()}: it unregisters the methods that your package registered -for S7 generics in other packages and removes any hooks that -\code{S7_on_load()} added. +\item Call \code{S7_on_unload()} from \code{.onUnload()}. This cleans up after +\code{S7_on_load()}: it unregisters methods that your package registered for +S7 generics in other packages, if they are still active, and removes any +hooks that \code{S7_on_load()} added. \item Call \code{S7_on_build()} at the top level (i.e. \emph{not} inside \code{.onLoad()}) after all method registration is complete. This avoids embedding copies of external generics in your package when you use \verb{method<-}. diff --git a/tests/testthat/test-hooks.R b/tests/testthat/test-hooks.R index 1ec8bd3d..66b84819 100644 --- a/tests/testthat/test-hooks.R +++ b/tests/testthat/test-hooks.R @@ -82,225 +82,26 @@ test_that("S7_on_unload() doesn't remove methods registered by another package", expect_equal(upstream$gen("x"), "second") }) -test_that("S7_on_unload() restores overwritten methods from another package", { - upstream <- local_package("upstream_restore", gen := new_generic("x")) - first <- local_package( - "downstream_restore_first", - .onLoad <- function(...) S7_on_load(), - .onUnload <- function(...) S7_on_unload(), - gen := new_external_generic("upstream_restore", dispatch_args = "x"), - method(gen, class_character) <- function(x) "first" - ) - first$.onLoad() - expect_equal(upstream$gen("x"), "first") - - second <- NULL - expect_message( - second <- local_package( - "downstream_restore_second", - .onLoad <- function(...) S7_on_load(), - .onUnload <- function(...) S7_on_unload(), - gen := new_external_generic("upstream_restore", dispatch_args = "x"), - method(gen, class_character) <- function(x) "second" - ), - "Overwriting method" - ) - second$.onLoad() - expect_equal(upstream$gen("x"), "second") - - second$.onUnload() - expect_equal(upstream$gen("x"), "first") -}) - -test_that("S7_on_unload() restores overwritten methods from the generic package", { +test_that("S7_on_unload() doesn't restore overwritten methods", { upstream <- local_package( - "upstream_restore_local", + "upstream_no_restore", gen := new_generic("x"), method(gen, class_character) <- function(x) "upstream" ) expect_equal(upstream$gen("x"), "upstream") downstream <- local_package( - "downstream_restore_local", - .onLoad <- function(...) S7_on_load(), - .onUnload <- function(...) S7_on_unload(), - gen := new_external_generic("upstream_restore_local", dispatch_args = "x"), - method(gen, class_character) <- function(x) "downstream" - ) - downstream$.onLoad() - expect_equal(upstream$gen("x"), "downstream") - - downstream$.onUnload() - expect_equal(upstream$gen("x"), "upstream") -}) - -test_that("S7_on_unload() restores overwritten methods from the session", { - upstream <- local_package("upstream_restore_session", gen := new_generic("x")) - local_methods(upstream$gen) - - session <- new.env(parent = globalenv()) - session$upstream <- upstream - eval( - quote(method(upstream$gen, class_character) <- function(x) "session"), - session - ) - expect_equal(upstream$gen("x"), "session") - - downstream <- local_package( - "downstream_restore_session", - .onLoad <- function(...) S7_on_load(), - .onUnload <- function(...) S7_on_unload(), - gen := new_external_generic( - "upstream_restore_session", - dispatch_args = "x" - ), - method(gen, class_character) <- function(x) "downstream" - ) - downstream$.onLoad() - expect_equal(upstream$gen("x"), "downstream") - - downstream$.onUnload() - expect_equal(upstream$gen("x"), "session") -}) - -test_that("S7_on_unload() restores upstream methods from base functions", { - upstream <- local_package( - "upstream_restore_base_function", - gen := new_generic("x"), - method(gen, class_character) <- identity - ) - expect_equal(upstream$gen("x"), "x") - - downstream <- local_package( - "downstream_restore_base_function", + "downstream_no_restore", .onLoad <- function(...) S7_on_load(), .onUnload <- function(...) S7_on_unload(), - gen := new_external_generic( - "upstream_restore_base_function", - dispatch_args = "x" - ), + gen := new_external_generic("upstream_no_restore", dispatch_args = "x"), method(gen, class_character) <- function(x) "downstream" ) downstream$.onLoad() expect_equal(upstream$gen("x"), "downstream") downstream$.onUnload() - expect_equal(upstream$gen("x"), "x") -}) - -test_that("S7_on_unload() preserves restoration after repeated registration", { - upstream <- local_package( - "upstream_restore_reregister", - gen := new_generic("x"), - method(gen, class_character) <- function(x) "upstream" - ) - downstream <- local_package( - "downstream_restore_reregister", - .onLoad <- function(...) S7_on_load(), - .onUnload <- function(...) S7_on_unload(), - gen := new_external_generic( - "upstream_restore_reregister", - dispatch_args = "x" - ), - method(gen, class_character) <- function(x) "downstream" - ) - expect_equal(upstream$gen("x"), "downstream") - - expect_message( - eval( - quote(method(gen, class_character) <- function(x) "downstream again"), - downstream - ), - "Overwriting method" - ) - expect_equal(upstream$gen("x"), "downstream again") - - downstream$.onUnload() - expect_equal(upstream$gen("x"), "upstream") -}) - -test_that("S7_on_unload() preserves restoration across unload order", { - upstream <- local_package( - "upstream_restore_chain", - gen := new_generic("x"), - method(gen, class_character) <- function(x) "upstream" - ) - first <- local_package( - "downstream_restore_chain_first", - .onLoad <- function(...) S7_on_load(), - .onUnload <- function(...) S7_on_unload(), - gen := new_external_generic("upstream_restore_chain", dispatch_args = "x"), - method(gen, class_character) <- function(x) "first" - ) - expect_equal(upstream$gen("x"), "first") - - second <- NULL - expect_message( - second <- local_package( - "downstream_restore_chain_second", - .onLoad <- function(...) S7_on_load(), - .onUnload <- function(...) S7_on_unload(), - gen := new_external_generic( - "upstream_restore_chain", - dispatch_args = "x" - ), - method(gen, class_character) <- function(x) "second" - ), - "Overwriting method" - ) - expect_equal(upstream$gen("x"), "second") - - first$.onUnload() - expect_equal(upstream$gen("x"), "second") - - second$.onUnload() - expect_equal(upstream$gen("x"), "upstream") -}) - -test_that("S7_on_unload() preserves union restorations after partial overwrite", { - upstream <- local_package( - "upstream_restore_union", - gen := new_generic("x"), - method(gen, class_character) <- function(x) "upstream-character", - method(gen, class_integer) <- function(x) "upstream-integer" - ) - first <- local_package( - "downstream_restore_union_first", - .onLoad <- function(...) S7_on_load(), - .onUnload <- function(...) S7_on_unload(), - gen := new_external_generic("upstream_restore_union", dispatch_args = "x"), - method(gen, new_union(class_character, class_integer)) <- - function(x) "first" - ) - first$.onLoad() - expect_equal(upstream$gen("x"), "first") - expect_equal(upstream$gen(1L), "first") - - second <- NULL - expect_message( - second <- local_package( - "downstream_restore_union_second", - .onLoad <- function(...) S7_on_load(), - .onUnload <- function(...) S7_on_unload(), - gen := new_external_generic( - "upstream_restore_union", - dispatch_args = "x" - ), - method(gen, class_character) <- function(x) "second" - ), - "Overwriting method" - ) - second$.onLoad() - expect_equal(upstream$gen("x"), "second") - expect_equal(upstream$gen(1L), "first") - - expect_message(first$.onLoad(), "Overwriting method") - expect_equal(upstream$gen("x"), "first") - expect_equal(upstream$gen(1L), "first") - - first$.onUnload() - expect_equal(upstream$gen("x"), "second") - expect_equal(upstream$gen(1L), "upstream-integer") + expect_error(upstream$gen("x"), class = "S7_error_method_not_found") }) test_that("S7_on_load() removes hooks for deleted external methods", { diff --git a/vignettes/packages.Rmd b/vignettes/packages.Rmd index f23e07c0..8988fcc9 100644 --- a/vignettes/packages.Rmd +++ b/vignettes/packages.Rmd @@ -43,7 +43,7 @@ S7::S7_on_build() `S7_on_load()` is S7's way of registering methods, rather than using export directives in your `NAMESPACE` like S3 and S4 do. This is only strictly necessary if you are registering methods for generics in other packages, but there's no harm in adding it and it ensures that you won't forget later. -`S7_on_unload()` undoes the work of `S7_on_load()`: it unregisters the methods and removes hooks, so unloading your package doesn't leave stale state behind. +`S7_on_unload()` cleans up after `S7_on_load()`: it unregisters methods that your package registered, if they are still active, and removes hooks, so unloading your package doesn't leave stale state behind. `S7_on_build()` cleans up after `method<-`. Because `method<-` is a replacement function, `method(generic, class) <- fun` is evaluated as `generic <- method<-(generic, class, fun)`, which would otherwise leave a copy of `generic` in your namespace. From 27603f38c6cfe783df429bcc7f67528b36595fb9 Mon Sep 17 00:00:00 2001 From: Tomasz Kalinowski Date: Wed, 17 Jun 2026 15:42:58 -0400 Subject: [PATCH 19/20] Document unload method ownership --- R/hooks.R | 2 ++ 1 file changed, 2 insertions(+) diff --git a/R/hooks.R b/R/hooks.R index a9aaecee..11d11396 100644 --- a/R/hooks.R +++ b/R/hooks.R @@ -203,6 +203,8 @@ unregister_own_S7_method <- function( sig <- signatures[[i]] current <- generic_get_method(generic, sig) own <- S7_method_for_signature(method, generic, sig, package = package) + # Unload only removes the method this package currently owns. It does not + # remember or restore any method that was overwritten during loading. if (identical(current, own)) { generic_remove_method(generic, sig) } From d6567f1632d0e89774b41731ee501ddd0dad6313 Mon Sep 17 00:00:00 2001 From: Tomasz Kalinowski Date: Wed, 17 Jun 2026 16:51:24 -0400 Subject: [PATCH 20/20] Remove unsupported unload restoration test --- tests/testthat/test-hooks.R | 22 ---------------------- 1 file changed, 22 deletions(-) diff --git a/tests/testthat/test-hooks.R b/tests/testthat/test-hooks.R index 66b84819..e48f1306 100644 --- a/tests/testthat/test-hooks.R +++ b/tests/testthat/test-hooks.R @@ -82,28 +82,6 @@ test_that("S7_on_unload() doesn't remove methods registered by another package", expect_equal(upstream$gen("x"), "second") }) -test_that("S7_on_unload() doesn't restore overwritten methods", { - upstream <- local_package( - "upstream_no_restore", - gen := new_generic("x"), - method(gen, class_character) <- function(x) "upstream" - ) - expect_equal(upstream$gen("x"), "upstream") - - downstream <- local_package( - "downstream_no_restore", - .onLoad <- function(...) S7_on_load(), - .onUnload <- function(...) S7_on_unload(), - gen := new_external_generic("upstream_no_restore", dispatch_args = "x"), - method(gen, class_character) <- function(x) "downstream" - ) - downstream$.onLoad() - expect_equal(upstream$gen("x"), "downstream") - - downstream$.onUnload() - expect_error(upstream$gen("x"), class = "S7_error_method_not_found") -}) - test_that("S7_on_load() removes hooks for deleted external methods", { upstream <- local_package("upstream_deleted", gen := new_generic("x")) downstream <- local_package(