Class/generic/methods introspection

NAMESPACE

@@ -11,6 +11,8 @@ S3method("|",S7_class)
 S3method(Ops,S7_object)
 S3method(Ops,S7_super)
 S3method(c,S7_class)
+S3method(format,S7_signature)
+S3method(format,S7_signature_list)
 S3method(print,S7_S3_class)
 S3method(print,S7_any)
 S3method(print,S7_base_class)
@@ -21,6 +23,8 @@ S3method(print,S7_method)
 S3method(print,S7_missing)
 S3method(print,S7_object)
 S3method(print,S7_property)
+S3method(print,S7_signature)
+S3method(print,S7_signature_list)
 S3method(print,S7_super)
 S3method(print,S7_union)
 S3method(str,S7_S3_class)
@@ -39,9 +43,12 @@ export("props<-")
 export(S4_register)
 export(S7_class)
 export(S7_class_desc)
+export(S7_classes)
 export(S7_data)
 export(S7_dispatch)
+export(S7_generics)
 export(S7_inherits)
+export(S7_methods)
 export(S7_object)
 export(as_class)
 export(check_is_S7)

NEWS.md

@@ -19,6 +19,7 @@
 * `prop()` no longer leaves an object in a broken state when a custom getter signals an error (#520, #640, #638).
 * `prop<-()` no longer fails when assigning a call or symbol to a property (#511, #633, #638).
 * New `prop_info()` returns a data frame summarising the properties of an S7 object or class, with one row per property and columns for name, default, class, getter, setter, and validator (#551).
+* New `S7_classes()`, `S7_generics()`, and `S7_methods()` are new introspection helpers. `S7_classes()` and `S7_generics()` list the S7 classes / generics defined in a given environment; pass `asNamespace("pkg")` to inspect a specific package (#335). `S7_methods()` returns a data frame of methods registered on a generic, or — analogously to `utils::methods(class = )` — registered for a class across all attached packages (#435).
 * `S7_class()` now returns a class specification for any R object, not just S7 objects. It returns the matching `class_*` for base types, a `new_S3_class()` wrapper for S3 objects, and the S4 class for S4 objects, so the result can be passed directly to `method()` or other S7 dispatch helpers (#559).
 * `S7_class_desc()` is a new exported helper that formats a class specification as a short human-readable string (#594).
 * `S7_data()` now preserves the S3 class when the S7 class inherits from an S3 class, so e.g. `S7_data()` on a data.frame subclass now returns a data.frame (#380).

R/introspect.R

@@ -0,0 +1,155 @@
+#' Find S7 classes and generics in an environment
+#'
+#' @description
+#' * `S7_classes()` returns the names of S7 classes defined in `env`.
+#' * `S7_generics()` returns the names of S7 generics defined in `env`.
+#'
+#' @param env An environment. Defaults to the caller's environment.
+#'   To inspect a package, pass `asNamespace("pkg")`; to inspect the global
+#'   environment, pass `globalenv()`.
+#' @returns A character vector of names.
+#' @export
+#' @examples
+#' # List S7 classes exported by the S7 package itself
+#' S7_classes(asNamespace("S7"))
+#' S7_generics(asNamespace("S7"))
+S7_classes <- function(env = parent.frame()) {
+  find_objects(env, is_class)
+}
+
+#' @export
+#' @rdname S7_classes
+S7_generics <- function(env = parent.frame()) {
+  find_objects(env, is_S7_generic)
+}
+
+#' List S7 methods
+#'
+#' List the methods registered on an S7 `generic`, or the methods registered
+#' for a given `class` across all S7 generics defined in attached packages.
+#'
+#' @param generic An S7 generic.
+#' @param class A class specification (anything accepted by [as_class()]).
+#'   When supplied, every S7 generic in every attached package is searched
+#'   for methods with this class in their signature.
+#' @returns A data frame with one row per matching method and columns:
+#'
+#'   * `generic`: the generic's name.
+#'   * `package`: the package the generic is defined in, or `NA` for generics
+#'     found in the global environment (or when `generic` is supplied
+#'     directly).
+#'   * `signature`: a list column of `S7_signature` objects describing the
+#'     dispatch signature. `format()` them for a human-readable description.
+#' @export
+#' @examples
+#' Foo <- new_class("Foo", package = NULL)
+#' Bar <- new_class("Bar", package = NULL)
+#' my_gen <- new_generic("my_gen", "x")
+#' method(my_gen, Foo) <- function(x) "foo"
+#' method(my_gen, Bar) <- function(x) "bar"
+#'
+#' S7_methods(generic = my_gen)
+#' S7_methods(class = Foo)
+S7_methods <- function(generic = NULL, class = NULL) {
+  if (!is.null(generic)) {
+    if (!is_S7_generic(generic)) {
+      stop("`generic` must be an S7 generic.")
+    }
+    generics <- list(list(generic = generic, package = NA_character_))
+  } else {
+    generics <- attached_generics()
+  }
+
+  if (!is.null(class)) {
+    target <- class_register(as_class(class))
+  } else {
+    target <- NULL
+  }
+
+  rows <- lapply(generics, function(g) {
+    generic_method_rows(g$generic, g$package, target)
+  })
+  out <- do.call(rbind, rows)
+  out$signature <- new_signature_list(out$signature)
+  out
+}
+
+generic_method_rows <- function(generic, package, class) {
+  ms <- methods(generic)
+  if (!is.null(class)) {
+    has_class <- function(m) any(vcapply(m@signature, class_register) == class)
+    ms <- Filter(has_class, ms)
+  }
+
+  data.frame(
+    generic = rep(generic@name, length(ms)),
+    package = rep(package, length(ms)),
+    signature = I(lapply(ms, \(m) new_signature(m@signature)))
+  )
+}
+
+# A list column of S7_signatures, used by S7_methods(). Needs its own class
+# so that print.data.frame() formats it per-element: data frames format whole
+# columns, so the scalar format.S7_signature() method is never reached.
+new_signature_list <- function(x) {
+  class(x) <- "S7_signature_list"
+  x
+}
+
+#' @export
+format.S7_signature_list <- function(x, ...) {
+  vcapply(unclass(x), format)
+}
+
+#' @export
+print.S7_signature_list <- function(x, ...) {
+  print(format(x), quote = FALSE)
+  invisible(x)
+}
+
+# All S7 generics reachable from attached packages and the global env,
+# each tagged with the package it was found in (`NA` for the global env).
+attached_generics <- function() {
+  out <- list()
+  for (env in attached_envs()) {
+    package <- env_package(env)
+    for (generic in unname(find_matches(env, is_S7_generic))) {
+      out[[length(out) + 1L]] <- list(generic = generic, package = package)
+    }
+  }
+  out
+}
+
+env_package <- function(env) {
+  if (identical(env, globalenv())) {
+    NA_character_
+  } else {
+    sub("^package:", "", environmentName(env))
+  }
+}
+
+attached_envs <- function() {
+  envs <- search()
+  pkgs <- envs[grepl("^package:", envs)]
+  pkgs <- setdiff(pkgs, "package:base")
+
+  c(lapply(pkgs, as.environment), globalenv())
+}
+
+find_objects <- function(env, predicate) {
+  names(find_matches(env, predicate))
+}
+
+# Named list of objects in `env` satisfying `predicate`.
+find_matches <- function(env, predicate) {
+  if (isNamespace(env)) {
+    # Not attached; use exported values
+    names <- getNamespaceExports(env)
+  } else {
+    # Attached or global; use all values
+    names <- ls(envir = env)
+  }
+
+  objs <- mget(names, envir = env, inherits = FALSE)
+  Filter(predicate, objs)
+}

R/method-register.R

@@ -290,6 +290,17 @@ new_signature <- function(x) {
   x
 }
 
+#' @export
+format.S7_signature <- function(x, ...) {
+  paste0(vcapply(unclass(x), class_desc), collapse = ", ")
+}
+
+#' @export
+print.S7_signature <- function(x, ...) {
+  cat(format(x), "\n", sep = "")
+  invisible(x)
+}
+
 check_method <- function(
   method,
   generic,

_pkgdown.yml

@@ -34,6 +34,8 @@ reference:
   - method_explain
   - S7_class
   - S7_class_desc
+  - S7_classes
+  - S7_methods
 
 - title: Packages
   desc: >

tests/testthat/_snaps/introspect.md

@@ -0,0 +1,17 @@
+# S7_methods() prints the signature column readably
+
+    Code
+      print(S7_methods(generic = gen))
+    Output
+        generic package signature
+      1     gen    <NA>     <Foo>
+      2     gen    <NA>     <Bar>
+
+# S7_methods() validates inputs
+
+    Code
+      S7_methods(generic = "not a generic")
+    Condition
+      Error in `S7_methods()`:
+      ! `generic` must be an S7 generic.
+

tests/testthat/_snaps/method-register.md

@@ -105,6 +105,13 @@
       Error:
       ! `signature` must be length 2.
 
+# S7_signature has format and print methods
+
+    Code
+      print(sig)
+    Output
+      <integer>, <character>
+
 # check_method complains if the functions are not compatible
 
     Code