Explore group generics implementation

NAMESPACE

@@ -8,6 +8,7 @@ S3method("[<-",S7_object)
 S3method("[[",S7_object)
 S3method("[[<-",S7_object)
 S3method("|",S7_class)
+S3method(Math,S7_object)
 S3method(Ops,S7_object)
 S3method(Ops,S7_super)
 S3method(c,S7_class)
@@ -37,6 +38,10 @@ export("method<-")
 export("prop<-")
 export("props<-")
 export(S4_register)
+export(S7_Complex)
+export(S7_Math)
+export(S7_Ops)
+export(S7_Summary)
 export(S7_class)
 export(S7_data)
 export(S7_dispatch)
@@ -64,6 +69,7 @@ export(class_numeric)
 export(class_raw)
 export(class_vector)
 export(convert)
+export(find_base_generic)
 export(method)
 export(method_explain)
 export(methods_register)

R/method-group.R

@@ -0,0 +1,85 @@
+#' S7 Group Generics
+#'
+#' Group generics allow you to implement methods for many generics at once.
+#' You cannot call a group generic directly; instead it is called automatically
+#' by members of the group if a more specific method is not found. For example,
+#' if you define a method for the `S7_Math` group generic, it will be called
+#' when you call `abs()`, `sign()`, `sqrt()`, and many other similar generics
+#' (see below for a complete list).
+#'
+#' @param x,z,e1,e2 Objects used for dispatch.
+#' @param ...,na.rm Additional arguments passed to methods.
+#' @param .Generic The name of the generic being dispatched on, i.e. if you've
+#'   defined a method for `S7_Math` and the user calls `abs()` then `.Generic`
+#'   will be `"abs"`.
+#'
+#'   Use `find_base_generic()` to find the base generic that corresponds to the
+#'   generic name.
+#' @details
+#' # Methods
+#'
+#' The group generics contain the following methods:
+#'
+#' * `Ops`: `r group_generics_md("Ops")`
+#' * `Math`: `r group_generics_md("Math")`
+#' * `Summary`: `r group_generics_md("Summary")`
+#' * `Complex`: `r group_generics_md("Complex")`
+#' * `matrixOps`: `r group_generics_md("matrixOps")`
+#'
+#' @name S7_group_generics
+NULL
+
+#' @export
+#' @rdname S7_group_generics
+S7_Math <- NULL
+
+#' @export
+#' @rdname S7_group_generics
+S7_Ops <- NULL
+
+#' @export
+#' @rdname S7_group_generics
+S7_Complex <- NULL
+
+#' @export
+#' @rdname S7_group_generics
+S7_Summary <- NULL
+
+on_load_define_group_generics <- function() {
+  S7_Math <<- new_generic("Math", "x", function(x, ..., .Generic) {
+    S7_dispatch()
+  })
+
+  S7_Ops <<- new_generic("Ops", c("e1", "e2"), function(e1, e2, ..., .Generic) {
+    S7_dispatch()
+  })
+
+  S7_Complex <<- new_generic("Complex", "z", function(z, ..., .Generic) {
+    S7_dispatch()
+  })
+
+  S7_Summary <<- new_generic("Summary", "x", function(x, ..., na.rm = FALSE, .Generic) {
+    S7_dispatch()
+  })
+}
+
+#' @export
+Math.S7_object <- function(x, ...) {
+  tryCatch(
+    return(S7_Math(x, ..., .Generic = .Generic)),
+    S7_error_method_not_found = function(cnd) NULL
+  )
+
+  NextMethod()
+}
+
+#' @export
+#' @rdname S7_group_generics
+find_base_generic <- function(.Generic) {
+  get(.Generic, mode = "function", envir = baseenv())
+}
+
+
+group_generics_md <- function(name) {
+  paste0("`", group_generics()[[name]], "`", collapse = ", ")
+}

R/method-ops.R

@@ -16,17 +16,24 @@ on_load_define_ops <- function() {
 
 #' @export
 Ops.S7_object <- function(e1, e2) {
+  # Try "specific" generic
   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.
+  # Try group generic
+  cnd <- tryCatch(
+    return(S7_Ops(e1, e2, .Generic = .Generic)),
+    S7_error_method_not_found = function(cnd) cnd
+  )
+
+  if (!S7_inherits(e1) || !S7_inherits(e2)) {
+    # Fall back to base behaviour. Must call NextMethod() directly here, not
+    # wrapped in an anonymous function.
     NextMethod()
+  } else {
+    stop(cnd)
   }
 }
 

R/zzz.R

@@ -122,6 +122,7 @@ methods::setOldClass(c("S7_method", "function", "S7_object"))
   activate_backward_compatiblility()
 
   on_load_make_convert_generic()
+  on_load_define_group_generics()
   on_load_define_ops()
   on_load_define_or_methods()
   on_load_define_S7_type()

_pkgdown.yml

@@ -30,6 +30,7 @@ reference:
   - method_explain
   - super
   - S7_class
+  - S7_group_generics
 
 - title: Packages
   desc: >

tests/testthat/_snaps/method-group.md

@@ -0,0 +1,8 @@
+# can provide Math group generic
+
+    Code
+      abs(foo1(-1, 2))
+    Condition
+      Error in `abs.default()`:
+      ! non-numeric argument to mathematical function
+

tests/testthat/test-method-group.R

@@ -0,0 +1,21 @@
+test_that("can provide Math group generic", {
+  local_methods(S7_Math)
+  foo1 <- new_class("foo1", properties = list(x = class_double, y = class_double))
+  foo2 <- new_class("foo2", class_double)
+
+  # base behaviour
+  expect_snapshot(abs(foo1(-1, 2)), error = TRUE)
+  expect_equal(abs(foo2(c(-1, 2))), foo2(c(1, 2)))
+
+  method(S7_Math, foo1) <- function(x, ..., .Generic) {
+    .Generic <- find_base_generic(.Generic)
+    foo1(.Generic(x@x, ...), .Generic(x@y, ...))
+  }
+  expect_equal(abs(foo1(-1, 2)), foo1(1, 2))
+
+  method(S7_Math, foo2) <- function(x, ..., .Generic) {
+    .Generic <- find_base_generic(.Generic)
+    foo2(.Generic(S7_data(x, ...)))
+  }
+  expect_equal(abs(foo2(c(-1, 2))), foo2(c(1, 2)))
+})

tests/testthat/test-method-ops.R

@@ -96,6 +96,23 @@ test_that("Ops generics falls back to base behaviour", {
   expect_equal(1:2 + foo(1), "numeric-foo")
 })
 
+test_that("specific method overrides group generic", {
+  local_methods(base_ops[["+"]], S7_Ops)
+
+  foo <- new_class("foo", class_integer)
+
+  method(`+`, list(foo, foo)) <- function(e1, e2) {
+    foo(S7_data(e1) + S7_data(e2) + 100L)
+  }
+  method(S7_Ops, list(foo, foo)) <- function(e1, e2, .Generic) {
+    .Generic <- find_base_generic(.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 + 1L + 100L))
+})
+
 test_that("`%*%` dispatches to S7 methods", {
   skip_if(getRversion() < "4.3")
   local_methods(base_ops[["+"]])