From 7a995ea2feaaacdb4be49c7f96c77020dd8f85af Mon Sep 17 00:00:00 2001 From: Tomasz Kalinowski Date: Wed, 6 Nov 2024 11:13:02 -0500 Subject: [PATCH 1/6] fix unary Ops methods: -, +, ! --- R/method-ops.R | 7 ++++++- 1 file changed, 6 insertions(+), 1 deletion(-) diff --git a/R/method-ops.R b/R/method-ops.R index a39ee00b..5e5117f2 100644 --- a/R/method-ops.R +++ b/R/method-ops.R @@ -17,7 +17,12 @@ on_load_define_ops <- function() { #' @export Ops.S7_object <- function(e1, e2) { cnd <- tryCatch( - return(base_ops[[.Generic]](e1, e2)), + return( + if (missing(e2)) + base_ops[[.Generic]](e1) + else + base_ops[[.Generic]](e1, e2) + ), S7_error_method_not_found = function(cnd) cnd ) From 0ad14b6dd801a913c42f86efb7cb93c41e15b01b Mon Sep 17 00:00:00 2001 From: Tomasz Kalinowski Date: Wed, 6 Nov 2024 11:23:16 -0500 Subject: [PATCH 2/6] also check `missing(e2)` in fallback. --- R/method-ops.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/R/method-ops.R b/R/method-ops.R index 5e5117f2..0617940c 100644 --- a/R/method-ops.R +++ b/R/method-ops.R @@ -26,7 +26,7 @@ Ops.S7_object <- function(e1, e2) { S7_error_method_not_found = function(cnd) cnd ) - if (S7_inherits(e1) && S7_inherits(e2)) { + if (S7_inherits(e1) && (missing(e2) || S7_inherits(e2))) { stop(cnd) } else { # Must call NextMethod() directly in the method, not wrapped in an From f75e089526bd59d217aeb9f42b5f9dcbab51c7ce Mon Sep 17 00:00:00 2001 From: Tomasz Kalinowski Date: Wed, 6 Nov 2024 11:25:26 -0500 Subject: [PATCH 3/6] add test --- tests/testthat/test-method-ops.R | 10 ++++++++++ 1 file changed, 10 insertions(+) diff --git a/tests/testthat/test-method-ops.R b/tests/testthat/test-method-ops.R index d825b65e..2dfd1fec 100644 --- a/tests/testthat/test-method-ops.R +++ b/tests/testthat/test-method-ops.R @@ -122,3 +122,13 @@ test_that("Ops methods can use super", { expect_equal(foo2(1L) + 1, foo2(2L)) }) + + +test_that("Unary Ops methods work", { + Double := new_class(class_double) + method(`-`, list(Double, class_missing)) <- function(e1, e2) { + Double(-as.double(e1)) + } + + expect_identical(-Double(1), Double(-1)) +}) From bf7eef86d680422a1645c7e9021c53d2f1656e1f Mon Sep 17 00:00:00 2001 From: Hadley Wickham Date: Mon, 27 Jul 2026 15:53:36 -0500 Subject: [PATCH 4/6] Move return inside --- R/method-ops.R | 11 +++++------ 1 file changed, 5 insertions(+), 6 deletions(-) diff --git a/R/method-ops.R b/R/method-ops.R index baaa90ad..8b6f27ea 100644 --- a/R/method-ops.R +++ b/R/method-ops.R @@ -17,12 +17,11 @@ on_load_define_ops <- function() { #' @export Ops.S7_object <- function(e1, e2) { cnd <- tryCatch( - return( - if (missing(e2)) - base_ops[[.Generic]](e1) - else - base_ops[[.Generic]](e1, e2) - ), + if (missing(e2)) { + return(base_ops[[.Generic]](e1)) + } else { + return(base_ops[[.Generic]](e1, e2)) + }, S7_error_method_not_found = function(cnd) cnd ) From c0b21fc81c913912562ffdd6e7e265329504b1fd Mon Sep 17 00:00:00 2001 From: Hadley Wickham Date: Mon, 27 Jul 2026 16:08:02 -0500 Subject: [PATCH 5/6] Add test and really fix --- NEWS.md | 1 + R/method-ops.R | 2 +- tests/testthat/_snaps/class.md | 1 + tests/testthat/test-method-ops.R | 4 ++++ 4 files changed, 7 insertions(+), 1 deletion(-) diff --git a/NEWS.md b/NEWS.md index f4cf1eb6..deb70463 100644 --- a/NEWS.md +++ b/NEWS.md @@ -22,6 +22,7 @@ * `new_object()` now names its first argument `_parent` to minimise the chance of a clash with a property (#423). It also accepts a single unnamed named list as a shortcut for splicing property values, making it easier to programmatically construct an object from a list of properties (#497). * `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). * `method<-` no longer emits an "Overwriting method" message when re-registering an identical method, eliminating spurious messages from `devtools::load_all()` (#474). +* `method<-` can now register methods for unary operators (e.g. `-x`, `+x`); give the method a signature of `list(Foo, class_missing)`. Previously, applying a unary operator to an S7 object failed with an error about the missing `e2` argument. If no unary method is found, the operator falls back to base behaviour, just as binary operators do (#531). * `new_class()` now errors if a child class overrides a parent property with a type that doesn't extend the parent's type, since such a class could never be instantiated (#352, #708). * `new_class()` now allows properties named `names`, `dim`, `dimnames`, `class`, `comment`, `tsp`, and `row.names`. But property names beginning with `_` are now reserved for internal use (#579). * `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). diff --git a/R/method-ops.R b/R/method-ops.R index 8b6f27ea..3017370d 100644 --- a/R/method-ops.R +++ b/R/method-ops.R @@ -25,7 +25,7 @@ Ops.S7_object <- function(e1, e2) { S7_error_method_not_found = function(cnd) cnd ) - if (S7_inherits(e1) && (missing(e2) || S7_inherits(e2))) { + if (!missing(e2) && S7_inherits(e1) && S7_inherits(e2)) { stop(cnd) } else { # Must call NextMethod() directly in the method, not wrapped in an diff --git a/tests/testthat/_snaps/class.md b/tests/testthat/_snaps/class.md index 14209ee8..9fb56fa6 100644 --- a/tests/testthat/_snaps/class.md +++ b/tests/testthat/_snaps/class.md @@ -314,3 +314,4 @@ Condition Error: ! No S7 class for base type . + diff --git a/tests/testthat/test-method-ops.R b/tests/testthat/test-method-ops.R index b4c1575c..f7443abd 100644 --- a/tests/testthat/test-method-ops.R +++ b/tests/testthat/test-method-ops.R @@ -120,6 +120,7 @@ test_that("Ops generics falls back to base behaviour", { local_methods(base_ops[["+"]]) foo := new_class(parent = class_double) + expect_equal(+foo(1), foo(+1)) expect_equal(foo(1) + 1, foo(2)) expect_equal(foo(1) + 1:2, 2:3) expect_equal(1 + foo(1), foo(2)) @@ -132,6 +133,9 @@ test_that("Ops generics falls back to base behaviour", { expect_equal(foo(1) + 1:2, "foo-numeric") expect_equal(1 + foo(1), "numeric-foo") expect_equal(1:2 + foo(1), "numeric-foo") + + method(`+`, list(foo, class_missing)) <- function(e1, e2) "foo" + expect_equal(+foo(), "foo") }) test_that("`%*%` dispatches to S7 methods", { From 46dd7228ab19a9d5220c28b81953416cc382eef1 Mon Sep 17 00:00:00 2001 From: Hadley Wickham Date: Mon, 27 Jul 2026 16:23:07 -0500 Subject: [PATCH 6/6] Handle `!` --- NEWS.md | 1 + R/generic-spec.R | 12 +++++-- R/method-ops.R | 3 ++ R/method-register.R | 3 +- tests/testthat/_snaps/method-ops.md | 8 +++++ tests/testthat/test-method-ops.R | 54 +++++++++++++++++++++++++++++ 6 files changed, 78 insertions(+), 3 deletions(-) create mode 100644 tests/testthat/_snaps/method-ops.md diff --git a/NEWS.md b/NEWS.md index deb70463..1090db08 100644 --- a/NEWS.md +++ b/NEWS.md @@ -23,6 +23,7 @@ * `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). * `method<-` no longer emits an "Overwriting method" message when re-registering an identical method, eliminating spurious messages from `devtools::load_all()` (#474). * `method<-` can now register methods for unary operators (e.g. `-x`, `+x`); give the method a signature of `list(Foo, class_missing)`. Previously, applying a unary operator to an S7 object failed with an error about the missing `e2` argument. If no unary method is found, the operator falls back to base behaviour, just as binary operators do (#531). +* `method<-` now supports methods for `!`. Unlike the other members of the `Ops` group, `!` is always unary (`1 ! 2` is a syntax error), so it dispatches on a single argument and takes a length-1 signature rather than `list(Foo, class_missing)`. Applying `!` to an S7 object previously failed with "attempt to apply non-function" (#531). * `new_class()` now errors if a child class overrides a parent property with a type that doesn't extend the parent's type, since such a class could never be instantiated (#352, #708). * `new_class()` now allows properties named `names`, `dim`, `dimnames`, `class`, `comment`, `tsp`, and `row.names`. But property names beginning with `_` are now reserved for internal use (#579). * `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). diff --git a/R/generic-spec.R b/R/generic-spec.R index 3caf075b..037c4231 100644 --- a/R/generic-spec.R +++ b/R/generic-spec.R @@ -125,7 +125,12 @@ internal_generics <- function() { } group_generics <- function() { - # S3 group generics can be defined by combining S4 group generics + # S3 group generics can be defined by combining S4 group generics. + # + # This means `Ops` doesn't include `!`, since S4 has no group generic + # containing it. That suits us: every member of this group dispatches on + # `e1` and `e2`, but `!` is always unary. `on_load_define_ops()` gives it a + # single-dispatch generic of its own. groups <- list( Ops = c("Arith", "Compare", "Logic"), Math = c("Math", "Math2"), @@ -142,7 +147,10 @@ group_generics <- function() { ops_group <- function(generic) { group <- group_generics() - if (generic %in% group$Ops) { + # `!` isn't in `group$Ops` (S7 treats it as a standalone unary generic), but + # R still dispatches it through the S3 `Ops` group, so it needs the same + # bridge as the binary operators. + if (generic %in% group$Ops || generic == "!") { "Ops" } else if (generic %in% group$matrixOps) { "matrixOps" diff --git a/R/method-ops.R b/R/method-ops.R index 3017370d..15e27029 100644 --- a/R/method-ops.R +++ b/R/method-ops.R @@ -7,6 +7,9 @@ on_load_define_ops <- function() { new_generic, dispatch_args = c("e1", "e2") ) + # R dispatches `!` through the `Ops` group, but it's always unary + base_ops[["!"]] <<- new_generic("!", dispatch_args = "e1") + base_matrix_ops <<- lapply( setNames(, group_generics()$matrixOps), new_generic, diff --git a/R/method-register.R b/R/method-register.R index 93ffde90..b0e8ad66 100644 --- a/R/method-register.R +++ b/R/method-register.R @@ -275,7 +275,8 @@ as_signature <- function(signature, generic, call = sys.call(-1L)) { if (n == 1) { # Accept a bare list of length 1 too, for symmetry with multi-dispatch # generics where a list is required (#555). - if (is_plain_list(signature) && length(signature) == 1) { + if (is_plain_list(signature)) { + check_signature_list(signature, 1, call = call) signature <- signature[[1]] } new_signature(list(as_class(signature, arg = "signature"))) diff --git a/tests/testthat/_snaps/method-ops.md b/tests/testthat/_snaps/method-ops.md new file mode 100644 index 00000000..c39eb2f6 --- /dev/null +++ b/tests/testthat/_snaps/method-ops.md @@ -0,0 +1,8 @@ +# `!` requires a length-1 signature + + Code + method(`!`, list(Logical, class_missing)) <- (function(e1, e2) e1) + Condition + Error in `method<-`: + ! `signature` must be length 1. + diff --git a/tests/testthat/test-method-ops.R b/tests/testthat/test-method-ops.R index f7443abd..8ebc7ff9 100644 --- a/tests/testthat/test-method-ops.R +++ b/tests/testthat/test-method-ops.R @@ -178,3 +178,57 @@ test_that("Unary Ops methods work", { expect_identical(-Double(1), Double(-1)) }) + +test_that("`!` dispatches on a single argument", { + local_methods(base_ops[["!"]]) + + Logical := new_class(class_logical) + method(`!`, Logical) <- function(e1) Logical(!as.logical(e1)) + + expect_identical(!Logical(TRUE), Logical(FALSE)) +}) + +test_that("`!` requires a length-1 signature", { + local_methods(base_ops[["!"]]) + + Logical := new_class(class_logical) + expect_snapshot(error = TRUE, { + method(`!`, list(Logical, class_missing)) <- function(e1, e2) e1 + }) +}) + +test_that("`!` can use super", { + local_methods(base_ops[["!"]]) + + Logical := new_class(class_logical) + Logical2 := new_class(Logical) + method(`!`, Logical) <- function(e1) "Logical" + method(`!`, Logical2) <- function(e1) paste0(!super(e1, Logical), "2") + + expect_equal(!Logical2(TRUE), "Logical2") +}) + +test_that("`!` dispatches to S7 methods for S3 and S4 classes", { + local_methods(base_ops[["!"]]) + local_S4_classes() + defer(unregister_s3_methods(baseenv(), "Ops")) + + method(`!`, new_S3_class("myS3")) <- function(e1) "myS3" + expect_equal(!structure(TRUE, class = "myS3"), "myS3") + + fooS4 <- setClass("fooS4", contains = "logical") + method(`!`, fooS4) <- function(e1) "fooS4" + expect_equal(!fooS4(TRUE), "fooS4") +}) + +test_that("`!` falls back to base behaviour", { + local_methods(base_ops[["!"]], base_ops[["+"]]) + + foo := new_class(parent = class_logical) + expect_identical(!foo(TRUE), foo(FALSE)) + + # including when the class has a method for a binary operator, which + # registers an `Ops` group method that also catches `!` + method(`+`, list(foo, class_any)) <- function(e1, e2) "foo-any" + expect_identical(!foo(TRUE), foo(FALSE)) +})