S7 support

DESCRIPTION

@@ -12,6 +12,7 @@ Imports:
     methods
 Suggests: 
     pkgload,
+    S7,
     testthat (>= 3.0.0)
 Config/testthat/edition: 3
 Depends: R (>= 4.1)

R/find-s7.R

@@ -0,0 +1,52 @@
+is_s7_generic <- function(x) {
+  fn <- tryCatch(match.fun(x), error = function(e) NULL)
+  inherits(fn, "S7_generic")
+}
+
+# Eventually use something from S7: https://github.com/RConsortium/S7/issues/597
+methods_find_s7 <- function(generic, name) {
+  methods_env <- attr(generic, "methods")
+  methods <- s7_walk_methods(methods_env)
+
+  if (length(methods) == 0) {
+    return(data.frame(
+      method = character(),
+      class = character(),
+      package = character(),
+      topic = character(),
+      visible = logical(),
+      source = character(),
+    ))
+  }
+
+  class <- vapply(methods, \(m) paste(m$classes, collapse = ","), character(1))
+
+  # S7 method topic aliases follow S4 convention: generic,class-method.
+  method <- paste0(name, ",", class, "-method")
+  package <- vapply(methods, \(m) fn_package(m$method), character(1))
+  topic <- help_topic(method, package)
+
+  data.frame(
+    method = method,
+    class = class,
+    package = package,
+    topic = topic,
+    visible = rep(TRUE, length(methods)),
+    source = rep(NA_character_, length(methods))
+  )
+}
+
+# Recursively walk S7 method table (nested environments) to extract all methods
+s7_walk_methods <- function(env, signature = character()) {
+  result <- list()
+  for (nm in sort(ls(env))) {
+    val <- env[[nm]]
+    if (is.environment(val)) {
+      result <- c(result, s7_walk_methods(val, c(signature, nm)))
+    } else {
+      method <- list(classes = c(signature, nm), method = val)
+      result <- c(result, list(method))
+    }
+  }
+  result
+}

R/find.R

@@ -1,5 +1,9 @@
 # Modified from sloop::methods_generic
 methods_find <- function(x) {
+  if (is_s7_generic(x)) {
+    return(methods_find_s7(match.fun(x), x))
+  }
+
   info <- attr(utils::methods(x), "info")
 
   if (nrow(info) == 0) {
@@ -78,19 +82,11 @@ lookup_package <- function(generic, class, is_s4) {
       fn <- utils::getS3method(generic, class, optional = TRUE)
     }
 
-    # Not found
     if (is.null(fn)) {
       return(NA_character_)
     }
 
-    pkg <- utils::packageName(environment(fn))
-
-    # Function method found, but in a non-package environment
-    if (is.null(pkg)) {
-      return(NA_character_)
-    }
-
-    pkg
+    fn_package(fn)
   }
 
   pkgs <- mapply(lookup_single_package, generic, class, is_s4, SIMPLIFY = FALSE)

R/utils.R

@@ -13,7 +13,12 @@ find_package <- function(x) {
   if (is.null(fn)) {
     return(NULL)
   }
-  utils::packageName(environment(fn))
+  fn_package(fn)
+}
+
+fn_package <- function(fn) {
+  pkg <- utils::packageName(environment(fn))
+  if (is.null(pkg)) NA_character_ else pkg
 }
 
 last <- function(x, n = 0) {

tests/testthat/_snaps/find-s7.md

@@ -0,0 +1,20 @@
+# S7 methods_list output
+
+    Code
+      cat(methods_list("s7_method"))
+    Output
+      \itemize{
+        \item \code{\link[=s7-method-2]{character}}
+        \item \code{integer}
+      }
+
+# S7 multi-dispatch methods_list output
+
+    Code
+      cat(methods_list("s7_multi"))
+    Output
+      \itemize{
+        \item \code{\link[=s7-multi-2]{character,integer}}
+        \item \code{integer,character}
+      }
+

tests/testthat/test-find-s7.R

@@ -0,0 +1,25 @@
+test_that("methods_find finds S7 methods", {
+  local_load_all("testS7Docs")
+  result <- methods_find("s7_method")
+  expect_equal(result$class, c("character", "integer"))
+  expect_equal(result$package, rep("testS7Docs", 2))
+  expect_equal(result$topic, c("s7-method-2", "s7_method"))
+})
+
+test_that("methods_find finds S7 multi-dispatch methods", {
+  local_load_all("testS7Docs")
+  result <- methods_find("s7_multi")
+  expect_equal(result$class, c("character,integer", "integer,character"))
+  expect_equal(result$package, rep("testS7Docs", 2))
+  expect_equal(result$topic, c("s7-multi-2", "s7_multi"))
+})
+
+test_that("S7 methods_list output", {
+  local_load_all("testS7Docs")
+  expect_snapshot(cat(methods_list("s7_method")))
+})
+
+test_that("S7 multi-dispatch methods_list output", {
+  local_load_all("testS7Docs")
+  expect_snapshot(cat(methods_list("s7_multi")))
+})

tests/testthat/testS7Docs/DESCRIPTION

@@ -0,0 +1,10 @@
+Package: testS7Docs
+Title: Test package for S7 generics
+License: GPL-2
+Description: Test package for S7 generics.
+Author: Hadley <h.wickham@gmail.com>
+Maintainer: Hadley <h.wickham@gmail.com>
+Version: 0.1
+Imports: S7
+Config/roxygen2/version: 7.3.3.9000
+Encoding: UTF-8

tests/testthat/testS7Docs/NAMESPACE

@@ -0,0 +1,4 @@
+# Generated by roxygen2: do not edit by hand
+
+export(s7_method)
+export(s7_multi)

tests/testthat/testS7Docs/R/a.R

@@ -0,0 +1,43 @@
+#' An S7 generic
+#'
+#' @param x,y A parameter
+#' @export
+s7_method <- S7::new_generic("s7_method", "x")
+
+#' @rdname s7_method
+S7::method(s7_method, S7::class_integer) <- function(x, ...) x
+
+#' S7 character method
+#'
+#' @rdname s7-method-2
+S7::method(s7_method, S7::class_character) <- function(x, ...) x
+
+#' An S7 multi-dispatch generic
+#'
+#' @param x,y A parameter
+#' @export
+s7_multi <- S7::new_generic("s7_multi", c("x", "y"))
+
+#' @rdname s7_multi
+S7::method(s7_multi, list(S7::class_integer, S7::class_character)) <- function(
+  x,
+  y,
+  ...
+) {
+  x
+}
+
+#' S7 multi-dispatch method
+#'
+#' @rdname s7-multi-2
+S7::method(s7_multi, list(S7::class_character, S7::class_integer)) <- function(
+  x,
+  y,
+  ...
+) {
+  y
+}
+
+.onLoad <- function(...) {
+  S7::methods_register()
+}