Strip external generics on build

NAMESPACE

@@ -43,6 +43,7 @@ export(S7_data)
 export(S7_dispatch)
 export(S7_inherits)
 export(S7_object)
+export(S7_on_build)
 export(as_class)
 export(check_is_S7)
 export(class_Date)

NEWS.md

@@ -4,6 +4,7 @@
 * Method dispatch on `class_missing` now correctly handles missing arguments forwarded through a wrapper functions (#595).
 * `convert()` now falls back to the corresponding `as.*()` function (e.g. `as.character()`) when converting to a base type like `class_character` and no method or inheritance-based default applies, so `convert(1, class_character)` works out of the box (#472).
 * `convert()` no longer errors when `from` is a base or S3 object and `to` is an S7 class that inherits from `from`'s class. The base/S3 value is now passed as `.data` to the `to` constructor (#537).
+* `method<-` no longer embeds a copy of a generic owned by another package in your package namespace. Instead it returns a sentinel value that the new `S7_on_build()` removes from the namespace at build time; call `S7_on_build()` at the top level of `zzz.R` (see `vignette("packages")`) (#364).
 * `method<-` now accepts `NULL` to unregister an existing method, e.g. `method(foo, class_character) <- NULL` (#613).
 * `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).

R/external-generic.R

@@ -75,41 +75,6 @@ is_external_generic <- function(x) {
   inherits(x, "S7_external_generic")
 }
 
-#' Register methods in a package
-#'
-#' When using S7 in a package you should always call `methods_register()` when
-#' your package is loaded. This ensures that methods are registered as needed
-#' when you implement methods for generics (S3, S4, and S7) in other packages.
-#' (This is not strictly necessary if you only register methods for generics
-#' in your package, but it's better to include it and not need it than forget
-#' to include it and hit weird errors.)
-#'
-#' @importFrom utils getFromNamespace packageName
-#' @export
-#' @returns Nothing; called for its side-effects.
-#' @examples
-#' .onLoad <- function(...) {
-#'   S7::methods_register()
-#' }
-methods_register <- function() {
-  package <- packageName(parent.frame())
-  ns <- topenv(parent.frame())
-  # TODO?: check/enforce that methods_register() is being called from .onLoad()
-
-  tbl <- S7_methods_table(package)
-
-  for (x in tbl) {
-    register <- registrar(x$generic, x$signature, x$method, ns)
-
-    if (isNamespaceLoaded(x$generic$package)) {
-      register()
-    }
-    setHook(packageEvent(x$generic$package, "onLoad"), register)
-  }
-
-  invisible()
-}
-
 registrar <- function(generic, signature, method, env) {
   # Force all arguments
   generic

R/generic-spec.R

@@ -56,7 +56,9 @@ is_local_generic <- function(generic, package) {
     return(FALSE)
   }
 
-  generic_pkg <- package_name(generic)
+  # unwrap S3 generics
+  f <- if (is_S3_generic(generic)) generic$generic else generic
+  generic_pkg <- package_name(f)
   is.null(generic_pkg) || generic_pkg == package
 }
 

R/hooks.R

@@ -0,0 +1,69 @@
+#' Package hooks for S7 methods
+#'
+#' @description
+#' When using S7 in a package, add two hooks to your `zzz.R`:
+#'
+#' * Call `methods_register()` from `.onLoad()`. This is S7's way of
+#'   registering methods, rather than using `NAMESPACE` directives like S3 and
+#'   S4 do. It ensures that methods for generics (S3, S4, and S7) defined in
+#'   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.
+#'
+#' * 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<-`.
+#'
+#' See `vignette("packages")` for more details.
+#'
+#' @importFrom utils getFromNamespace packageName
+#' @returns Nothing; both functions are called for their side-effects.
+#' @examples
+#' # In zzz.R:
+#' .onLoad <- function(...) {
+#'   S7::methods_register()
+#' }
+#' S7::S7_on_build()
+#' @export
+methods_register <- function() {
+  package <- packageName(parent.frame())
+  ns <- topenv(parent.frame())
+  # TODO?: check/enforce that methods_register() is being called from .onLoad()
+
+  tbl <- S7_methods_table(package)
+
+  for (x in tbl) {
+    register <- registrar(x$generic, x$signature, x$method, ns)
+
+    if (isNamespaceLoaded(x$generic$package)) {
+      register()
+    }
+    setHook(packageEvent(x$generic$package, "onLoad"), register)
+  }
+
+  invisible()
+}
+
+#' @export
+#' @rdname methods_register
+S7_on_build <- function() {
+  strip_generic_sentinels(topenv(parent.frame()))
+}
+
+strip_generic_sentinels <- function(ns) {
+  for (name in ls(ns, all.names = TRUE)) {
+    if (is_generic_sentinel(get0(name, envir = ns, inherits = FALSE))) {
+      rm(list = name, envir = ns)
+    }
+  }
+  invisible()
+}
+
+generic_sentinel <- function(generic) {
+  external <- as_external_generic(generic)
+  class(external) <- c("S7_generic_sentinel", "S7_external_generic")
+  external
+}
+
+is_generic_sentinel <- function(x) inherits(x, "S7_generic_sentinel")

R/method-register.R

@@ -42,7 +42,12 @@
 #'   The same rules apply to S4 generics as S7 generics.
 #' @param value A function that implements the generic specification for the
 #'   given `signature`, or `NULL` to unregister an existing method.
-#' @returns The `generic`, invisibly.
+#' @returns Usually `generic`, invisibly.
+#'
+#'   When registering a method for a generic that lives in another package
+#'   (an external, S3, or S4 generic), returns a sentinel object instead, to
+#'   avoid embedding a copy of that generic in your package. See
+#'   `vignette("packages")` for details.
 #' @export
 #' @examples
 #' # Create a generic
@@ -65,7 +70,6 @@
   } else {
     register_method(generic, signature, value, env = parent.frame())
   }
-  invisible(generic)
 }
 
 register_method <- function(
@@ -76,6 +80,7 @@ register_method <- function(
   package = packageName(env),
   call = sys.call(-1L)
 ) {
+  original <- generic
   generic <- as_generic(generic, call = call)
   signature <- as_signature(signature, generic, call = call)
 
@@ -109,11 +114,12 @@ 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)) {
-    generic <- as_external_generic(generic)
-    external_methods_add(package, generic, signature, method)
+    external <- as_external_generic(generic)
+    external_methods_add(package, external, signature, method)
+    return(generic_sentinel(external))
   }
 
-  invisible(generic)
+  invisible(original)
 }
 
 unregister_method <- function(
@@ -123,6 +129,7 @@ unregister_method <- function(
   package = packageName(env),
   call = sys.call(-1L)
 ) {
+  original <- generic
   generic <- as_generic(generic, call = call)
   signature <- as_signature(signature, generic, call = call)
 
@@ -145,11 +152,12 @@ unregister_method <- function(
   # If we're inside a package, also remove from the deferred external
   # methods table so the method isn't re-registered on package load.
   if (!is.null(package) && !is_local_generic(generic, package)) {
-    generic <- as_external_generic(generic)
-    external_methods_remove(package, generic, signature)
+    external <- as_external_generic(generic)
+    external_methods_remove(package, external, signature)
+    return(generic_sentinel(external))
   }
 
-  invisible(generic)
+  invisible(original)
 }
 
 register_S3_method <- function(

tests/testthat/helper.R

@@ -28,6 +28,7 @@ quick_test <- function() {
   identical(Sys.getenv("R_TESTTHAT_QUICK", "false"), "true")
 }
 
+
 quick_test_disable <- function() {
   Sys.setenv("R_TESTTHAT_QUICK" = "false")
 }
@@ -60,6 +61,33 @@ local_S4_class <- function(name, ..., env = parent.frame()) {
   out
 }
 
+# Create a temporary library, prepend it to .libPaths(), and restore the
+# library paths and delete the temporary library when `frame` exits. Returns
+# the path to the temporary library.
+local_libpath <- function(frame = parent.frame()) {
+  lib <- tempfile()
+  dir.create(lib)
+  defer(unlink(lib, recursive = TRUE), frame = frame)
+
+  old <- .libPaths()
+  .libPaths(c(lib, old))
+  defer(.libPaths(old), frame = frame)
+  lib
+}
+
+# Install the package at `path` into `lib`, attach it, and detach (and unload)
+# it when `frame` exits. The package name is taken from `basename(path)`.
+local_install_and_attach <- function(path, lib, frame = parent.frame()) {
+  quick_install(path, lib)
+  package <- basename(path)
+  library(package, character.only = TRUE)
+  defer(
+    try(detach(paste0("package:", package), unload = TRUE), silent = TRUE),
+    frame = frame
+  )
+  invisible(package)
+}
+
 # Create an S3 generic in globalenv() so that `UseMethod()` can find methods
 # registered by S7 (which writes to the generic's environment's methods table).
 # Cleans up the generic and any registered methods on exit.

tests/testthat/t3/DESCRIPTION

@@ -0,0 +1,10 @@
+Package: t3
+Title: Test Provider Package With S3 and S4 Generics
+Version: 0.0.0.9000
+Authors@R:
+    person("Jim", "Hester", , "james.f.hester@gmail.com", role = c("aut", "cre"))
+Description: Defines an S3 generic and an S4 generic for other packages to
+    register S7 methods against.
+Imports: methods
+License: MIT + file LICENSE
+Encoding: UTF-8

tests/testthat/t3/NAMESPACE

@@ -0,0 +1,4 @@
+export(t3_s3)
+export(t3_s4)
+exportMethods(t3_s4)
+import(methods)

tests/testthat/t3/R/t3.R

@@ -0,0 +1,5 @@
+#' @export
+t3_s3 <- function(x) UseMethod("t3_s3")
+
+#' @export
+methods::setGeneric("t3_s4", function(x) standardGeneric("t3_s4"))

tests/testthat/t4/DESCRIPTION

@@ -0,0 +1,10 @@
+Package: t4
+Title: Test Consumer Registering Methods for Another Package's Generics
+Version: 0.0.0.9000
+Authors@R:
+    person("Jim", "Hester", , "james.f.hester@gmail.com", role = c("aut", "cre"))
+Description: Registers S7 methods for the S3 and S4 generics defined in t3,
+    exercising S7_on_build().
+Imports: S7, t3, methods
+License: MIT + file LICENSE
+Encoding: UTF-8

tests/testthat/t4/NAMESPACE

@@ -0,0 +1,4 @@
+export(t4_class)
+importFrom(t3, t3_s3)
+importFrom(t3, t3_s4)
+import(methods)

tests/testthat/t4/R/t4.R

@@ -0,0 +1,16 @@
+#' @export
+t4_class <- S7::new_class("t4_class", package = "t4")
+
+# Register an S7 method for an S3 generic defined in another package (t3).
+S7::method(t3_s3, t4_class) <- function(x) "s3-dispatch"
+
+# Register an S7 method for an S4 generic defined in another package (t3).
+S7::S4_register(t4_class)
+S7::method(t3_s4, t4_class) <- function(x) "s4-dispatch"
+
+.onLoad <- function(libname, pkgname) {
+  S7::S4_register(t4_class)
+  S7::methods_register()
+}
+
+S7::S7_on_build()