|
| 1 | +#' Find S7 classes and generics in an environment |
| 2 | +#' |
| 3 | +#' @description |
| 4 | +#' * `S7_classes()` returns the names of S7 classes defined in `env`. |
| 5 | +#' * `S7_generics()` returns the names of S7 generics defined in `env`. |
| 6 | +#' |
| 7 | +#' @param env An environment. Defaults to the caller's environment. |
| 8 | +#' To inspect a package, pass `asNamespace("pkg")`; to inspect the global |
| 9 | +#' environment, pass `globalenv()`. |
| 10 | +#' @returns A character vector of names. |
| 11 | +#' @export |
| 12 | +#' @examples |
| 13 | +#' # List S7 classes exported by the S7 package itself |
| 14 | +#' S7_classes(asNamespace("S7")) |
| 15 | +#' S7_generics(asNamespace("S7")) |
| 16 | +S7_classes <- function(env = parent.frame()) { |
| 17 | + find_objects(env, is_class) |
| 18 | +} |
| 19 | + |
| 20 | +#' @export |
| 21 | +#' @rdname S7_classes |
| 22 | +S7_generics <- function(env = parent.frame()) { |
| 23 | + find_objects(env, is_S7_generic) |
| 24 | +} |
| 25 | + |
| 26 | +#' List S7 methods |
| 27 | +#' |
| 28 | +#' List the methods registered on an S7 `generic`, or the methods registered |
| 29 | +#' for a given `class` across all S7 generics defined in attached packages. |
| 30 | +#' |
| 31 | +#' @param generic An S7 generic. |
| 32 | +#' @param class A class specification (anything accepted by [as_class()]). |
| 33 | +#' When supplied, every S7 generic in every attached package is searched |
| 34 | +#' for methods with this class in their signature. |
| 35 | +#' @returns A data frame with one row per matching method and columns: |
| 36 | +#' |
| 37 | +#' * `generic`: the generic's name. |
| 38 | +#' * `package`: the package the generic is defined in, or `NA` for generics |
| 39 | +#' found in the global environment (or when `generic` is supplied |
| 40 | +#' directly). |
| 41 | +#' * `signature`: a list column of `S7_signature` objects describing the |
| 42 | +#' dispatch signature. `format()` them for a human-readable description. |
| 43 | +#' @export |
| 44 | +#' @examples |
| 45 | +#' Foo <- new_class("Foo", package = NULL) |
| 46 | +#' Bar <- new_class("Bar", package = NULL) |
| 47 | +#' my_gen <- new_generic("my_gen", "x") |
| 48 | +#' method(my_gen, Foo) <- function(x) "foo" |
| 49 | +#' method(my_gen, Bar) <- function(x) "bar" |
| 50 | +#' |
| 51 | +#' S7_methods(generic = my_gen) |
| 52 | +#' S7_methods(class = Foo) |
| 53 | +S7_methods <- function(generic = NULL, class = NULL) { |
| 54 | + if (!is.null(generic)) { |
| 55 | + if (!is_S7_generic(generic)) { |
| 56 | + stop("`generic` must be an S7 generic.") |
| 57 | + } |
| 58 | + generics <- list(list(generic = generic, package = NA_character_)) |
| 59 | + } else { |
| 60 | + generics <- attached_generics() |
| 61 | + } |
| 62 | + |
| 63 | + if (!is.null(class)) { |
| 64 | + target <- class_register(as_class(class)) |
| 65 | + } else { |
| 66 | + target <- NULL |
| 67 | + } |
| 68 | + |
| 69 | + rows <- lapply(generics, function(g) { |
| 70 | + generic_method_rows(g$generic, g$package, target) |
| 71 | + }) |
| 72 | + out <- do.call(rbind, rows) |
| 73 | + out$signature <- new_signature_list(out$signature) |
| 74 | + out |
| 75 | +} |
| 76 | + |
| 77 | +generic_method_rows <- function(generic, package, class) { |
| 78 | + ms <- methods(generic) |
| 79 | + if (!is.null(class)) { |
| 80 | + has_class <- function(m) any(vcapply(m@signature, class_register) == class) |
| 81 | + ms <- Filter(has_class, ms) |
| 82 | + } |
| 83 | + |
| 84 | + data.frame( |
| 85 | + generic = rep(generic@name, length(ms)), |
| 86 | + package = rep(package, length(ms)), |
| 87 | + signature = I(lapply(ms, \(m) new_signature(m@signature))) |
| 88 | + ) |
| 89 | +} |
| 90 | + |
| 91 | +# A list column of S7_signatures, used by S7_methods(). Needs its own class |
| 92 | +# so that print.data.frame() formats it per-element: data frames format whole |
| 93 | +# columns, so the scalar format.S7_signature() method is never reached. |
| 94 | +new_signature_list <- function(x) { |
| 95 | + class(x) <- "S7_signature_list" |
| 96 | + x |
| 97 | +} |
| 98 | + |
| 99 | +#' @export |
| 100 | +format.S7_signature_list <- function(x, ...) { |
| 101 | + vcapply(unclass(x), format) |
| 102 | +} |
| 103 | + |
| 104 | +#' @export |
| 105 | +print.S7_signature_list <- function(x, ...) { |
| 106 | + print(format(x), quote = FALSE) |
| 107 | + invisible(x) |
| 108 | +} |
| 109 | + |
| 110 | +# All S7 generics reachable from attached packages and the global env, |
| 111 | +# each tagged with the package it was found in (`NA` for the global env). |
| 112 | +attached_generics <- function() { |
| 113 | + out <- list() |
| 114 | + for (env in attached_envs()) { |
| 115 | + package <- env_package(env) |
| 116 | + for (generic in unname(find_matches(env, is_S7_generic))) { |
| 117 | + out[[length(out) + 1L]] <- list(generic = generic, package = package) |
| 118 | + } |
| 119 | + } |
| 120 | + out |
| 121 | +} |
| 122 | + |
| 123 | +env_package <- function(env) { |
| 124 | + if (identical(env, globalenv())) { |
| 125 | + NA_character_ |
| 126 | + } else { |
| 127 | + sub("^package:", "", environmentName(env)) |
| 128 | + } |
| 129 | +} |
| 130 | + |
| 131 | +attached_envs <- function() { |
| 132 | + envs <- search() |
| 133 | + pkgs <- envs[grepl("^package:", envs)] |
| 134 | + pkgs <- setdiff(pkgs, "package:base") |
| 135 | + |
| 136 | + c(lapply(pkgs, as.environment), globalenv()) |
| 137 | +} |
| 138 | + |
| 139 | +find_objects <- function(env, predicate) { |
| 140 | + names(find_matches(env, predicate)) |
| 141 | +} |
| 142 | + |
| 143 | +# Named list of objects in `env` satisfying `predicate`. |
| 144 | +find_matches <- function(env, predicate) { |
| 145 | + if (isNamespace(env)) { |
| 146 | + # Not attached; use exported values |
| 147 | + names <- getNamespaceExports(env) |
| 148 | + } else { |
| 149 | + # Attached or global; use all values |
| 150 | + names <- ls(envir = env) |
| 151 | + } |
| 152 | + |
| 153 | + objs <- mget(names, envir = env, inherits = FALSE) |
| 154 | + Filter(predicate, objs) |
| 155 | +} |
0 commit comments