diff --git a/NEWS.md b/NEWS.md index ebe53a0b..624b3d0a 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 `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). diff --git a/R/method-dispatch.R b/R/method-dispatch.R index 5aad227a..d612d399 100644 --- a/R/method-dispatch.R +++ b/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) { diff --git a/R/method-ops.R b/R/method-ops.R index 1e6e8ece..a39ee00b 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)), + 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) diff --git a/tests/testthat/test-method-dispatch.R b/tests/testthat/test-method-dispatch.R index 350a8b04..fb71db11 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 = "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") }) diff --git a/tests/testthat/test-method-ops.R b/tests/testthat/test-method-ops.R index 1c7a9aed..d825b65e 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 = "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[["+"]])