Ensure Ops falls back to base behaviour (RConsortium#382)

Fixes RConsortium#320

Author: hadley

NEWS.md

@@ -1,5 +1,12 @@
 # S7 (development version)
 
+* When a method is not found, the error now has class `S7_error_method_not_found`.
+
+* The `Ops` generic now falls back to base Ops behaviour when one of the 
+  arguments is not an S7 object (#320). This means that you get the somewhat 
+  inconsistent base behaviour, but means that S7 doesn't introduce a new axis 
+  of inconsistency. 
+
 * In `new_class()`, properties can either be named by naming the element
   of the list or by supplying the `name` argument to `new_property()` (#371).
 

R/method-dispatch.R

@@ -2,7 +2,8 @@
 method_lookup_error <- function(name, args) {
   types <- vcapply(args, obj_desc)
   msg <- method_lookup_error_message(name, types)
-  stop(msg, call. = FALSE)
+  cnd <- errorCondition(msg, class = c("S7_error_method_not_found", "error"))
+  stop(cnd)
 }
 
 method_lookup_error_message <- function(name, types) {

R/method-ops.R

@@ -16,7 +16,18 @@ on_load_define_ops <- function() {
 
 #' @export
 Ops.S7_object <- function(e1, e2) {
-  base_ops[[.Generic]](e1, e2)
+  cnd <- tryCatch(
+    return(base_ops[[.Generic]](e1, e2)),
+    S7_error_method_not_found = function(cnd) cnd
+  )
+
+  if (S7_inherits(e1) && S7_inherits(e2)) {
+    stop(cnd)
+  } else {
+    # Must call NextMethod() directly in the method, not wrapped in an
+    # anonymous function.
+    NextMethod()
+  }
 }
 
 #' @rawNamespace if (getRversion() >= "4.3.0") S3method(chooseOpsMethod, S7_object)

tests/testthat/test-method-dispatch.R

@@ -143,6 +143,8 @@ test_that("single dispatch fails with informative messages", {
     fail(foo())
     fail(Foo(x = 1))
   })
+
+  expect_error(fail(TRUE), class = "S7_error_method_not_found")
 })
 
 test_that("multiple dispatch fails with informative messages", {
@@ -157,6 +159,8 @@ test_that("multiple dispatch fails with informative messages", {
     fail(, TRUE)
     fail(TRUE, TRUE)
   })
+
+  expect_error(fail(TRUE, TRUE), class = "S7_error_method_not_found")
 })
 
 

tests/testthat/test-method-ops.R

@@ -12,6 +12,8 @@ test_that("Ops generics dispatch to S7 methods for S7 classes", {
   expect_equal(foo1() + foo2(), "foo1-foo2")
   expect_equal(foo2() + foo1(), "foo2-foo1")
   expect_equal(foo2() + foo2(), "foo2-foo2")
+
+  expect_error(foo1() + new_class("foo3")(), class = "S7_error_method_not_found")
 })
 
 test_that("Ops generics dispatch to S3 methods", {
@@ -76,6 +78,24 @@ test_that("Ops generics dispatch to S7 methods for NULL", {
   expect_equal(NULL + foo(), "NULL-foo")
 })
 
+test_that("Ops generics falls back to base behaviour", {
+  local_methods(base_ops[["+"]])
+
+  foo <- new_class("foo", parent = class_double)
+  expect_equal(foo(1) + 1, foo(2))
+  expect_equal(foo(1) + 1:2, 2:3)
+  expect_equal(1 + foo(1), foo(2))
+  expect_equal(1:2 + foo(1), 2:3)
+
+  # but can be overridden
+  method(`+`, list(foo, class_numeric)) <- function(e1, e2) "foo-numeric"
+  method(`+`, list(class_numeric, foo)) <- function(e1, e2) "numeric-foo"
+  expect_equal(foo(1) + 1, "foo-numeric")
+  expect_equal(foo(1) + 1:2, "foo-numeric")
+  expect_equal(1 + foo(1), "numeric-foo")
+  expect_equal(1:2 + foo(1), "numeric-foo")
+})
+
 test_that("`%*%` dispatches to S7 methods", {
   skip_if(getRversion() < "4.3")
   local_methods(base_ops[["+"]])