Add missing S7_super method for Ops (#359)

Fixes #357
RConsortium · Nov 29, 2023 · e9ebe6f · e9ebe6f
1 parent 687c173
commit e9ebe6f
Show file tree

Hide file tree

Showing 4 changed files with 27 additions and 0 deletions.
diff --git 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
@@ -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
@@ -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
@@ -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))
+})