Register Ops bridges for S3/S4 classes (#679)

Fixes #544

Author: hadley

NEWS.md

@@ -8,6 +8,7 @@
 * `convert()` no longer automatically converts between sibling classes (classes that merely share a common ancestor); the default downcast now applies only when `to` is genuinely a descendant of `from`'s class (#509).
 * `convert()` now falls back to the corresponding `as.*()` function (e.g. `as.character()`) when converting to a base type like `class_character` and no method or inheritance-based default applies, so `convert(1, class_character)` works out of the box (#472).
 * `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 works for double-dispatch operators (e.g. `+`, `==`, `%*%`) with plain S3 or S4 classes, even when neither operand is an S7 object (#544).
 * `method<-` no longer embeds a copy of a generic owned by another package in your package namespace. Instead it returns a sentinel value that the new `S7_on_build()` removes from the namespace at build time; call `S7_on_build()` at the top level of `zzz.R` (see `vignette("packages")`) (#364).
 * `method<-` now accepts `NULL` to unregister an existing method, e.g. `method(foo, class_character) <- NULL` (#613).
 * `convert()` is now idempotent when `from` is already an instance of `to`, returning it unchanged. When `from` inherits from `to` but is more specific, dispatch is now restricted to classes more specific than `to`, so an inherited downcasting method can no longer be selected in place of an upcast (#429).

R/generic-spec.R

@@ -139,3 +139,14 @@ group_generics <- function() {
   }
   out
 }
+
+ops_group <- function(generic) {
+  group <- group_generics()
+  if (generic %in% group$Ops) {
+    "Ops"
+  } else if (generic %in% group$matrixOps) {
+    "matrixOps"
+  } else {
+    NULL
+  }
+}

R/method-ops.R

@@ -48,3 +48,40 @@ chooseOpsMethod.S7_super <- chooseOpsMethod.S7_object
 
 #' @rawNamespace if (getRversion() >= "4.3.0") S3method(matrixOps, S7_super)
 matrixOps.S7_super <- matrixOps.S7_object
+
+# Bridge base operators to S7 operators for S3/S4 registration
+register_ops_bridge <- function(generic, signatures, env) {
+  group <- ops_group(generic@name)
+  if (is.null(group)) {
+    return(invisible())
+  }
+
+  classes <- unique(unlist(lapply(signatures, function(sig) {
+    lapply(sig, ops_bridge_class)
+  })))
+
+  for (class in classes) {
+    # Don't clobber an existing group methods
+    if (has_s3_method(group, class, env)) {
+      next
+    }
+
+    # Re-use `Ops.S7_object`/`matrixOps.S7_object` to avoid conflicting methods
+    generic <- if (group == "Ops") Ops.S7_object else matrixOps.S7_object
+    registerS3method(group, class, generic, envir = env)
+  }
+  invisible()
+}
+
+has_s3_method <- function(generic, class, env) {
+  !is.null(utils::getS3method(generic, class, envir = env, optional = TRUE))
+}
+
+ops_bridge_class <- function(x) {
+  switch(
+    class_type(x),
+    S7_S3 = x$class[[1]],
+    S4 = x@className,
+    NULL
+  )
+}

R/method-register.R

@@ -91,6 +91,7 @@ register_method <- function(
     for (sig in signatures) {
       register_S7_method(generic, sig, method, call = call)
     }
+    register_ops_bridge(generic, signatures, env)
   } else if (is_S3_generic(generic)) {
     for (sig in signatures) {
       register_S3_method(generic, sig, method, env, call = call)

tests/testthat/helper.R

@@ -106,6 +106,13 @@ local_s3_generic <- function(name, frame = parent.frame()) {
   invisible()
 }
 
+# Define an S3 method in globalenv() and remove it again on exit.
+local_s3_method <- function(name, fun, frame = parent.frame()) {
+  assign(name, fun, envir = globalenv())
+  defer(rm(list = name, envir = globalenv()), frame = frame)
+  invisible()
+}
+
 unregister_s3_methods <- function(envir, generic) {
   tbl <- envir[[".__S3MethodsTable__."]]
   if (!is.null(tbl)) {

tests/testthat/test-method-ops.R

@@ -22,6 +22,7 @@ test_that("Ops generics dispatch to S7 methods for S7 classes", {
 test_that("Ops generics dispatch to S3 methods", {
   skip_if(getRversion() < "4.3")
   local_methods(base_ops[["+"]])
+  defer(unregister_s3_methods(baseenv(), "Ops"))
 
   foo <- new_class("foo")
   method(`+`, list(class_factor, foo)) <- function(e1, e2) "factor-foo"
@@ -32,8 +33,7 @@ test_that("Ops generics dispatch to S3 methods", {
 
   # Even if custom method exists
   foo_S3 <- structure(list(), class = "foo_S3")
-  assign("+.foo_S3", function(e1, e2) stop("Failure!"), envir = globalenv())
-  defer(rm("+.foo_S3", envir = globalenv()))
+  local_s3_method("+.foo_S3", function(e1, e2) stop("Failure!"))
 
   method(`+`, list(new_S3_class("foo_S3"), foo)) <- function(e1, e2) "S3-S7"
   method(`+`, list(foo, new_S3_class("foo_S3"))) <- function(e1, e2) "S7-S3"
@@ -42,6 +42,39 @@ test_that("Ops generics dispatch to S3 methods", {
   expect_equal(foo_S3 + foo(), "S3-S7")
 })
 
+test_that("operator methods on S3/S4 classes work when neither operand is S7", {
+  local_methods(base_ops[["+"]])
+
+  class_foo <- new_S3_class("foo")
+  foo <- structure(list(), class = "foo")
+  method(`+`, list(class_foo, class_any)) <- function(e1, e2) "foo+any"
+  expect_equal(foo + 10, "foo+any")
+
+  fooS4 <- local_S4_class("fooS4")
+  method(`+`, list(fooS4, class_any)) <- function(e1, e2) "fooS4+any"
+  expect_equal(fooS4("x") + 10, "fooS4+any")
+
+  # An unregistered operator still falls back to the base behaviour
+  expect_error(foo * 10, regexp = "non-numeric argument")
+})
+
+test_that("operator bridge does not clobber an existing group method", {
+  skip_if(getRversion() < "4.3")
+  local_methods(base_ops[["+"]])
+  defer(unregister_s3_methods(baseenv(), "Ops"))
+
+  local_s3_method("Ops.myS3", function(e1, e2) "myS3-ops")
+  method(`+`, list(new_S3_class("myS3"), class_any)) <- function(e1, e2) "!"
+
+  # + method used for S7 classes
+  x <- structure(list(), class = "myS3")
+  foo <- new_class("foo")
+  expect_equal(x + foo(), "!")
+
+  # but `Ops.myS3` used for base/S3 classes
+  expect_equal(x + 10, "myS3-ops")
+})
+
 test_that("Ops generics dispatch to S7 methods for S4 classes", {
   local_methods(base_ops[["+"]])
   fooS4 <- local_S4_class("foo", contains = "character")