From 7ae296345c0bc7d6889bc8e562930904d4f32ba8 Mon Sep 17 00:00:00 2001 From: Hadley Wickham Date: Fri, 29 May 2026 15:56:09 -0500 Subject: [PATCH 1/7] Separate out S3 and S4 specific code --- R/method-register-S3.R | 54 +++++++ R/method-register-S4.R | 52 +++++++ R/method-register.R | 108 ------------- tests/testthat/_snaps/method-register-S3.md | 24 +++ tests/testthat/_snaps/method-register-S4.md | 12 ++ tests/testthat/_snaps/method-register.md | 36 ----- tests/testthat/test-method-register-S3.R | 110 +++++++++++++ tests/testthat/test-method-register-S4.R | 58 +++++++ tests/testthat/test-method-register.R | 162 -------------------- 9 files changed, 310 insertions(+), 306 deletions(-) create mode 100644 R/method-register-S3.R create mode 100644 R/method-register-S4.R create mode 100644 tests/testthat/_snaps/method-register-S3.md create mode 100644 tests/testthat/_snaps/method-register-S4.md create mode 100644 tests/testthat/test-method-register-S3.R create mode 100644 tests/testthat/test-method-register-S4.R diff --git a/R/method-register-S3.R b/R/method-register-S3.R new file mode 100644 index 00000000..305491b0 --- /dev/null +++ b/R/method-register-S3.R @@ -0,0 +1,54 @@ +register_S3_method <- function( + generic, + signature, + method, + envir = parent.frame(), + call = sys.call(-1L) +) { + 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_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) + } +} + +# `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) +} diff --git a/R/method-register-S4.R b/R/method-register-S4.R new file mode 100644 index 00000000..294f0bed --- /dev/null +++ b/R/method-register-S4.R @@ -0,0 +1,52 @@ +register_S4_method <- function( + generic, + signature, + method, + env = parent.frame(), + call = sys.call(-1L) +) { + S4_env <- topenv(env) + S4_signature <- lapply(signature, S4_class, S4_env = S4_env, call = call) + methods::setMethod(generic, S4_signature, method, where = S4_env) +} + +S4_class <- function(x, S4_env, call = sys.call(-1L)) { + switch( + class_type(x), + `NULL` = "NULL", + missing = "missing", + any = "ANY", + S7_base = base_to_S4(x$class), + S4 = x, + S7 = S4_registered_class(x, call = call), + S7_S3 = S4_registered_class(x, call = call), + S7_union = stop2( + "Internal error: union should be flattened upstream.", + call = NULL + ) + ) +} + +# S4 dispatch uses `class()` to find a method, but `class(1.5)` is "numeric", +# not "double", so registering under "double" silently misses real doubles. +# Mapping to "numeric" catches doubles but also matches integers too. There's +# no clean S4 way to say "doubles only" and this seems likely to be what +# people want. +base_to_S4 <- function(class) { + switch(class, double = "numeric", class) +} + +S4_registered_class <- function(x, call = sys.call(-1L)) { + class <- tryCatch( + methods::getClass(class_register(x)), + error = function(err) NULL + ) + if (is.null(class)) { + msg <- sprintf( + "Class has not been registered with S4; please call S4_register(%s).", + class_deparse(x) + ) + stop2(msg, call = call) + } + class +} diff --git a/R/method-register.R b/R/method-register.R index 663013e2..97bde028 100644 --- a/R/method-register.R +++ b/R/method-register.R @@ -152,61 +152,6 @@ unregister_method <- function( invisible(generic) } -register_S3_method <- function( - generic, - signature, - method, - envir = parent.frame(), - call = sys.call(-1L) -) { - 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_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) - } -} - -# `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) { # Flatten out unions to individual signatures signatures <- flatten_signature(signature) @@ -377,59 +322,6 @@ check_method <- function( invisible(TRUE) } -register_S4_method <- function( - generic, - signature, - method, - env = parent.frame(), - call = sys.call(-1L) -) { - S4_env <- topenv(env) - S4_signature <- lapply(signature, S4_class, S4_env = S4_env, call = call) - methods::setMethod(generic, S4_signature, method, where = S4_env) -} - -S4_class <- function(x, S4_env, call = sys.call(-1L)) { - switch( - class_type(x), - `NULL` = "NULL", - missing = "missing", - any = "ANY", - S7_base = base_to_S4(x$class), - S4 = x, - S7 = S4_registered_class(x, call = call), - S7_S3 = S4_registered_class(x, call = call), - S7_union = stop2( - "Internal error: union should be flattened upstream.", - call = NULL - ) - ) -} - -# S4 dispatch uses `class()` to find a method, but `class(1.5)` is "numeric", -# not "double", so registering under "double" silently misses real doubles. -# Mapping to "numeric" catches doubles but also matches integers too. There's -# no clean S4 way to say "doubles only" and this seems likely to be what -# people want. -base_to_S4 <- function(class) { - switch(class, double = "numeric", class) -} - -S4_registered_class <- function(x, call = sys.call(-1L)) { - class <- tryCatch( - methods::getClass(class_register(x)), - error = function(err) NULL - ) - if (is.null(class)) { - msg <- sprintf( - "Class has not been registered with S4; please call S4_register(%s).", - class_deparse(x) - ) - stop2(msg, call = call) - } - class -} - #' @export print.S7_method <- function(x, ...) { signature <- method_signature(x@generic, x@signature) diff --git a/tests/testthat/_snaps/method-register-S3.md b/tests/testthat/_snaps/method-register-S3.md new file mode 100644 index 00000000..4d0d3201 --- /dev/null +++ b/tests/testthat/_snaps/method-register-S3.md @@ -0,0 +1,24 @@ +# S3 method registration / rejects class_missing on S3 generics + + Code + method(s3_gen, class_missing) <- (function(x) "missing") + Condition + Error: + ! `class_missing` not supported for non-operator S3 generics. + +# S3 method unregistration / errors when unregistering from an S3 generic + + Code + method(sum, foo) <- NULL + Condition + Error in `method<-`: + ! Can't unregister methods for S3 generics + +--- + + Code + method(base_sum, foo) <- NULL + Condition + Error in `method<-`: + ! Can't unregister methods for S3 generics + diff --git a/tests/testthat/_snaps/method-register-S4.md b/tests/testthat/_snaps/method-register-S4.md new file mode 100644 index 00000000..8bad9032 --- /dev/null +++ b/tests/testthat/_snaps/method-register-S4.md @@ -0,0 +1,12 @@ +# S4 method registration / can register S7 method for S4 generic + + Class has not been registered with S4; please call S4_register(S4foo). + +# S4 method unregistration / errors when unregistering from an S4 generic + + Code + method(removeS4, S4foo) <- NULL + Condition + Error in `method<-`: + ! Can't unregister methods for S4 generics + diff --git a/tests/testthat/_snaps/method-register.md b/tests/testthat/_snaps/method-register.md index 2648d432..d61a0cfa 100644 --- a/tests/testthat/_snaps/method-register.md +++ b/tests/testthat/_snaps/method-register.md @@ -6,18 +6,6 @@ Message Overwriting method foo() -# method registration / rejects class_missing on S3 generics - - Code - method(s3_gen, class_missing) <- (function(x) "missing") - Condition - Error: - ! `class_missing` not supported for non-operator S3 generics. - -# method registration / can register S7 method for S4 generic - - Class has not been registered with S4; please call S4_register(S4foo). - # method registration / checks argument types Code @@ -55,30 +43,6 @@ - x: - y: -# method unregistration / errors when unregistering from an S3 generic - - Code - method(sum, foo) <- NULL - Condition - Error in `method<-`: - ! Can't unregister methods for S3 generics - ---- - - Code - method(base_sum, foo) <- NULL - Condition - Error in `method<-`: - ! Can't unregister methods for S3 generics - -# method unregistration / errors when unregistering from an S4 generic - - Code - method(removeS4, S4foo) <- NULL - Condition - Error in `method<-`: - ! Can't unregister methods for S4 generics - # as_signature() / accepts a length-1 list for single dispatch (#555) Code diff --git a/tests/testthat/test-method-register-S3.R b/tests/testthat/test-method-register-S3.R new file mode 100644 index 00000000..d83a3b92 --- /dev/null +++ b/tests/testthat/test-method-register-S3.R @@ -0,0 +1,110 @@ +describe("S3 method registration", { + it("can register S7 method for S3 generic", { + foo1 <- new_class("foo") + method(sum, foo1) <- function(x, ...) "foo" + expect_equal(sum(foo1()), "foo") + + foo2 <- new_class("foo", package = "bar") + method(sum, foo2) <- function(x, ...) "foo" + expect_equal(sum(foo2()), "foo") + + # and doesn't modify generic + expect_equal(sum, base::sum) + }) + + it("can register S7 method for S3 Ops generic", { + foo <- new_class("foo") + bar <- new_class("bar") + + method(`+`, list(foo, bar)) <- function(e1, e2) "foobar" + expect_equal(foo() + bar(), "foobar") + + if (getRversion() >= "4.3.0") { + method(`%*%`, list(foo, bar)) <- function(x, y) "foo.bar" + expect_equal(foo() %*% bar(), "foo.bar") + } + }) + + 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(s3_gen, class_missing) <- function(x) "missing" + }) + }) +}) + +describe("S3 method unregistration", { + it("errors when unregistering from an S3 generic", { + foo <- new_class("foo") + method(sum, foo) <- function(x, ...) "foo" + expect_snapshot(method(sum, foo) <- NULL, error = TRUE) + + # External generics that resolve to S3 generics also error + base_sum <- new_external_generic("base", "sum", "x") + expect_snapshot(method(base_sum, foo) <- NULL, error = TRUE) + }) +}) diff --git a/tests/testthat/test-method-register-S4.R b/tests/testthat/test-method-register-S4.R new file mode 100644 index 00000000..d3f761db --- /dev/null +++ b/tests/testthat/test-method-register-S4.R @@ -0,0 +1,58 @@ +describe("S4 method registration", { + it("can register S7 method for S4 generic", { + methods::setGeneric("bar", function(x) standardGeneric("bar")) + S4foo <- new_class("S4foo", package = NULL) + + expect_snapshot_error(method(bar, S4foo) <- function(x) "foo") + + S4_register(S4foo) + on.exit(S4_remove_classes("S4foo"), add = TRUE) + + method(bar, S4foo) <- function(x) "foo" + expect_equal(bar(S4foo()), "foo") + }) + + it("can register S4 methods for base types, class_any, class_missing, and NULL", { + methods::setGeneric("s4_gen", function(x) standardGeneric("s4_gen")) + method(s4_gen, class_character) <- function(x) "char" + method(s4_gen, class_any) <- function(x) "any" + method(s4_gen, class_missing) <- function(x) "missing" + method(s4_gen, NULL) <- function(x) "null" + + expect_equal(s4_gen("hi"), "char") + expect_equal(s4_gen(list()), "any") + expect_equal(s4_gen(), "missing") + expect_equal(s4_gen(NULL), "null") + }) + + it("S4 method registration expands S7 unions to one method per class", { + methods::setGeneric("s4_union", function(x) standardGeneric("s4_union")) + method(s4_union, class_integer | class_character) <- function(x) "u" + + expect_equal(s4_union(1L), "u") + expect_equal(s4_union("a"), "u") + }) + + it("S4 method registration on class_double catches actual doubles", { + # class(1.5) is "numeric", not "double", so class_double must register + # under S4's "numeric" class to dispatch on real doubles. + methods::setGeneric("s4_double", function(x) standardGeneric("s4_double")) + method(s4_double, class_numeric) <- function(x) "num" + + expect_equal(s4_double(1L), "num") + expect_equal(s4_double(1.5), "num") + }) +}) + +describe("S4 method unregistration", { + it("errors when unregistering from an S4 generic", { + methods::setGeneric("removeS4", function(x) standardGeneric("removeS4")) + on.exit(suppressMessages(methods::removeGeneric("removeS4")), add = TRUE) + S4foo <- new_class("S4foo", package = NULL) + S4_register(S4foo) + on.exit(S4_remove_classes("S4foo"), add = TRUE) + + method(removeS4, S4foo) <- function(x) "foo" + expect_snapshot(method(removeS4, S4foo) <- NULL, error = TRUE) + }) +}) diff --git a/tests/testthat/test-method-register.R b/tests/testthat/test-method-register.R index bd3fcc37..438980a5 100644 --- a/tests/testthat/test-method-register.R +++ b/tests/testthat/test-method-register.R @@ -38,147 +38,6 @@ describe("method registration", { expect_equal(sum, base::sum) }) - it("can register S7 method for S3 generic", { - foo1 <- new_class("foo") - method(sum, foo1) <- function(x, ...) "foo" - expect_equal(sum(foo1()), "foo") - - foo2 <- new_class("foo", package = "bar") - method(sum, foo2) <- function(x, ...) "foo" - expect_equal(sum(foo2()), "foo") - - # and doesn't modify generic - expect_equal(sum, base::sum) - }) - - it("can register S7 method for S3 Ops generic", { - foo <- new_class("foo") - bar <- new_class("bar") - - method(`+`, list(foo, bar)) <- function(e1, e2) "foobar" - expect_equal(foo() + bar(), "foobar") - - if (getRversion() >= "4.3.0") { - method(`%*%`, list(foo, bar)) <- function(x, y) "foo.bar" - expect_equal(foo() %*% bar(), "foo.bar") - } - }) - - 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(s3_gen, class_missing) <- function(x) "missing" - }) - }) - - it("can register S7 method for S4 generic", { - methods::setGeneric("bar", function(x) standardGeneric("bar")) - S4foo <- new_class("S4foo", package = NULL) - - expect_snapshot_error(method(bar, S4foo) <- function(x) "foo") - - S4_register(S4foo) - on.exit(S4_remove_classes("S4foo"), add = TRUE) - - method(bar, S4foo) <- function(x) "foo" - expect_equal(bar(S4foo()), "foo") - }) - - it("can register S4 methods for base types, class_any, class_missing, and NULL", { - methods::setGeneric("s4_gen", function(x) standardGeneric("s4_gen")) - method(s4_gen, class_character) <- function(x) "char" - method(s4_gen, class_any) <- function(x) "any" - method(s4_gen, class_missing) <- function(x) "missing" - method(s4_gen, NULL) <- function(x) "null" - - expect_equal(s4_gen("hi"), "char") - expect_equal(s4_gen(list()), "any") - expect_equal(s4_gen(), "missing") - expect_equal(s4_gen(NULL), "null") - }) - - it("S4 method registration expands S7 unions to one method per class", { - methods::setGeneric("s4_union", function(x) standardGeneric("s4_union")) - method(s4_union, class_integer | class_character) <- function(x) "u" - - expect_equal(s4_union(1L), "u") - expect_equal(s4_union("a"), "u") - }) - - it("S4 method registration on class_double catches actual doubles", { - # class(1.5) is "numeric", not "double", so class_double must register - # under S4's "numeric" class to dispatch on real doubles. - methods::setGeneric("s4_double", function(x) standardGeneric("s4_double")) - method(s4_double, class_numeric) <- function(x) "num" - - expect_equal(s4_double(1L), "num") - expect_equal(s4_double(1.5), "num") - }) - it("checks argument types", { foo <- new_generic("foo", "x") expect_snapshot(error = TRUE, { @@ -227,27 +86,6 @@ describe("method unregistration", { expect_silent(method(foo, class_character) <- NULL) expect_length(methods(foo), 0) }) - - it("errors when unregistering from an S3 generic", { - foo <- new_class("foo") - method(sum, foo) <- function(x, ...) "foo" - expect_snapshot(method(sum, foo) <- NULL, error = TRUE) - - # External generics that resolve to S3 generics also error - base_sum <- new_external_generic("base", "sum", "x") - expect_snapshot(method(base_sum, foo) <- NULL, error = TRUE) - }) - - it("errors when unregistering from an S4 generic", { - methods::setGeneric("removeS4", function(x) standardGeneric("removeS4")) - on.exit(suppressMessages(methods::removeGeneric("removeS4")), add = TRUE) - S4foo <- new_class("S4foo", package = NULL) - S4_register(S4foo) - on.exit(S4_remove_classes("S4foo"), add = TRUE) - - method(removeS4, S4foo) <- function(x) "foo" - expect_snapshot(method(removeS4, S4foo) <- NULL, error = TRUE) - }) }) describe("as_signature()", { From 81195b76483345da8ae23833f1a18ad01ab69625 Mon Sep 17 00:00:00 2001 From: Hadley Wickham Date: Fri, 29 May 2026 15:57:42 -0500 Subject: [PATCH 2/7] Switch to test_that --- tests/testthat/_snaps/method-register-S3.md | 4 +- tests/testthat/_snaps/method-register-S4.md | 4 +- tests/testthat/test-method-register-S3.R | 164 ++++++++++---------- tests/testthat/test-method-register-S4.R | 106 ++++++------- 4 files changed, 135 insertions(+), 143 deletions(-) diff --git a/tests/testthat/_snaps/method-register-S3.md b/tests/testthat/_snaps/method-register-S3.md index 4d0d3201..3b4a3a28 100644 --- a/tests/testthat/_snaps/method-register-S3.md +++ b/tests/testthat/_snaps/method-register-S3.md @@ -1,4 +1,4 @@ -# S3 method registration / rejects class_missing on S3 generics +# rejects class_missing on S3 generics Code method(s3_gen, class_missing) <- (function(x) "missing") @@ -6,7 +6,7 @@ Error: ! `class_missing` not supported for non-operator S3 generics. -# S3 method unregistration / errors when unregistering from an S3 generic +# errors when unregistering from an S3 generic Code method(sum, foo) <- NULL diff --git a/tests/testthat/_snaps/method-register-S4.md b/tests/testthat/_snaps/method-register-S4.md index 8bad9032..77606fa4 100644 --- a/tests/testthat/_snaps/method-register-S4.md +++ b/tests/testthat/_snaps/method-register-S4.md @@ -1,8 +1,8 @@ -# S4 method registration / can register S7 method for S4 generic +# can register S7 method for S4 generic Class has not been registered with S4; please call S4_register(S4foo). -# S4 method unregistration / errors when unregistering from an S4 generic +# errors when unregistering from an S4 generic Code method(removeS4, S4foo) <- NULL diff --git a/tests/testthat/test-method-register-S3.R b/tests/testthat/test-method-register-S3.R index d83a3b92..e7dd8f60 100644 --- a/tests/testthat/test-method-register-S3.R +++ b/tests/testthat/test-method-register-S3.R @@ -1,110 +1,106 @@ -describe("S3 method registration", { - it("can register S7 method for S3 generic", { - foo1 <- new_class("foo") - method(sum, foo1) <- function(x, ...) "foo" - expect_equal(sum(foo1()), "foo") - - foo2 <- new_class("foo", package = "bar") - method(sum, foo2) <- function(x, ...) "foo" - expect_equal(sum(foo2()), "foo") - - # and doesn't modify generic - expect_equal(sum, base::sum) - }) +test_that("can register S7 method for S3 generic", { + foo1 <- new_class("foo") + method(sum, foo1) <- function(x, ...) "foo" + expect_equal(sum(foo1()), "foo") - it("can register S7 method for S3 Ops generic", { - foo <- new_class("foo") - bar <- new_class("bar") + foo2 <- new_class("foo", package = "bar") + method(sum, foo2) <- function(x, ...) "foo" + expect_equal(sum(foo2()), "foo") - method(`+`, list(foo, bar)) <- function(e1, e2) "foobar" - expect_equal(foo() + bar(), "foobar") + # and doesn't modify generic + expect_equal(sum, base::sum) +}) - if (getRversion() >= "4.3.0") { - method(`%*%`, list(foo, bar)) <- function(x, y) "foo.bar" - expect_equal(foo() %*% bar(), "foo.bar") - } - }) +test_that("can register S7 method for S3 Ops generic", { + foo <- new_class("foo") + bar <- new_class("bar") - 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")) + method(`+`, list(foo, bar)) <- function(e1, e2) "foobar" + expect_equal(foo() + bar(), "foobar") - local({ - method(s3_gen, class_character) <- function(x) "char" - method(s3_gen, class_integer) <- function(x) "int" - }) + if (getRversion() >= "4.3.0") { + method(`%*%`, list(foo, bar)) <- function(x, y) "foo.bar" + expect_equal(foo() %*% bar(), "foo.bar") + } +}) - expect_equal(s3_gen("a"), "char") - expect_equal(s3_gen(1L), "int") - }) +test_that("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")) - it("can register S7 method for S3 generic with base type signature", { - local_s3_generic("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 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("a"), "char") + expect_equal(s3_gen(1L), "int") +}) - expect_equal(s3_gen(structure(list(), class = "foo")), "foo") - expect_equal(s3_gen(factor("a")), "factor") - }) +test_that("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" - 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("a"), "char") + expect_equal(s3_gen(1L), "int") +}) - 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") - }) +test_that("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" - 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(structure(list(), class = "foo")), "foo") + expect_equal(s3_gen(factor("a")), "factor") +}) - expect_equal(s3_gen(1L), "any") - expect_equal(s3_gen(NULL), "null") - }) +test_that("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" - 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(ordered("a")), "ord") + # plain factors don't match because only `ordered` was registered + expect_error(s3_gen(factor("a")), "no applicable method") +}) - expect_equal(s3_gen(1L), "num") - expect_equal(s3_gen(1.5), "num") +test_that("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" - # 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_gen(1L), "any") + expect_equal(s3_gen(NULL), "null") +}) - expect_equal(s3_gen2("a"), "x") - expect_equal(s3_gen2(structure(list(), class = "foo")), "x") - }) +test_that("S3 method registration expands unions to one method per class", { + local_s3_generic("s3_gen") + method(s3_gen, class_numeric) <- function(x) "num" - it("rejects class_missing on S3 generics", { - local_s3_generic("s3_gen") - expect_snapshot(error = TRUE, { - method(s3_gen, class_missing) <- function(x) "missing" - }) + 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") +}) + +test_that("rejects class_missing on S3 generics", { + local_s3_generic("s3_gen") + expect_snapshot(error = TRUE, { + method(s3_gen, class_missing) <- function(x) "missing" }) }) -describe("S3 method unregistration", { - it("errors when unregistering from an S3 generic", { - foo <- new_class("foo") - method(sum, foo) <- function(x, ...) "foo" - expect_snapshot(method(sum, foo) <- NULL, error = TRUE) +test_that("errors when unregistering from an S3 generic", { + foo <- new_class("foo") + method(sum, foo) <- function(x, ...) "foo" + expect_snapshot(method(sum, foo) <- NULL, error = TRUE) - # External generics that resolve to S3 generics also error - base_sum <- new_external_generic("base", "sum", "x") - expect_snapshot(method(base_sum, foo) <- NULL, error = TRUE) - }) + # External generics that resolve to S3 generics also error + base_sum <- new_external_generic("base", "sum", "x") + expect_snapshot(method(base_sum, foo) <- NULL, error = TRUE) }) diff --git a/tests/testthat/test-method-register-S4.R b/tests/testthat/test-method-register-S4.R index d3f761db..c700e81f 100644 --- a/tests/testthat/test-method-register-S4.R +++ b/tests/testthat/test-method-register-S4.R @@ -1,58 +1,54 @@ -describe("S4 method registration", { - it("can register S7 method for S4 generic", { - methods::setGeneric("bar", function(x) standardGeneric("bar")) - S4foo <- new_class("S4foo", package = NULL) - - expect_snapshot_error(method(bar, S4foo) <- function(x) "foo") - - S4_register(S4foo) - on.exit(S4_remove_classes("S4foo"), add = TRUE) - - method(bar, S4foo) <- function(x) "foo" - expect_equal(bar(S4foo()), "foo") - }) - - it("can register S4 methods for base types, class_any, class_missing, and NULL", { - methods::setGeneric("s4_gen", function(x) standardGeneric("s4_gen")) - method(s4_gen, class_character) <- function(x) "char" - method(s4_gen, class_any) <- function(x) "any" - method(s4_gen, class_missing) <- function(x) "missing" - method(s4_gen, NULL) <- function(x) "null" - - expect_equal(s4_gen("hi"), "char") - expect_equal(s4_gen(list()), "any") - expect_equal(s4_gen(), "missing") - expect_equal(s4_gen(NULL), "null") - }) - - it("S4 method registration expands S7 unions to one method per class", { - methods::setGeneric("s4_union", function(x) standardGeneric("s4_union")) - method(s4_union, class_integer | class_character) <- function(x) "u" - - expect_equal(s4_union(1L), "u") - expect_equal(s4_union("a"), "u") - }) - - it("S4 method registration on class_double catches actual doubles", { - # class(1.5) is "numeric", not "double", so class_double must register - # under S4's "numeric" class to dispatch on real doubles. - methods::setGeneric("s4_double", function(x) standardGeneric("s4_double")) - method(s4_double, class_numeric) <- function(x) "num" - - expect_equal(s4_double(1L), "num") - expect_equal(s4_double(1.5), "num") - }) +test_that("can register S7 method for S4 generic", { + methods::setGeneric("bar", function(x) standardGeneric("bar")) + S4foo <- new_class("S4foo", package = NULL) + + expect_snapshot_error(method(bar, S4foo) <- function(x) "foo") + + S4_register(S4foo) + on.exit(S4_remove_classes("S4foo"), add = TRUE) + + method(bar, S4foo) <- function(x) "foo" + expect_equal(bar(S4foo()), "foo") +}) + +test_that("can register S4 methods for base types, class_any, class_missing, and NULL", { + methods::setGeneric("s4_gen", function(x) standardGeneric("s4_gen")) + method(s4_gen, class_character) <- function(x) "char" + method(s4_gen, class_any) <- function(x) "any" + method(s4_gen, class_missing) <- function(x) "missing" + method(s4_gen, NULL) <- function(x) "null" + + expect_equal(s4_gen("hi"), "char") + expect_equal(s4_gen(list()), "any") + expect_equal(s4_gen(), "missing") + expect_equal(s4_gen(NULL), "null") +}) + +test_that("S4 method registration expands S7 unions to one method per class", { + methods::setGeneric("s4_union", function(x) standardGeneric("s4_union")) + method(s4_union, class_integer | class_character) <- function(x) "u" + + expect_equal(s4_union(1L), "u") + expect_equal(s4_union("a"), "u") +}) + +test_that("S4 method registration on class_double catches actual doubles", { + # class(1.5) is "numeric", not "double", so class_double must register + # under S4's "numeric" class to dispatch on real doubles. + methods::setGeneric("s4_double", function(x) standardGeneric("s4_double")) + method(s4_double, class_numeric) <- function(x) "num" + + expect_equal(s4_double(1L), "num") + expect_equal(s4_double(1.5), "num") }) -describe("S4 method unregistration", { - it("errors when unregistering from an S4 generic", { - methods::setGeneric("removeS4", function(x) standardGeneric("removeS4")) - on.exit(suppressMessages(methods::removeGeneric("removeS4")), add = TRUE) - S4foo <- new_class("S4foo", package = NULL) - S4_register(S4foo) - on.exit(S4_remove_classes("S4foo"), add = TRUE) - - method(removeS4, S4foo) <- function(x) "foo" - expect_snapshot(method(removeS4, S4foo) <- NULL, error = TRUE) - }) +test_that("errors when unregistering from an S4 generic", { + methods::setGeneric("removeS4", function(x) standardGeneric("removeS4")) + on.exit(suppressMessages(methods::removeGeneric("removeS4")), add = TRUE) + S4foo <- new_class("S4foo", package = NULL) + S4_register(S4foo) + on.exit(S4_remove_classes("S4foo"), add = TRUE) + + method(removeS4, S4foo) <- function(x) "foo" + expect_snapshot(method(removeS4, S4foo) <- NULL, error = TRUE) }) From 6bacff4b453d36311e23a262f5bea19ce6764654 Mon Sep 17 00:00:00 2001 From: Hadley Wickham Date: Fri, 29 May 2026 16:01:39 -0500 Subject: [PATCH 3/7] Flatten signatures once --- R/method-register.R | 41 +++++++++++++++++++++-------------------- 1 file changed, 21 insertions(+), 20 deletions(-) diff --git a/R/method-register.R b/R/method-register.R index 97bde028..dbe42a64 100644 --- a/R/method-register.R +++ b/R/method-register.R @@ -87,22 +87,18 @@ register_method <- function( } # Register in current session + signatures <- flatten_signature(signature) if (is_S7_generic(generic)) { - check_method( - method, - generic, - name = method_name(generic, signature), - call = call - ) - register_S7_method(generic, signature, method) + for (sig in signatures) { + register_S7_method(generic, sig, method, call = call) + } } else if (is_S3_generic(generic)) { - for (sig in flatten_signature(signature)) { + for (sig in signatures) { register_S3_method(generic, sig, method, env, call = call) } } else if (is_S4_generic(generic)) { - signatures <- flatten_signature(signature) - for (signature in signatures) { - register_S4_method(generic, signature, method, env, call = call) + for (sig in signatures) { + register_S4_method(generic, sig, method, env, call = call) } } @@ -152,15 +148,20 @@ unregister_method <- function( invisible(generic) } -register_S7_method <- function(generic, signature, method) { - # Flatten out unions to individual signatures - signatures <- flatten_signature(signature) - - # Register each method - for (signature in signatures) { - method <- S7_method(method, generic = generic, signature = signature) - generic_add_method(generic, signature, method) - } +register_S7_method <- function( + generic, + signature, + method, + call = sys.call(-1L) +) { + check_method( + method, + generic, + name = method_name(generic, signature), + call = call + ) + method <- S7_method(method, generic = generic, signature = signature) + generic_add_method(generic, signature, method) invisible() } From 66480d9d0b5dd7562dbf8abfd96a995f9b1ba864 Mon Sep 17 00:00:00 2001 From: Hadley Wickham Date: Fri, 29 May 2026 16:04:44 -0500 Subject: [PATCH 4/7] Polish news and docs --- NEWS.md | 2 +- R/method-register.R | 14 ++++---------- man/method-set.Rd | 14 ++++---------- 3 files changed, 9 insertions(+), 21 deletions(-) diff --git a/NEWS.md b/NEWS.md index 6b42f35f..625bf167 100644 --- a/NEWS.md +++ b/NEWS.md @@ -9,7 +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). +* `method<-` can now register methods on S3 and S4 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) (#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 dbe42a64..59419891 100644 --- a/R/method-register.R +++ b/R/method-register.R @@ -21,7 +21,7 @@ #' or an [S4 generic][methods::setGeneric]. #' @param signature A method signature. #' -#' For S7 generics that use single dispatch, this must be one of the +#' For single single dispatch generics, this must be one of the #' following: #' #' * An S7 class (created by [new_class()]). @@ -30,16 +30,10 @@ #' * An S4 class (created by [methods::getClass()] or [methods::new()]). #' * A base type like [class_logical], [class_integer], or [class_numeric]. #' * A special type like [class_missing] or [class_any]. +#' * A length-1 list containing any of the above. #' -#' 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 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. +#' For generics that use multiple dispatch, this must be a list of any of +#' the above types. #' @param value A function that implements the generic specification for the #' given `signature`, or `NULL` to unregister an existing method. #' @returns The `generic`, invisibly. diff --git a/man/method-set.Rd b/man/method-set.Rd index dfda98fd..9a2b0121 100644 --- a/man/method-set.Rd +++ b/man/method-set.Rd @@ -13,7 +13,7 @@ or an \link[methods:setGeneric]{S4 generic}.} \item{signature}{A method signature. -For S7 generics that use single dispatch, this must be one of the +For single single dispatch generics, this must be one of the following: \itemize{ \item An S7 class (created by \code{\link[=new_class]{new_class()}}). @@ -22,17 +22,11 @@ following: \item An S4 class (created by \code{\link[methods:getClass]{methods::getClass()}} or \code{\link[methods:new]{methods::new()}}). \item A base type like \link{class_logical}, \link{class_integer}, or \link{class_numeric}. \item A special type like \link{class_missing} or \link{class_any}. +\item A length-1 list containing any of the above. } -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 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.} +For generics that use multiple dispatch, this must be a list of any of +the above types.} \item{value}{A function that implements the generic specification for the given \code{signature}, or \code{NULL} to unregister an existing method.} From b3113bc30e48c47750531e5b24602d692938b3a0 Mon Sep 17 00:00:00 2001 From: Hadley Wickham Date: Mon, 1 Jun 2026 08:44:03 -0500 Subject: [PATCH 5/7] Update compatibility --- vignettes/compatibility.Rmd | 11 ++--------- 1 file changed, 2 insertions(+), 9 deletions(-) diff --git a/vignettes/compatibility.Rmd b/vignettes/compatibility.Rmd index b674d4cf..43e318f2 100644 --- a/vignettes/compatibility.Rmd +++ b/vignettes/compatibility.Rmd @@ -34,13 +34,8 @@ There are two main differences between an S7 object and an S3 object: All up, this means most usage of S7 with S3 will just work. -- S7 can register methods for: - - - S7 class and S3 generic - - S3 class and S7 generic - +- S7 can register methods for S3 generics and S3 classes - S7 classes can extend S3 classes - - S3 classes can extend S7 classes ### Methods @@ -153,9 +148,7 @@ The chief difference is that they can be dynamic. - S7 classes can not extend S4 classes - S4 classes can extend S3 classes -- S7 can register methods for: - - S7 class and S4 generic - - S4 class and S7 generic +- S7 can register methods for S4 generics and S4 classes ### Unions From 57eaffa54080dff2261bf95d6fbbd6060ca64bfa Mon Sep 17 00:00:00 2001 From: Hadley Wickham Date: Tue, 2 Jun 2026 13:40:18 -0400 Subject: [PATCH 6/7] Update R/method-register.R Co-authored-by: Tomasz Kalinowski --- R/method-register.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/R/method-register.R b/R/method-register.R index 59419891..88555526 100644 --- a/R/method-register.R +++ b/R/method-register.R @@ -21,7 +21,7 @@ #' or an [S4 generic][methods::setGeneric]. #' @param signature A method signature. #' -#' For single single dispatch generics, this must be one of the +#' For single-dispatch generics, this must be one of the #' following: #' #' * An S7 class (created by [new_class()]). From 9301a8a97166bb46148fa3eaefbc729a003ab854 Mon Sep 17 00:00:00 2001 From: Hadley Wickham Date: Tue, 2 Jun 2026 13:40:36 -0400 Subject: [PATCH 7/7] Re-document --- man/method-set.Rd | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/man/method-set.Rd b/man/method-set.Rd index 9a2b0121..3867a1d4 100644 --- a/man/method-set.Rd +++ b/man/method-set.Rd @@ -13,7 +13,7 @@ or an \link[methods:setGeneric]{S4 generic}.} \item{signature}{A method signature. -For single single dispatch generics, this must be one of the +For single-dispatch generics, this must be one of the following: \itemize{ \item An S7 class (created by \code{\link[=new_class]{new_class()}}).