Complete S3 method registration

NEWS.md

@@ -9,6 +9,7 @@
 * `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<-` 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 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). `class_missing` is explicitly rejected since S3 dispatches on a single, always-present argument (#455).
 * `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).
 * `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).

R/method-register.R

@@ -35,7 +35,9 @@
 #'   the above types. (For convenience you can also use a list in the single
 #'   dispatch case too.)
 #'
-#'   For S3 generics, this must be a single S7 class.
+#'   For S3 generics, this can be any of the above types. There's one exception:
+#'   you can only use [class_missing] with S3 operators that support double
+#'   dispatch (e.g. `+` and `-`).
 #'
 #'   The same rules apply to S4 generics as S7 generics.
 #' @param value A function that implements the generic specification for the
@@ -94,7 +96,9 @@ register_method <- function(
     )
     register_S7_method(generic, signature, method)
   } else if (is_S3_generic(generic)) {
-    register_S3_method(generic, signature, method, env, call = call)
+    for (sig in flatten_signature(signature)) {
+      register_S3_method(generic, sig, method, env, call = call)
+    }
   } else if (is_S4_generic(generic)) {
     signatures <- flatten_signature(signature)
     for (signature in signatures) {
@@ -155,23 +159,52 @@ register_S3_method <- function(
   envir = parent.frame(),
   call = sys.call(-1L)
 ) {
-  if (class_type(signature[[1]]) != "S7") {
-    msg <- sprintf(
-      "When registering methods for S3 generic %s(), signature must be an S7 class, not %s.",
-      generic$name,
-      class_friendly(signature[[1]])
-    )
-    stop2(msg, call = call)
-  }
+  sig <- signature[[1]]
+
+  class <- switch(
+    class_type(sig),
+    `NULL` = "NULL",
+    missing = stop2(
+      "`class_missing` not supported for non-operator S3 generics.",
+      call = NULL
+    ),
+    any = "default",
+    S7_base = sig$class,
+    S7 = S7_class_name(sig),
+    S7_union = stop2("Unreachable", call = NULL),
+    S7_S3 = sig$class[[1]],
+    S4 = sig@className
+  )
 
-  if (
-    is_external_generic(external_generic <- get0(generic$name, envir = envir))
-  ) {
-    envir <- asNamespace(external_generic$package)
+  if (is_local_s3_generic(generic)) {
+    register_local_s3_method(generic, class, method)
+  } else {
+    # Register external generics in their own namespace
+    external_generic <- get0(generic$name, envir = envir)
+    if (is_external_generic(external_generic)) {
+      envir <- asNamespace(external_generic$package)
+    }
+    registerS3method(generic$name, class, method, envir)
   }
+}
 
-  class <- S7_class_name(signature[[1]])
-  registerS3method(generic$name, class, method, envir)
+# `registerS3method()` registers into the S3 methods table of
+# `environment(generic)`, but `UseMethod()` dispatches using the table of
+# `topenv(environment(generic))`. These are the same for package and global
+# generics, but differ for a generic defined in a local environment.
+is_local_s3_generic <- function(generic) {
+  env <- environment(generic$generic)
+  !is.null(env) && !identical(env, topenv(env))
+}
+register_local_s3_method <- function(generic, class, method) {
+  dispatch_env <- topenv(environment(generic$generic))
+  table <- dispatch_env[[".__S3MethodsTable__."]]
+  if (is.null(table)) {
+    table <- new.env(parent = baseenv())
+    dispatch_env[[".__S3MethodsTable__."]] <- table
+  }
+  assign(paste(generic$name, class, sep = "."), method, envir = table)
+  invisible(method)
 }
 
 register_S7_method <- function(generic, signature, method) {

tests/testthat/_snaps/method-register.md

@@ -6,13 +6,13 @@
     Message
       Overwriting method foo(<character>)
 
-# method registration / S3 registration requires a S7 class
+# method registration / rejects class_missing on S3 generics
 
     Code
-      method(sum, new_S3_class("foo")) <- (function(x, ...) "foo")
+      method(s3_gen, class_missing) <- (function(x) "missing")
     Condition
-      Error in `method<-`:
-      ! When registering methods for S3 generic sum(), signature must be an S7 class, not an S3 class.
+      Error:
+      ! `class_missing` not supported for non-operator S3 generics.
 
 # method registration / can register S7 method for S4 generic
 

tests/testthat/helper.R

@@ -60,6 +60,34 @@ local_S4_class <- function(name, ..., env = parent.frame()) {
   out
 }
 
+# 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.
+local_s3_generic <- function(name, frame = parent.frame()) {
+  eval(
+    bquote(.(name) <- function(x) UseMethod(.(name))),
+    globalenv()
+  )
+  defer(
+    {
+      rm(list = name, envir = globalenv())
+      unregister_s3_methods(globalenv(), name)
+    },
+    frame = frame
+  )
+  invisible()
+}
+
+unregister_s3_methods <- function(envir, generic) {
+  tbl <- envir[[".__S3MethodsTable__."]]
+  if (!is.null(tbl)) {
+    methods <- ls(tbl, pattern = paste0("^", generic, "\\."))
+    rm(list = methods, envir = tbl)
+  }
+
+  invisible()
+}
+
 # Lightweight equivalent of withr::defer()
 defer <- function(expr, frame = parent.frame(), after = FALSE) {
   thunk <- as.call(list(function() expr))

tests/testthat/test-method-register.R

@@ -64,10 +64,74 @@ describe("method registration", {
     }
   })
 
-  it("S3 registration requires a S7 class", {
-    foo <- new_class("foo")
+  it("can register S7 method for S3 generic defined in a local environment", {
+    s3_gen <- local(function(x) UseMethod("s3_gen"))
+    defer(unregister_s3_methods(topenv(environment(s3_gen)), "s3_gen"))
+
+    local({
+      method(s3_gen, class_character) <- function(x) "char"
+      method(s3_gen, class_integer) <- function(x) "int"
+    })
+
+    expect_equal(s3_gen("a"), "char")
+    expect_equal(s3_gen(1L), "int")
+  })
+
+  it("can register S7 method for S3 generic with base type signature", {
+    local_s3_generic("s3_gen")
+    method(s3_gen, class_character) <- function(x) "char"
+    method(s3_gen, class_integer) <- function(x) "int"
+
+    expect_equal(s3_gen("a"), "char")
+    expect_equal(s3_gen(1L), "int")
+  })
+
+  it("can register S7 method for S3 generic with S3 class signature", {
+    local_s3_generic("s3_gen")
+    method(s3_gen, new_S3_class("foo")) <- function(x) "foo"
+    method(s3_gen, class_factor) <- function(x) "factor"
+
+    expect_equal(s3_gen(structure(list(), class = "foo")), "foo")
+    expect_equal(s3_gen(factor("a")), "factor")
+  })
+
+  it("S3 registration for a multi-class S3 class uses only the first class", {
+    local_s3_generic("s3_gen")
+    method(s3_gen, new_S3_class(c("ordered", "factor"))) <- function(x) "ord"
+
+    expect_equal(s3_gen(ordered("a")), "ord")
+    # plain factors don't match because only `ordered` was registered
+    expect_error(s3_gen(factor("a")), "no applicable method")
+  })
+
+  it("can register S7 method for S3 generic with class_any and NULL", {
+    local_s3_generic("s3_gen")
+    method(s3_gen, class_any) <- function(x) "any"
+    method(s3_gen, NULL) <- function(x) "null"
+
+    expect_equal(s3_gen(1L), "any")
+    expect_equal(s3_gen(NULL), "null")
+  })
+
+  it("S3 method registration expands unions to one method per class", {
+    local_s3_generic("s3_gen")
+    method(s3_gen, class_numeric) <- function(x) "num"
+
+    expect_equal(s3_gen(1L), "num")
+    expect_equal(s3_gen(1.5), "num")
+
+    # Custom union mixing a base type and an S3 class
+    local_s3_generic("s3_gen2")
+    method(s3_gen2, class_character | new_S3_class("foo")) <- function(x) "x"
+
+    expect_equal(s3_gen2("a"), "x")
+    expect_equal(s3_gen2(structure(list(), class = "foo")), "x")
+  })
+
+  it("rejects class_missing on S3 generics", {
+    local_s3_generic("s3_gen")
     expect_snapshot(error = TRUE, {
-      method(sum, new_S3_class("foo")) <- function(x, ...) "foo"
+      method(s3_gen, class_missing) <- function(x) "missing"
     })
   })