diff --git a/NEWS.md b/NEWS.md index 4a8359c7..6b42f35f 100644 --- a/NEWS.md +++ b/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). diff --git a/R/method-register.R b/R/method-register.R index b44a4827..663013e2 100644 --- a/R/method-register.R +++ b/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) { diff --git a/man/method-set.Rd b/man/method-set.Rd index 26c3764e..dfda98fd 100644 --- a/man/method-set.Rd +++ b/man/method-set.Rd @@ -28,7 +28,9 @@ For S7 generics that use multiple dispatch, this must be a list of any of 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 \link{class_missing} with S3 operators that support double +dispatch (e.g. \code{+} and \code{-}). The same rules apply to S4 generics as S7 generics.} diff --git a/tests/testthat/_snaps/method-register.md b/tests/testthat/_snaps/method-register.md index 08198409..2648d432 100644 --- a/tests/testthat/_snaps/method-register.md +++ b/tests/testthat/_snaps/method-register.md @@ -6,13 +6,13 @@ Message Overwriting method foo() -# 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 diff --git a/tests/testthat/helper.R b/tests/testthat/helper.R index 2e22cec7..578c551d 100644 --- a/tests/testthat/helper.R +++ b/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)) diff --git a/tests/testthat/test-method-register.R b/tests/testthat/test-method-register.R index 9281b454..bd3fcc37 100644 --- a/tests/testthat/test-method-register.R +++ b/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" }) })