Merge pull request #422 from RConsortium/external-s3-generic

fix S3 method registration across packages

DESCRIPTION

@@ -36,6 +36,7 @@ Suggests:
     methods,
     rmarkdown,
     testthat (>= 3.2.0),
+    callr,
     tibble
 VignetteBuilder: 
     knitr

NEWS.md

@@ -1,16 +1,18 @@
 # S7 (development version)
 
-* `convert()` now provides a default method to transform a parent class instance 
+* Fixed S3 methods registration across packages (#422).
+
+* `convert()` now provides a default method to transform a parent class instance
   into a subclass, enabling class construction from a prototype (#444).
 
-* The default object constructor returned by `new_class()` has been updated. 
+* The default object constructor returned by `new_class()` has been updated.
   It now accepts lazy (promise) property defaults and includes dynamic properties
-  with a `setter` in the constructor. Additionally, all custom property setters 
-  are now consistently invoked by the default constructor. If you're using S7 in 
-  an R package, you'll need to re-document to ensure that your documentation 
+  with a `setter` in the constructor. Additionally, all custom property setters
+  are now consistently invoked by the default constructor. If you're using S7 in
+  an R package, you'll need to re-document to ensure that your documentation
   matches the updated usage (#438, #445).
 
-* Fixed an issue where a custom property `getter()` would infinitely recurse 
+* Fixed an issue where a custom property `getter()` would infinitely recurse
   when accessing itself (reported in #403, fixed in #406).
 
 * Property setting (via `prop<-` and `@<-`) rewritten in C for performance (#396).

R/aaa.R

@@ -7,3 +7,9 @@ new_function <- function(args = NULL,
                          env = asNamespace("S7")) {
   as.function.default(c(args, body) %||% list(NULL), env)
 }
+
+`append1<-` <- function (x, value) {
+  stopifnot(is.list(x) || identical(mode(x), mode(value)))
+  x[[length(x) + 1L]] <- value
+  x
+}

R/external-generic.R

@@ -47,7 +47,7 @@ as_external_generic <- function(x) {
   } else if (is_external_generic(x)) {
     x
   } else if (is_S3_generic(x)) {
-    pkg <- package_name(x)
+    pkg <- package_name(x$generic)
     new_external_generic(pkg, x$name, "__S3__")
   } else if (is_S4_generic(x)) {
     new_external_generic(x@package, as.vector(x@generic), x@signature)
@@ -88,10 +88,13 @@ is_external_generic <- function(x) {
 #' }
 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)
+    register <- registrar(x$generic, x$signature, x$method, ns)
 
     if (isNamespaceLoaded(x$generic$package)) {
       register()
@@ -103,9 +106,9 @@ methods_register <- function() {
   invisible()
 }
 
-registrar <- function(generic, signature, method) {
+registrar <- function(generic, signature, method, env) {
   # Force all arguments
-  list(generic, signature, method)
+  generic; signature; method; env;
 
   function(...) {
     ns <- asNamespace(generic$package)
@@ -115,7 +118,7 @@ registrar <- function(generic, signature, method) {
         warning(msg, call. = FALSE)
       } else {
         generic_fun <- get(generic$name, envir = ns, inherits = FALSE)
-        register_method(generic_fun, signature, method, package = NULL)
+        register_method(generic_fun, signature, method, env, package = NULL)
       }
     }
   }
@@ -129,12 +132,11 @@ external_methods_reset <- function(package) {
 external_methods_add <- function(package, generic, signature, method) {
   tbl <- S7_methods_table(package)
 
-  methods <- append(
-    tbl,
-    list(list(generic = generic, signature = signature, method = method))
-  )
+  append1(tbl) <- list(generic = generic,
+                       signature = signature,
+                       method = method)
 
-  S7_methods_table(package) <- methods
+  S7_methods_table(package) <- tbl
   invisible()
 }
 
@@ -144,7 +146,7 @@ external_methods_add <- function(package, generic, signature, method) {
 S7_methods_table <- function(package) {
   ns <- asNamespace(package)
   tbl <- ns[[".__S3MethodsTable__."]]
-  attr(tbl, "S7methods")
+  attr(tbl, "S7methods") %||% list()
 }
 `S7_methods_table<-` <- function(package, value) {
   ns <- asNamespace(package)

R/method-register.R

@@ -67,18 +67,17 @@ register_method <- function(generic,
   generic <- as_generic(generic)
   signature <- as_signature(signature, generic)
 
+
+  if (is_external_generic(generic) && isNamespaceLoaded(generic$package)) {
+    generic <- as_generic(getFromNamespace(generic$name, generic$package))
+  }
+
   # Register in current session
   if (is_S7_generic(generic)) {
     check_method(method, generic, name = method_name(generic, signature))
     register_S7_method(generic, signature, method)
-  } else if (is_external_generic(generic)) {
-    # Only register immediately if soft dependency is available
-    if (requireNamespace(generic$package, quietly = TRUE)) {
-      gen <- getFromNamespace(generic$name, asNamespace(generic$package))
-      register_method(gen, signature, method, package = NULL)
-    }
   } else if (is_S3_generic(generic)) {
-    register_S3_method(generic, signature, method)
+    register_S3_method(generic, signature, method, env)
   } else if (is_S4_generic(generic)) {
     register_S4_method(generic, signature, method, env)
   }
@@ -93,7 +92,7 @@ register_method <- function(generic,
   invisible(generic)
 }
 
-register_S3_method <- function(generic, signature, method) {
+register_S3_method <- function(generic, signature, method, envir = parent.frame()) {
   if (class_type(signature[[1]]) != "S7") {
     msg <- sprintf(
       "When registering methods for S3 generic %s(), signature must be an S7 class, not %s.",
@@ -102,8 +101,14 @@ register_S3_method <- function(generic, signature, method) {
     )
     stop(msg, call. = FALSE)
   }
+
+  if (is_external_generic(external_generic <- get0(generic$name, envir = envir))) {
+    envir <- asNamespace(external_generic$package)
+  }
+
   class <- S7_class_name(signature[[1]])
-  registerS3method(generic$name, class, method, envir = parent.frame())
+  # dbg(generic$name, class, method, envir)
+  registerS3method(generic$name, class, method, envir)
 }
 
 register_S7_method <- function(generic, signature, method) {

tests/testthat/helper.R

@@ -69,3 +69,58 @@ named_list <- function(...) {
   names(x) <- names2(x)
   x
 }
+
+
+dbg <- function(..., .display = utils::str) {
+  out <- NULL
+  exprs <- as.list(substitute(list(...)))[-1L]
+
+  for (i in seq_len(...length())) {
+    ..i <- as.symbol(sprintf("..%i", i))
+    if (eval(substitute(missing(..i)))) {
+      next
+    }
+
+    name <- names(exprs)[[i]]
+    expr <- deparse1(exprs[[i]])
+
+    label <- if (is.null(name)) {
+      sprintf("`%s`", expr)
+    } else {
+      sprintf("(%s) `%s`", name, expr)
+    }
+    cat(label, ": ", sep = "")
+    .display(out <- eval(..i))
+  }
+
+  cl <- sys.call()
+  filepath <- utils::getSrcFilename(cl)
+
+  if (length(filepath)) {
+    if (!file.exists(filepath) &&
+        file.exists(file.path("R", filepath))) {
+      filepath <- file.path("R", filepath)
+    }
+
+    lineno <- utils::getSrcLocation(cl)
+
+    if (isNamespaceLoaded("cli")) {
+      cli <- asNamespace("cli")
+      loc <- cli$col_grey(cli$style_hyperlink(
+        sprintf("(from %s:%i)", filepath, lineno),
+        sprintf("file://%s", normalizePath(filepath, mustWork = FALSE)),
+        params = c(line = lineno)
+      ))
+    } else {
+      loc <- sprintf("(from %s:%i)", filepath, lineno)
+    }
+
+    cat(loc, "\n")
+  } else {
+    cat(sprintf("(from call: %s (srcfile missing))\n", trimws(
+      deparse1(sys.call(-2), width.cutoff = 60)
+    )))
+  }
+
+  invisible(out)
+}

tests/testthat/t0/DESCRIPTION

@@ -15,4 +15,4 @@ License: MIT + file LICENSE
 Encoding: UTF-8
 LazyData: true
 Roxygen: list(markdown = TRUE)
-RoxygenNote: 7.1.1
+RoxygenNote: 7.3.2

tests/testthat/t0/NAMESPACE

@@ -1,3 +1,4 @@
 # Generated by roxygen2: do not edit by hand
 
-export(bar)
+export(an_s3_generic)
+export(an_s7_generic)

tests/testthat/t0/R/t0.R

@@ -0,0 +1,5 @@
+#' @export
+an_s7_generic <- S7::new_generic("an_s7_generic", "x")
+
+#' @export
+an_s3_generic <- function(x) UseMethod("an_s3_generic")

tests/testthat/t1/DESCRIPTION

@@ -15,4 +15,4 @@ License: MIT + file LICENSE
 Encoding: UTF-8
 LazyData: true
 Roxygen: list(markdown = TRUE)
-RoxygenNote: 7.1.1
+RoxygenNote: 7.3.2

tests/testthat/t1/NAMESPACE

@@ -1,3 +1,4 @@
 # Generated by roxygen2: do not edit by hand
 
-export(foo)
+export(another_s3_generic)
+export(another_s7_generic)

tests/testthat/t1/R/t1.R

@@ -0,0 +1,5 @@
+#' @export
+another_s7_generic <- S7::new_generic("another_s7_generic", "x")
+
+#' @export
+another_s3_generic <- function(x) UseMethod("another_s3_generic")

tests/testthat/t2/DESCRIPTION

@@ -16,4 +16,4 @@ License: MIT + file LICENSE
 Encoding: UTF-8
 LazyData: true
 Roxygen: list(markdown = TRUE)
-RoxygenNote: 7.1.1
+RoxygenNote: 7.3.2

tests/testthat/t2/NAMESPACE

@@ -1,3 +1,5 @@
 # Generated by roxygen2: do not edit by hand
 
-importFrom(t0,bar)
+export(an_s7_class)
+importFrom(t0,an_s3_generic)
+importFrom(t0,an_s7_generic)

tests/testthat/t2/R/t2.R

@@ -0,0 +1,22 @@
+
+#' @export
+an_s7_class <- S7::new_class("an_s7_class")
+
+#' @importFrom t0 an_s7_generic
+S7::method(an_s7_generic, S7::class_character) <- function(x) "foo"
+S7::method(an_s7_generic, an_s7_class) <- function(x) "foo"
+
+#' @importFrom t0 an_s3_generic
+S7::method(an_s3_generic, an_s7_class) <- function(x) "foo"
+
+
+another_s7_generic <- S7::new_external_generic("t1", "another_s7_generic", "x")
+S7::method(another_s7_generic, S7::class_character) <- function(x) "foo"
+S7::method(another_s7_generic, an_s7_class) <- function(x) "foo"
+
+another_s3_generic <- S7::new_external_generic("t1", "another_s3_generic", "x")
+S7::method(another_s3_generic, an_s7_class) <- function(x) "foo"
+
+.onLoad <- function(libname, pkgname) {
+  S7::methods_register()
+}

tests/testthat/test-external-generic.R

@@ -59,28 +59,59 @@ test_that("new_method works with both hard and soft dependencies", {
   skip_if(getRversion() < "4.1" && Sys.info()[["sysname"]] == "Windows")
   skip_if(quick_test())
 
-  tmp_lib <- tempfile()
-  dir.create(tmp_lib)
-  old_libpaths <- .libPaths()
-  .libPaths(c(tmp_lib, old_libpaths))
 
   on.exit({
     .libPaths(old_libpaths)
     try(detach("package:t2", unload = TRUE), silent = TRUE)
     try(detach("package:t1", unload = TRUE), silent = TRUE)
     try(detach("package:t0", unload = TRUE), silent = TRUE)
     unlink(tmp_lib, recursive = TRUE)
+    # remove.packages(c("t1", "t0", "t2"))
   })
 
-  quick_install(test_path(c("t0", "t1")), tmp_lib)
+  tmp_lib <- tempfile()
+  dir.create(tmp_lib)
+  old_libpaths <- .libPaths()
+  .libPaths(c(tmp_lib, old_libpaths))
+
+  # t2 has a hard dependency on t0
+  # t2 has a soft dependency on t1
+
+  # First, ensure that t2 can install and run successfully without t1 installed
+  quick_install(test_path("t0"), tmp_lib)
   quick_install(test_path("t2"), tmp_lib)
+
   library("t2")
+  library("t0")
+  expect_equal(an_s3_generic(t2::an_s7_class()), "foo")
+  expect_equal(an_s7_generic("x"), "foo")
+
+  # Now install the soft dependency
+  quick_install(test_path("t1"), tmp_lib)
 
-  # t2 has a soft dependency on t1
   library("t1")
-  expect_equal(foo("x"), "foo")
+  expect_equal(another_s3_generic(t2::an_s7_class()), "foo")
+  expect_equal(another_s7_generic("x"), "foo")
+
+
+  ## Check again in a fresh session, with everything installed
+  expect_no_error(callr::r(function() {
+    library(t2)
+
+    stopifnot(exprs = {
+      t0::an_s3_generic(an_s7_class()) == "foo"
+      t0::an_s7_generic("x") == "foo"
+    })
+
+    if(isNamespaceLoaded("t1"))
+      stop("Prematurely loaded {t1}")
+
+    stopifnot(exprs = {
+      t1::another_s3_generic(an_s7_class()) == "foo"
+      t1::another_s7_generic("x") == "foo"
+    })
+
+    NULL
+  }))
 
-  # t2 has a hard dependency on t0
-  library("t0")
-  expect_equal(bar("x"), "bar")
 })