免责声明
此答案基于Edward 和Kohske 的答案。我将不考虑这个作为最终接受的答案，其主要目的只是为其他用户记录另一种/扩展方法和一些基准。
内部函数 1
感谢Edward。
listFunctions_inner <- function(
name,
do.recursive=FALSE,
.do.verbose=FALSE,
.buffer=new.env()
){
..name <- "listFunctions_inner"
if (!is.character(name) | missing(name)) {
stop(paste(..name, " // expecting 'name' of class 'character'", sep=""))
}
name.0 <- name
if (tryCatch(is.function(get(name)), error=function(e) FALSE)) {
# PROCESS FUNCTIONS
if (.do.verbose) {
message(paste(..name, " // processing function: '", name, "'", sep=""))
}
# Get the function's code:
code <- deparse(get(name))
# break code up into sections preceding left brackets:
left.brackets <- c(unlist(strsplit(code, split="[[:space:]]*\\(")))
out <- sort(unique(unlist(lapply(left.brackets, function (x) {
# Split up according to anything that can't be in a function name.
# split = not alphanumeric, not '_', and not '.'
words <- c(unlist(strsplit(x, split="[^[:alnum:]_.]")))
last.word <- tail(words, 1)
last.word.is.function <- tryCatch(is.function(get(last.word)),
error=function(e) return(FALSE))
out <- last.word[last.word.is.function]
return(out)
}))))
if (do.recursive){
# funs.checked: We need to keep track of which functions
# we've checked to avoid infinite loops.
.buffer$funs.checked <- c(.buffer$funs.checked, name)
funs.next <- out[!(out %in% .buffer$funs.checked)]
if (length(funs.next)) {
out <- sort(unique(unlist(c(out, do.call(c,
lapply(funs.next, function(x) {
if (x == ".Primitive") {
return(NULL)
}
listFunctions_inner(
name=x,
do.recursive=TRUE,
.buffer=.buffer
)
})
)))))
}
}
out <- sort(unique(unlist(out)))
} else {
# PROCESS NAMESPACES
if (.do.verbose) {
message(paste(..name, " // processing namespace: '", name, "'", sep=""))
}
name <- paste("package", ":", name, sep="")
if (!name %in% search()) {
stop(paste(..name, " // invalid namespace: '", name.0, "'"))
}
# KEEP AS REFERENCE
# out <- ls(name)
funlist <- lsf.str(name)
out <- head(funlist, n=length(funlist))
}
out
}
内部函数 2
感谢Kohske
listFunctions2_inner <- function(
name,
do.recursive=FALSE,
.do.verbose=FALSE,
.buffer=new.env()
) {
..name <- "listFunctions2_inner"
if (!is.character(name) | missing(name)) {
stop(paste(..name, " // expecting 'name' of class 'character'", sep=""))
}
name.0 <- name
if (tryCatch(is.function(get(name)), error=function(e) FALSE)) {
# PROCESS FUNCTIONS
leaf <- function (e, w) {
r <- try(eval(e), silent = TRUE)
if(!is.null(r) && is.function(r)) out <<- c(out, as.character(e))
}
call <- function (e, w) {
walkCode(e[[1]], w)
for (a in as.list(e[-1])) if (!missing(a)) walkCode(a, w)
}
out <- c()
walkCode(
body(name),
makeCodeWalker(call=call, leaf=leaf, write=cat)
)
if (do.recursive){
# funs.checked: We need to keep track of which functions
# we've checked to avoid infinite loops.
.buffer$funs.checked <- c(.buffer$funs.checked, name)
funs.next <- out[!(out %in% .buffer$funs.checked)]
if (length(funs.next)) {
out <- sort(unique(unlist(c(out, do.call(c,
lapply(funs.next, function(x) {
if (x == ".Primitive") {
return(NULL)
}
listFunctions_inner(
name=x,
do.recursive=TRUE,
.buffer=.buffer
)
})
)))))
}
}
out <- sort(unique(out))
} else {
# PROCESS NAMESPACES
if (.do.verbose) {
message(paste(..name, " // processing namespace: '", name, "'", sep=""))
}
name <- paste("package", ":", name, sep="")
if (!name %in% search()) {
stop(paste(..name, " // invalid namespace: '", name.0, "'"))
}
# KEEP AS REFERENCE
# out <- ls(name)
funlist <- lsf.str(name)
out <- head(funlist, n=length(funlist))
}
}
包装函数
这个包装器让您选择实际使用的内部函数，并允许指定应该或不应该考虑的命名空间。这对我的用例很重要（请参阅上面的动机部分），因为我通常只对尚未移动到包中的“自己的”函数（.GlobalEnv）感兴趣。
listFunctions <- function(
name,
ns,
innerFunction=listFunctions,
do.inverse=FALSE,
do.table=FALSE,
do.recursive=FALSE,
.do.verbose=FALSE
){
..name <- "listFunctions_inner"
if (!is.character(name) | missing(name)) {
stop(paste(..name, " // expecting 'name' of class 'character'", sep=""))
}
out <- innerFunction(name, do.recursive=do.recursive,
.do.verbose=.do.verbose)
if (do.table) {
x.ns <- sapply(out, function(x) {
out <- environmentName(environment(get(x)))
if (out == "") {
out <- ".Primitive"
}
out
})
if (!missing(ns)) {
if (!do.inverse) {
idx <- which(x.ns %in% ns)
} else {
idx <- which(!x.ns %in% ns)
}
if (!length(idx)) {
return(NULL)
}
out <- out[idx]
x.ns <- x.ns[idx]
}
out <- data.frame(name=out, ns=x.ns, stringsAsFactors=FALSE)
rownames(out) <- NULL
}
out
}
应用
# Character vector
listFunctions("install.packages")
# Data Frame (table)
> listFunctions("install.packages", do.table=TRUE)
name ns
1 .libPaths .Primitive
2 .standard_regexps base
3 any .Primitive
4 available.packages utils
...
84 winDialog utils
# Consider 'base' only
> listFunctions("install.packages", ns="base", do.table=TRUE)
name ns
1 .standard_regexps base
2 basename base
3 capabilities base
...
56 warning base
# Consider all except 'base'
> listFunctions("install.packages", ns="base", do.inverse=TRUE, do.table=TRUE)
name ns
1 .libPaths .Primitive
2 any .Primitive
3 available.packages utils
...
28 winDialog utils
# Recursively, no table
listFunctions("install.packages", do.recursive=TRUE)
# Recursively table
listFunctions("install.packages", do.table=TRUE, do.recursive=TRUE)
name ns
1 .amatch_bounds base
2 .amatch_costs base
3 .C .Primitive
...
544 xzfile base
# List functions inside a namespace
listFunctions("utils")
listFunctions("utils", do.table=TRUE)
基准内部函数 1
> bench <- microbenchmark(listFunctions("install.packages"))
bench
> Unit: milliseconds
expr min lq median uq
1 listFunctions("install.packages") 152.9654 157.2805 160.5019 165.4688
max
1 244.6589
> bench <- microbenchmark(listFunctions("install.packages", do.recursive=TRUE), times=3)
bench
> Unit: seconds
expr min lq
1 listFunctions("install.packages", do.recursive = TRUE) 6.272732 6.30164
median uq max
1 6.330547 6.438158 6.545769
基准内部函数 2
> bench <- microbenchmark(listFunctions("install.packages",
+ innerFunction=listFunctions2_inner))
bench
> Unit: milliseconds
expr
1 listFunctions("install.packages", innerFunction = listFunctions2_inner)
min lq median uq max
1 207.0299 212.3286 222.6448 324.6399 445.4154
> bench <- microbenchmark(listFunctions("install.packages",
+ innerFunction=listFunctions2_inner, do.recursive=TRUE), times=3)
bench
Warning message:
In nm[nm == ""] <- exprnm[nm == ""] :
number of items to replace is not a multiple of replacement length
> Unit: seconds
expr
1 listFunctions("install.packages", innerFunction = listFunctions2_inner,
min lq median uq max
1 7.673281 8.065561 8.457841 8.558259 8.658678