wrap methods() to report S3 and S4 methods for generic or class

methods.R

## 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'")
}