Merge pull request #586 from r-lib/S7-external-generics

Add support for S7 methods registered for external generics

.github/workflows/R-CMD-check.yaml

@@ -5,6 +5,7 @@
 # check-standard.yaml is likely a better choice.
 # usethis::use_github_action("check-standard") will install it.
 on:
+  workflow_dispatch:
   push:
     branches: [main, master]
   pull_request:

R/S7.R

@@ -1,12 +1,27 @@
 replacements_S7 <- function(env) {
-  unlist(recursive = FALSE, use.names = FALSE, eapply(env, all.names = TRUE,
+  bindings <- unlist(recursive = FALSE, use.names = FALSE, eapply(env, all.names = TRUE,
     function(obj) {
       if (inherits(obj, "S7_generic")) {
         traverse_S7_generic(obj)
       } else if (inherits(obj, "S7_class")) {
         traverse_S7_class(obj)
       }
     }))
+
+  S7_methods_tbl <- attr(env[[".__S3MethodsTable__."]], "S7methods", exact = TRUE)
+  external_methods <- lapply(seq_along(S7_methods_tbl), function(i) {
+    entry <- S7_methods_tbl[[i]]
+    name <- external_generic_method_signature(entry$generic, entry$signature)
+
+    replacement(
+      # `name` is for informative printouts only.
+      # It is not used by covr, and does not need to be unique,
+      name = name,
+      env = entry,
+      target_value = entry$method)
+  })
+
+  c(bindings, external_methods)
 }
 
 traverse_S7_generic <- function(x) {
@@ -51,3 +66,19 @@ traverse_S7_class <- function(x) {
     prop_fun_replacements
   )
 }
+
+
+external_generic_method_signature <- function(generic, signature) {
+  # This function is a lightly modified copy of S7:::method_signature() for external generics
+  display_generic <- paste0(c(generic$package, generic$name), collapse = "::")
+  class_deparse <- asNamespace("S7")$class_deparse # not exported from S7 :/
+  single <- length(generic$dispatch_args) == 1
+  if (single) {
+    signature <- class_deparse(signature[[1]])
+  } else {
+    classes <- vapply(signature, class_deparse, "", USE.NAMES = FALSE)
+    signature <- paste0("list(", paste0(classes, collapse = ", "), ")")
+  }
+
+  sprintf("method(%s, %s)", display_generic, signature)
+}

tests/testthat/TestS7/R/foo.R

@@ -37,3 +37,18 @@ method(inside, Range) <- function(x, y) {
 # enable usage of <S7_object>@name in package code
 #' @rawNamespace if (getRversion() < "4.3.0") importFrom("S7", "@")
 NULL
+
+# test external S3 generics
+method(format, Range) <- function(x) {
+  sprintf("Range(%s, %s)", x@start, x@end)
+}
+
+testthat_print <- new_external_generic("testthat", "testthat_print", "x")
+method(testthat_print, Range) <- function(x, ...) {
+  cat(format(x))
+  invisible(x)
+}
+
+.onLoad <- function(libname, pkgname) {
+  S7::methods_register()
+}

tests/testthat/TestS7/tests/testthat/test-foo.R

@@ -14,3 +14,11 @@ test_that("Range works", {
   expect_equal(x@length, 5)
   expect_equal(x@end, 6)
 })
+
+test_that("Range methods work", {
+  x <- Range(1:10)
+  expect_equal(base::format(x), "Range(1, 10)")
+
+  # Test external generic method for testthat::testthat_print()
+  expect_equal(testthat::capture_output(x, print = TRUE), "Range(1, 10)")
+})

tests/testthat/_snaps/S7.md

@@ -0,0 +1,22 @@
+# S7 coverage is reported
+
+    Code
+      cov[, c("functions", "first_line", "last_line", "value")]
+    Output
+                                               functions first_line last_line value
+      1                   Range@properties$length$getter          9         9     1
+      2                   Range@properties$length$setter         11        11     1
+      3                   Range@properties$length$setter         12        12     1
+      4                                            Range         17        17     2
+      5                                  Range@validator         20        20     5
+      6                                  Range@validator         21        21     0
+      7                                  Range@validator         22        22     5
+      8                                  Range@validator         23        23     0
+      9                                  Range@validator         24        24     5
+      10                                 Range@validator         25        25     1
+      11                   method(inside, TestS7::Range)         34        34     1
+      12             method(base::format, TestS7::Range)         43        43     2
+      13 method(testthat::testthat_print, TestS7::Range)         48        48     1
+      14 method(testthat::testthat_print, TestS7::Range)         49        49     1
+      15                                         .onLoad         53        53     0
+

tests/testthat/test-S7.R

@@ -1,5 +1,7 @@
 test_that("S7 coverage is reported", {
+  local_edition(3)
   cov <- as.data.frame(package_coverage(test_path("TestS7")))
 
-  expect_equal(cov$value, c(1, 1, 1, 1, 4, 0, 4, 0, 4, 1, 1))
+  expect_equal(cov$value, c(1, 1, 1, 2, 5, 0, 5, 0, 5, 1, 1, 2, 1, 1, 0))
+  expect_snapshot(cov[, c("functions", "first_line", "last_line", "value")])
 })