fix unary Ops methods: -, +, !

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).

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"

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

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")))

tests/testthat/_snaps/class.md

@@ -314,3 +314,4 @@
     Condition
       Error:
       ! No S7 class for base type <pairlist>.
+

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.
+

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))
+})