Explore group generics implementation

NAMESPACE

@@ -8,7 +8,10 @@ S3method("[<-",S7_object)
 S3method("[[",S7_object)
 S3method("[[<-",S7_object)
 S3method("|",S7_class)
+S3method(Complex,S7_object)
+S3method(Math,S7_object)
 S3method(Ops,S7_object)
+S3method(Summary,S7_object)
 S3method(c,S7_class)
 S3method(print,S7_S3_class)
 S3method(print,S7_any)

R/method-group.R

@@ -0,0 +1,40 @@
+group_generic_Math <- NULL
+group_generic_Ops <- NULL
+group_generic_Complex <- NULL
+group_generic_Sumary <- NULL
+
+on_load_define_group_generics <- function() {
+  group_generic_Math <<- new_generic("Math", "x")
+  group_generic_Ops <<- new_generic("Ops", c("e1", "e2"))
+  group_generic_Complex <<- new_generic("Complex", "z")
+  group_generic_Summary <<- new_generic("Summary", "x", function(x, ..., na.rm = FALSE) {
+    S7_dispatch()
+  })
+}
+
+#' @export
+Math.S7_object <- function(x, ...) {
+  group_generic_Math(x, ..., .Generic = .Generic)
+}
+
+#' @export
+Ops.S7_object <- function(e1, e2) {
+  dispatch <- list(obj_dispatch(e1), obj_dispatch(e2))
+  specific <- .Call(method_, base_ops[[.Generic]], dispatch, environment(), FALSE)
+
+  if (!is.null(specific)) {
+    specific(e1, e2)
+  } else {
+    group_generic_Ops(e1, e2, .Generic = match.fun(.Generic))
+  }
+}
+
+#' @export
+Complex.S7_object <- function(z) {
+  group_generic_Complex(z, .Generic = .Generic)
+}
+
+#' @export
+Summary.S7_object <- function(..., na.rm = FALSE, .Generic) {
+  group_generic_Summary(..., na.rm = TRUE, .Generic = .Generic)
+}

R/method-ops.R

@@ -14,11 +14,6 @@ on_load_define_ops <- function() {
   )
 }
 
-#' @export
-Ops.S7_object <- function(e1, e2) {
-  base_ops[[.Generic]](e1, e2)
-}
-
 #' @rawNamespace if (getRversion() >= "4.3.0") S3method(chooseOpsMethod, S7_object)
 chooseOpsMethod.S7_object <- function(x, y, mx, my, cl, reverse) TRUE
 

R/zzz.R

@@ -120,6 +120,7 @@ methods::setOldClass(c("S7_method", "function", "S7_object"))
 
 .onLoad <- function(...) {
   on_load_make_convert_generic()
+  on_load_define_group_generics()
   on_load_define_matrixOps()
   on_load_define_ops()
   on_load_define_or_methods()

tests/testthat/test-method-group.R

@@ -0,0 +1,14 @@
+test_that("specific method overrides group generic", {
+  foo <- new_class("foo", class_integer)
+
+  method(`+`, list(foo, foo)) <- function(e1, e2) {
+    foo(S7_data(e1) + S7_data(e2) + 100L)
+  }
+  method(group_generic_Ops, list(foo, foo)) <- function(e1, e2, .Generic) {
+    foo(.Generic(S7_data(e1), S7_data(e2)))
+  }
+
+  expect_equal(foo(1L) * foo(1:5), foo(1:5))
+  expect_equal(foo(1L) + foo(1:5), foo(1:5 + 101L))
+
+})