diff --git a/NAMESPACE b/NAMESPACE index a1e3c7e5..f2e43419 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -9,6 +9,7 @@ S3method("[[",S7_object) S3method("[[<-",S7_object) S3method("|",S7_class) S3method(Ops,S7_object) +S3method(Ops,S7_super) S3method(c,S7_class) S3method(print,S7_S3_class) S3method(print,S7_any) @@ -86,7 +87,9 @@ if (getRversion() < "4.3.0") export(`@`) if (getRversion() >= "4.3.0" && !is.null(asNamespace("utils")$.AtNames)) S3method(utils::.AtNames,S7_object) if (getRversion() >= "4.3.0") S3method(base::`@`, S7_object) if (getRversion() >= "4.3.0") S3method(chooseOpsMethod, S7_object) +if (getRversion() >= "4.3.0") S3method(chooseOpsMethod, S7_super) if (getRversion() >= "4.3.0") S3method(matrixOps, S7_object) +if (getRversion() >= "4.3.0") S3method(matrixOps, S7_super) if (getRversion() >= "4.3.0") S3method(nameOfClass, S7_class, S7_class_name) importFrom(stats,setNames) importFrom(utils,getFromNamespace) diff --git a/NEWS.md b/NEWS.md index 42ef54de..f811e59d 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,5 +1,7 @@ # S7 (development version) +* `super()` now works with Ops methods (#357). + * `method()` now generates an informative message when dispatch fails (#387). * S7 provides a new automatic backward compatibility mechanism to provide diff --git a/R/method-ops.R b/R/method-ops.R index a9173574..1e6e8ece 100644 --- a/R/method-ops.R +++ b/R/method-ops.R @@ -26,3 +26,12 @@ chooseOpsMethod.S7_object <- function(x, y, mx, my, cl, reverse) TRUE matrixOps.S7_object <- function(x, y) { base_matrix_ops[[.Generic]](x, y) } + +#' @export +Ops.S7_super <- Ops.S7_object + +#' @rawNamespace if (getRversion() >= "4.3.0") S3method(chooseOpsMethod, S7_super) +chooseOpsMethod.S7_super <- chooseOpsMethod.S7_object + +#' @rawNamespace if (getRversion() >= "4.3.0") S3method(matrixOps, S7_super) +matrixOps.S7_super <- matrixOps.S7_object diff --git a/tests/testthat/test-method-ops.R b/tests/testthat/test-method-ops.R index 877573b2..1c7a9aed 100644 --- a/tests/testthat/test-method-ops.R +++ b/tests/testthat/test-method-ops.R @@ -89,3 +89,16 @@ test_that("`%*%` dispatches to S7 methods", { expect_equal(1 %*% ClassX(), "class_any %*% ClassX") }) +test_that("Ops methods can use super", { + foo <- new_class("foo", class_integer) + foo2 <- new_class("foo2", foo) + + method(`+`, list(foo, class_double)) <- function(e1, e2) { + foo(S7_data(e1) + as.integer(e2)) + } + method(`+`, list(foo2, class_double)) <- function(e1, e2) { + foo2(super(e1, foo) + e2) + } + + expect_equal(foo2(1L) + 1, foo2(2L)) +})