Ensure Ops falls back to base behaviour

Fixes #320

NEWS.md

@@ -1,5 +1,12 @@
 # S7 (development version)
 
+* When a method is not found, the error now has class `methodNotFound`.
+
+* 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. 
+
 * S7 provides a new automatic backward compatibility mechanism to provide
   a version of `@` that works in R before version 4.3 (#326).
 

R/method-dispatch.R

@@ -11,7 +11,8 @@ method_lookup_error <- function(name, args, signatures) {
     msg <- sprintf("Can't find method for generic `%s(%s)`:\n%s", name, arg_names, types)
   }
 
-  stop(msg, call. = FALSE)
+  cnd <- errorCondition(message = msg, class = c("methodNotFound", "error"))
+  stop(cnd)
 }
 
 #' @rdname new_generic

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)),
+    methodNotFound = 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 = "methodNotFound")
 })
 
 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 = "methodNotFound")
 })
 
 

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 = "methodNotFound")
 })
 
 test_that("Ops generics dispatch to S3 methods", {
@@ -76,6 +78,19 @@ 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)
+
+  # but can be overridden
+  method(`+`, list(foo, class_numeric)) <- function(e1, e2) "foo-numeric"
+  expect_equal(foo(1) + 1, "foo-numeric")
+  expect_equal(foo(1) + 1:2, "foo-numeric")
+})
+
 test_that("`%*%` dispatches to S7 methods", {
   skip_if(getRversion() < "4.3")
   local_methods(base_ops[["+"]])