diff --git a/NEWS.md b/NEWS.md index 6022f984..592625e8 100644 --- a/NEWS.md +++ b/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). diff --git a/R/method-dispatch.R b/R/method-dispatch.R index 40f21fbe..a8889d15 100644 --- a/R/method-dispatch.R +++ b/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 diff --git a/R/method-ops.R b/R/method-ops.R index 3ebbda22..48aae74e 100644 --- a/R/method-ops.R +++ b/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) diff --git a/tests/testthat/test-method-dispatch.R b/tests/testthat/test-method-dispatch.R index 350a8b04..b8507ba2 100644 --- a/tests/testthat/test-method-dispatch.R +++ b/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") }) diff --git a/tests/testthat/test-method-ops.R b/tests/testthat/test-method-ops.R index 877573b2..af98b072 100644 --- a/tests/testthat/test-method-ops.R +++ b/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[["+"]])