Skip to content

Instantly share code, notes, and snippets.

@mtmorgan
Last active Aug 29, 2015
Embed
What would you like to do?
wrap methods() to report S3 and S4 methods for generic or class
## compatibility
if (!exists("lengths"))
lengths <- function(x) vapply(x, length, integer(1))
##
## methods
##
.S4methodsForClass <-
function(generic.function, class, .methods_info)
{
def <- tryCatch(getClass(class), error=function(...) NULL)
if (is.null(def))
return(.methods_info())
mtable <- ".MTable"
classes <- c(class, names(getClass(class)@contains))
generics <- getGenerics(where=search())
nms <- setNames(as.vector(generics), as.vector(generics))
packages <- lapply(nms, function(generic) {
table <- get(mtable, environment(getGeneric(generic)))
lapply(names(table), function(nm, table) {
environmentName(environment(table[[nm]]))
}, table)
})
methods <- lapply(nms, function(generic, classes) {
table <- get(mtable, environment(getGeneric(generic)))
methods <- names(table)
lapply(methods, function(method, classes) {
m <- table[[method]]
if (is(m, "MethodDefinition") && any(m@defined %in% classes))
setNames(as.vector(m@defined), names(m@defined))
else
NULL
}, classes)
}, classes)
geom <- lapply(methods, function(method) {
!vapply(method, is.null, logical(1))
})
filter <- function(elt, geom) elt[geom]
packages <- Map(filter, packages, geom)
methods <- Map(filter, methods, geom)
packages <- packages[lengths(methods) != 0L]
methods <- methods[lengths(methods) != 0L]
## only derived methods
geom <- lapply(methods, function(method, classes) {
sig <- simplify2array(method)
if (!is.matrix(sig))
sig <- matrix(sig, ncol=length(method))
idx <- apply(sig, 2, match, classes, 0)
if (!is.matrix(idx))
idx <- matrix(idx, ncol=ncol(sig))
keep <- colSums(idx != 0) != 0
sidx <- idx[,keep, drop=FALSE]
## 'nearest' method
shift <- c(0, cumprod(pmax(1, apply(sidx, 1, max)))[-nrow(sidx)])
score <- colSums(sidx + shift)
sig0 <- sig <- sig[,keep, drop=FALSE]
sig0[sidx != 0] <- "*"
sig0 <- apply(sig0, 2, paste, collapse="#")
split(score, sig0) <-
lapply(split(score, sig0), function(elt) elt == min(elt))
score == 1
}, classes)
filter <- function(elt, geom) elt[geom]
packages <- Map(filter, packages, geom)
methods <- Map(filter, methods, geom)
generic <- rep(names(methods), lengths(methods))
signature <- unlist(lapply(methods, function(method) {
vapply(method, paste0, character(1L), collapse=",")
}), use.names=FALSE)
package <- unlist(packages, use.names=FALSE)
.methods_info(generic=generic, signature=signature, from=package,
isS4=rep(TRUE, length(signature)))
}
.S4methodsForGeneric <-
function(generic.function, class, .methods_info)
{
if (is.null(getGeneric(generic.function)))
return(.methods_info())
mtable <- ".MTable"
generic <- generic.function
table <- get(mtable, environment(getGeneric(generic)))
packages <- sapply(names(table), function(nm, table) {
environmentName(environment(table[[nm]]))
}, table)
methods <- names(table)
signatures <- lapply(methods, function(method, classes) {
m <- table[[method]]
if (is(m, "MethodDefinition"))
setNames(as.vector(m@defined), names(m@defined))
else
NULL
})
geom <- vapply(signatures, Negate(is.null), logical(1))
packages <- packages[geom]
methods <- methods[geom]
signatures <- sapply(signatures[geom], function(elt) {
paste0(as.vector(elt), collapse=",")
})
.methods_info(generic=rep(generic.function, length(packages)), from=packages,
signature=signatures, isS4=rep(TRUE, length(signatures)))
}
##
## utils
##
print.MethodsFunction <-
function(x, ...)
{
info <- attr(x, "info")
if (attr(x, "bygeneric")) {
visible <- ifelse(info$visible, "", "*")
values <- paste0(rownames(info), visible)
} else {
values <- unique(info$generic)
}
if (length(values))
print(noquote(values))
else
print(noquote("no methods found"))
cat("\n see '?methods' for accessing help and source code\n")
}
## class constructors
.MethodsFunction <-
function(s3, s4, bygeneric)
{
df <- rbind(s3, s4)
rownames <- ifelse(df$isS4,
paste0(df$generic, ",", df$signature, "-method"),
paste0(df$generic, ".", df$signature))
keep <- !duplicated(rownames)
df <- df[keep, , drop=FALSE]
rownames(df) <- rownames[keep]
df <- df[order(rownames(df)), c("generic", "visible", "isS4", "from"),
drop=FALSE]
structure(rownames(df), info=df, bygeneric=bygeneric,
class="MethodsFunction")
}
.methods_info <-
function(generic=character(), signature=character(),
visible=rep(TRUE, length(signature)), from=character(),
isS4=logical(length(signature)))
{
data.frame(generic=generic, signature=signature, from=from,
isS4=isS4, visible=visible, stringsAsFactors=FALSE)
}
## S3
.S3methods <-
function(generic.function, class)
{
x <- utils::methods(generic.function, class)
if (!length(x))
return(.methods_info())
info <- attr(x, "info")
method <- rownames(info)
package <- sub("package:", "", info[["from"]])
if (missing(generic.function)) {
re <- "(.*)\\.([[:alnum:]_]+)$"
generic <- sub(re, "\\1", method)
class <- sub(re, "\\2", method)
} else {
generic <- generic.function
class <- sub(sprintf("%s.", generic.function), "", method,
fixed=TRUE)
}
## FIXME: not always dispatch on first argument
sig <- vapply(generic, function(elt) {
fun <- get(elt)
if (is.primitive(fun)) "x" # FIXME: ???
else names(formals(fun))[[1]]
}, character(1))
.methods_info(generic=generic, signature=class, from=package,
visible=info[["visible"]])
}
## All
.methodsForClass <-
function(generic.function, class)
{
s3 <- .S3methods(generic.function, class)
s4 <- if (.isMethodsDispatchOn())
.S4methodsForClass(generic.function, class, .methods_info)
else .methods_info()
.MethodsFunction(s3, s4, FALSE)
}
.methodsForGeneric <-
function(generic.function, class)
{
s3 <- tryCatch(.S3methods(generic.function, class),
error=function(...) .methods_info())
s4 <- if (.isMethodsDispatchOn())
.S4methodsForGeneric(generic.function, class, .methods_info)
else .methods_info()
.MethodsFunction(s3, s4, TRUE)
}
methods <-
function(generic.function, class)
{
if (!missing(generic.function)) {
if (!is.character(generic.function))
generic.function <- deparse(substitute(generic.function))
.methodsForGeneric(generic.function, class)
} else if (!missing(class)) {
.methodsForClass(generic.function, class)
} else
stop("must supply 'generic.function' or 'class'")
}
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment