diff --git a/NEWS.md b/NEWS.md index f4cf1eb6..1090db08 100644 --- a/NEWS.md +++ b/NEWS.md @@ -22,6 +22,8 @@ * `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). +* `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 39a74310..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, @@ -17,11 +20,15 @@ on_load_define_ops <- function() { #' @export Ops.S7_object <- function(e1, e2) { cnd <- tryCatch( - return(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 ) - if (S7_inherits(e1) && 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/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/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/_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 6273f17f..8ebc7ff9 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", { @@ -164,3 +168,67 @@ 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)) +}) + +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)) +})