From 71d1c2be72aa11914172fca83f16586f7385692a Mon Sep 17 00:00:00 2001 From: Hadley Wickham Date: Tue, 7 Apr 2026 09:25:33 -0500 Subject: [PATCH 1/6] Add support for S7 --- R/find-s7.R | 68 ++++++++++++++++++++ R/find.R | 4 ++ tests/testthat/_snaps/find-s7.md | 20 ++++++ tests/testthat/test-find-s7.R | 25 +++++++ tests/testthat/testS7Docs/DESCRIPTION | 10 +++ tests/testthat/testS7Docs/NAMESPACE | 4 ++ tests/testthat/testS7Docs/R/a.R | 47 ++++++++++++++ tests/testthat/testS7Docs/man/s7-method-2.Rd | 8 +++ tests/testthat/testS7Docs/man/s7-multi-2.Rd | 8 +++ tests/testthat/testS7Docs/man/s7_method.Rd | 15 +++++ tests/testthat/testS7Docs/man/s7_multi.Rd | 15 +++++ 11 files changed, 224 insertions(+) create mode 100644 R/find-s7.R create mode 100644 tests/testthat/_snaps/find-s7.md create mode 100644 tests/testthat/test-find-s7.R create mode 100644 tests/testthat/testS7Docs/DESCRIPTION create mode 100644 tests/testthat/testS7Docs/NAMESPACE create mode 100644 tests/testthat/testS7Docs/R/a.R create mode 100644 tests/testthat/testS7Docs/man/s7-method-2.Rd create mode 100644 tests/testthat/testS7Docs/man/s7-multi-2.Rd create mode 100644 tests/testthat/testS7Docs/man/s7_method.Rd create mode 100644 tests/testthat/testS7Docs/man/s7_multi.Rd diff --git a/R/find-s7.R b/R/find-s7.R new file mode 100644 index 0000000..9b2cadb --- /dev/null +++ b/R/find-s7.R @@ -0,0 +1,68 @@ +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(), + stringsAsFactors = FALSE + )) + } + + 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, + function(m) { + pkg <- utils::packageName(environment(m$method)) + if (is.null(pkg)) NA_character_ else pkg + }, + 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)), + stringsAsFactors = FALSE + ) +} + +# 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 { + result <- c( + result, + list(list( + classes = c(signature, nm), + method = val + )) + ) + } + } + result +} diff --git a/R/find.R b/R/find.R index 1b16360..0a5d18f 100644 --- a/R/find.R +++ b/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) { diff --git a/tests/testthat/_snaps/find-s7.md b/tests/testthat/_snaps/find-s7.md new file mode 100644 index 0000000..2cd4b90 --- /dev/null +++ b/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} + } + diff --git a/tests/testthat/test-find-s7.R b/tests/testthat/test-find-s7.R new file mode 100644 index 0000000..6a31fa4 --- /dev/null +++ b/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"))) +}) diff --git a/tests/testthat/testS7Docs/DESCRIPTION b/tests/testthat/testS7Docs/DESCRIPTION new file mode 100644 index 0000000..7065a39 --- /dev/null +++ b/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 +Maintainer: Hadley +Version: 0.1 +Imports: S7 +Config/roxygen2/version: 7.3.3.9000 +Encoding: UTF-8 diff --git a/tests/testthat/testS7Docs/NAMESPACE b/tests/testthat/testS7Docs/NAMESPACE new file mode 100644 index 0000000..720b262 --- /dev/null +++ b/tests/testthat/testS7Docs/NAMESPACE @@ -0,0 +1,4 @@ +# Generated by roxygen2: do not edit by hand + +export(s7_method) +export(s7_multi) diff --git a/tests/testthat/testS7Docs/R/a.R b/tests/testthat/testS7Docs/R/a.R new file mode 100644 index 0000000..37bb85a --- /dev/null +++ b/tests/testthat/testS7Docs/R/a.R @@ -0,0 +1,47 @@ +#' An S7 generic +#' +#' @param x,y A parameter +#' @export +s7_method <- S7::new_generic("s7_method", "x") + +#' @rdname s7_method +#' @name s7_method,integer-method +S7::method(s7_method, S7::class_integer) <- function(x, ...) x + +#' S7 character method +#' +#' @rdname s7-method-2 +#' @name s7_method,character-method +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 +#' @name s7_multi,integer,character-method +S7::method(s7_multi, list(S7::class_integer, S7::class_character)) <- function( + x, + y, + ... +) { + x +} + +#' S7 multi-dispatch method +#' +#' @rdname s7-multi-2 +#' @name s7_multi,character,integer-method +S7::method(s7_multi, list(S7::class_character, S7::class_integer)) <- function( + x, + y, + ... +) { + y +} + +.onLoad <- function(...) { + S7::methods_register() +} diff --git a/tests/testthat/testS7Docs/man/s7-method-2.Rd b/tests/testthat/testS7Docs/man/s7-method-2.Rd new file mode 100644 index 0000000..a805fbd --- /dev/null +++ b/tests/testthat/testS7Docs/man/s7-method-2.Rd @@ -0,0 +1,8 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/a.R +\name{s7_method,character-method} +\alias{s7_method,character-method} +\title{S7 character method} +\description{ +S7 character method +} diff --git a/tests/testthat/testS7Docs/man/s7-multi-2.Rd b/tests/testthat/testS7Docs/man/s7-multi-2.Rd new file mode 100644 index 0000000..cddb740 --- /dev/null +++ b/tests/testthat/testS7Docs/man/s7-multi-2.Rd @@ -0,0 +1,8 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/a.R +\name{s7_multi,character,integer-method} +\alias{s7_multi,character,integer-method} +\title{S7 multi-dispatch method} +\description{ +S7 multi-dispatch method +} diff --git a/tests/testthat/testS7Docs/man/s7_method.Rd b/tests/testthat/testS7Docs/man/s7_method.Rd new file mode 100644 index 0000000..6808f02 --- /dev/null +++ b/tests/testthat/testS7Docs/man/s7_method.Rd @@ -0,0 +1,15 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/a.R +\name{s7_method} +\alias{s7_method} +\alias{s7_method,integer-method} +\title{An S7 generic} +\usage{ +s7_method(x, ...) +} +\arguments{ +\item{x, y}{A parameter} +} +\description{ +An S7 generic +} diff --git a/tests/testthat/testS7Docs/man/s7_multi.Rd b/tests/testthat/testS7Docs/man/s7_multi.Rd new file mode 100644 index 0000000..ef9a3fd --- /dev/null +++ b/tests/testthat/testS7Docs/man/s7_multi.Rd @@ -0,0 +1,15 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/a.R +\name{s7_multi} +\alias{s7_multi} +\alias{s7_multi,integer,character-method} +\title{An S7 multi-dispatch generic} +\usage{ +s7_multi(x, y, ...) +} +\arguments{ +\item{x, y}{A parameter} +} +\description{ +An S7 multi-dispatch generic +} From 9c83b57b05bc2332da07cfb4dbd4e2ec37af9548 Mon Sep 17 00:00:00 2001 From: Hadley Wickham Date: Tue, 7 Apr 2026 09:27:45 -0500 Subject: [PATCH 2/6] Document with dev roxygen2 --- tests/testthat/testS7Docs/R/a.R | 4 ---- tests/testthat/testS7Docs/man/s7-method-2.Rd | 4 ++++ tests/testthat/testS7Docs/man/s7-multi-2.Rd | 4 ++++ tests/testthat/testS7Docs/man/s7_method.Rd | 3 +++ tests/testthat/testS7Docs/man/s7_multi.Rd | 3 +++ 5 files changed, 14 insertions(+), 4 deletions(-) diff --git a/tests/testthat/testS7Docs/R/a.R b/tests/testthat/testS7Docs/R/a.R index 37bb85a..5978c90 100644 --- a/tests/testthat/testS7Docs/R/a.R +++ b/tests/testthat/testS7Docs/R/a.R @@ -5,13 +5,11 @@ s7_method <- S7::new_generic("s7_method", "x") #' @rdname s7_method -#' @name s7_method,integer-method S7::method(s7_method, S7::class_integer) <- function(x, ...) x #' S7 character method #' #' @rdname s7-method-2 -#' @name s7_method,character-method S7::method(s7_method, S7::class_character) <- function(x, ...) x #' An S7 multi-dispatch generic @@ -21,7 +19,6 @@ S7::method(s7_method, S7::class_character) <- function(x, ...) x s7_multi <- S7::new_generic("s7_multi", c("x", "y")) #' @rdname s7_multi -#' @name s7_multi,integer,character-method S7::method(s7_multi, list(S7::class_integer, S7::class_character)) <- function( x, y, @@ -33,7 +30,6 @@ S7::method(s7_multi, list(S7::class_integer, S7::class_character)) <- function( #' S7 multi-dispatch method #' #' @rdname s7-multi-2 -#' @name s7_multi,character,integer-method S7::method(s7_multi, list(S7::class_character, S7::class_integer)) <- function( x, y, diff --git a/tests/testthat/testS7Docs/man/s7-method-2.Rd b/tests/testthat/testS7Docs/man/s7-method-2.Rd index a805fbd..b67b5da 100644 --- a/tests/testthat/testS7Docs/man/s7-method-2.Rd +++ b/tests/testthat/testS7Docs/man/s7-method-2.Rd @@ -3,6 +3,10 @@ \name{s7_method,character-method} \alias{s7_method,character-method} \title{S7 character method} +\usage{ +## S7 method for class +s7_method(x, ...) +} \description{ S7 character method } diff --git a/tests/testthat/testS7Docs/man/s7-multi-2.Rd b/tests/testthat/testS7Docs/man/s7-multi-2.Rd index cddb740..7d2aa30 100644 --- a/tests/testthat/testS7Docs/man/s7-multi-2.Rd +++ b/tests/testthat/testS7Docs/man/s7-multi-2.Rd @@ -3,6 +3,10 @@ \name{s7_multi,character,integer-method} \alias{s7_multi,character,integer-method} \title{S7 multi-dispatch method} +\usage{ +## S7 method for classes , +s7_multi(x, y, ...) +} \description{ S7 multi-dispatch method } diff --git a/tests/testthat/testS7Docs/man/s7_method.Rd b/tests/testthat/testS7Docs/man/s7_method.Rd index 6808f02..cfaa99f 100644 --- a/tests/testthat/testS7Docs/man/s7_method.Rd +++ b/tests/testthat/testS7Docs/man/s7_method.Rd @@ -6,6 +6,9 @@ \title{An S7 generic} \usage{ s7_method(x, ...) + +## S7 method for class +s7_method(x, ...) } \arguments{ \item{x, y}{A parameter} diff --git a/tests/testthat/testS7Docs/man/s7_multi.Rd b/tests/testthat/testS7Docs/man/s7_multi.Rd index ef9a3fd..8ae35d7 100644 --- a/tests/testthat/testS7Docs/man/s7_multi.Rd +++ b/tests/testthat/testS7Docs/man/s7_multi.Rd @@ -6,6 +6,9 @@ \title{An S7 multi-dispatch generic} \usage{ s7_multi(x, y, ...) + +## S7 method for classes , +s7_multi(x, y, ...) } \arguments{ \item{x, y}{A parameter} From 6a38236d775f485d784a3f4d5ea1813af7b5173e Mon Sep 17 00:00:00 2001 From: Hadley Wickham Date: Tue, 7 Apr 2026 09:31:35 -0500 Subject: [PATCH 3/6] Needs S7 for tests --- DESCRIPTION | 1 + 1 file changed, 1 insertion(+) diff --git a/DESCRIPTION b/DESCRIPTION index a3866ed..78b6f8c 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -12,6 +12,7 @@ Imports: methods Suggests: pkgload, + S7, testthat (>= 3.0.0) Config/testthat/edition: 3 Depends: R (>= 4.1) From 56d31483b03f91b59c5cabcaca6b331f2a06966b Mon Sep 17 00:00:00 2001 From: Hadley Wickham Date: Tue, 7 Apr 2026 09:39:08 -0500 Subject: [PATCH 4/6] Add `fn_package` helper --- R/find-s7.R | 11 +---------- R/find.R | 10 +--------- R/utils.R | 7 ++++++- 3 files changed, 8 insertions(+), 20 deletions(-) diff --git a/R/find-s7.R b/R/find-s7.R index 9b2cadb..66b220b 100644 --- a/R/find-s7.R +++ b/R/find-s7.R @@ -24,16 +24,7 @@ methods_find_s7 <- function(generic, name) { # S7 method topic aliases follow S4 convention: generic,class-method. method <- paste0(name, ",", class, "-method") - - package <- vapply( - methods, - function(m) { - pkg <- utils::packageName(environment(m$method)) - if (is.null(pkg)) NA_character_ else pkg - }, - character(1) - ) - + package <- vapply(methods, \(m) fn_package(m$method), character(1)) topic <- help_topic(method, package) data.frame( diff --git a/R/find.R b/R/find.R index 0a5d18f..7c76176 100644 --- a/R/find.R +++ b/R/find.R @@ -82,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) diff --git a/R/utils.R b/R/utils.R index e6409ef..67906b2 100644 --- a/R/utils.R +++ b/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) { From 62080d57757f8f4204854370f1d98bb3362c8a48 Mon Sep 17 00:00:00 2001 From: Hadley Wickham Date: Tue, 7 Apr 2026 09:41:19 -0500 Subject: [PATCH 5/6] Drop stringsAsFactors --- R/find-s7.R | 4 +--- 1 file changed, 1 insertion(+), 3 deletions(-) diff --git a/R/find-s7.R b/R/find-s7.R index 66b220b..58fbfad 100644 --- a/R/find-s7.R +++ b/R/find-s7.R @@ -16,7 +16,6 @@ methods_find_s7 <- function(generic, name) { topic = character(), visible = logical(), source = character(), - stringsAsFactors = FALSE )) } @@ -33,8 +32,7 @@ methods_find_s7 <- function(generic, name) { package = package, topic = topic, visible = rep(TRUE, length(methods)), - source = rep(NA_character_, length(methods)), - stringsAsFactors = FALSE + source = rep(NA_character_, length(methods)) ) } From 59feb5521bdc4d70a7c5440f0378586ae922c842 Mon Sep 17 00:00:00 2001 From: Hadley Wickham Date: Tue, 7 Apr 2026 09:43:59 -0500 Subject: [PATCH 6/6] Clarify recursive --- R/find-s7.R | 9 ++------- 1 file changed, 2 insertions(+), 7 deletions(-) diff --git a/R/find-s7.R b/R/find-s7.R index 58fbfad..88b681b 100644 --- a/R/find-s7.R +++ b/R/find-s7.R @@ -44,13 +44,8 @@ s7_walk_methods <- function(env, signature = character()) { if (is.environment(val)) { result <- c(result, s7_walk_methods(val, c(signature, nm))) } else { - result <- c( - result, - list(list( - classes = c(signature, nm), - method = val - )) - ) + method <- list(classes = c(signature, nm), method = val) + result <- c(result, list(method)) } } result