Store the S7 methods table as an attribute of the S3 methods table (#343

)

This prevents it from being listed in `functions_in_S3_table` (https://github.com/wch/r-source/blob/16c4fbf48efb4d43ef5dccadc86576100edd85b4/src/library/tools/R/QC.R#L370-L383) and later generating a warning when calling `formals` on each element of that list.

Fixes #342

NEWS.md

@@ -1,5 +1,10 @@
 # S7 (development version)
 
+* External methods are now registered using an attribute of the S3 methods 
+  table rather than an element of that environment. This prevents a warning
+  being generated during the "code/documentation mismatches" check in
+  `R CMD check` (#342).
+
 * `new_object()` no longer accepts `NULL` as `.parent`.
 
 * `new_object()` now correctly runs the validator from abstract parent classes

R/external-generic.R

@@ -74,7 +74,7 @@ is_external_generic <- function(x) {
 #' }
 methods_register <- function() {
   package <- packageName(parent.frame())
-  tbl <- external_methods_get(package)
+  tbl <- S7_methods_table(package)
 
   for (x in tbl) {
     register <- registrar(x$generic, x$signature, x$method)
@@ -107,28 +107,34 @@ registrar <- function(generic, signature, method) {
   }
 }
 
-external_methods_get <- function(package) {
-  S3_methods_table(package)[[".S7_methods"]] %||% list()
-}
-
 external_methods_reset <- function(package) {
-  tbl <- S3_methods_table(package)
-  tbl[[".S7_methods"]] <- list()
+  S7_methods_table(package) <- list()
   invisible()
 }
 
 external_methods_add <- function(package, generic, signature, method) {
-  tbl <- S3_methods_table(package)
+  tbl <- S7_methods_table(package)
 
   methods <- append(
-    tbl[[".S7_methods"]] %||% list(),
+    tbl,
     list(list(generic = generic, signature = signature, method = method))
   )
 
-  tbl[[".S7_methods"]] <- methods
+  S7_methods_table(package) <- methods
   invisible()
 }
 
-S3_methods_table <- function(package) {
-  asNamespace(package)[[".__S3MethodsTable__."]]
+# Store external methods in an attribute of the S3 methods table since
+# this mutable object is present in all packages.
+
+S7_methods_table <- function(package) {
+  ns <- asNamespace(package)
+  tbl <- ns[[".__S3MethodsTable__."]]
+  attr(tbl, "S7methods")
+}
+`S7_methods_table<-` <- function(package, value) {
+  ns <- asNamespace(package)
+  tbl <- ns[[".__S3MethodsTable__."]]
+  attr(tbl, "S7methods") <- value
+  invisible()
 }

tests/testthat/test-external-generic.R

@@ -2,12 +2,12 @@ test_that("can get and append methods", {
   external_methods_reset("S7")
   on.exit(external_methods_reset("S7"), add = TRUE)
 
-  expect_equal(external_methods_get("S7"), list())
+  expect_equal(S7_methods_table("S7"), list())
 
   bar <- new_external_generic("foo", "bar", "x")
   external_methods_add("S7", bar, list(), function() {})
   expect_equal(
-    external_methods_get("S7"),
+    S7_methods_table("S7"),
     list(
       list(
         generic = bar,