找出在给定函数内被调用的函数

Question

可能是重复的问题：
在R中生成调用图

我希望能够系统地分析给定函数，找出在该函数内部调用了哪些其他函数。如果可能的话，进行递归分析。

我在milktrader的博客文章中发现了一个函数，可以类似地分析包（或命名空间）。

listFunctions <- function(
    name,
    ...
){ 
    name.0  <- name
    name    <- paste("package", ":", name, sep="")
    if (!name %in% search()) {
        stop(paste("Invalid namespace: '", name.0, "'"))
    }
    # KEEP AS REFERENCE       
#    out <- ls(name)
    funlist <- lsf.str(name)
    out     <- head(funlist, n=length(funlist))
    return(out)
}

> listFunctions("stats")
  [1] "acf"                  "acf2AR"               "add.scope"           
  [4] "add1"                 "addmargins"           "aggregate"           
  [7] "aggregate.data.frame" "aggregate.default"    "aggregate.ts"        
 [10] "AIC"                  "alias"                "anova"               
....
[499] "xtabs"   

然而，我希望有一个函数，其中name将是函数的名称，并且返回值是调用name内部的函数的字符向量（如果递归完成，则为列表）。

动机

实际上，我需要某种基于字符的输出（向量或列表）。原因是我正在为并行化任意“内部函数”编写通用包装器函数，在这个过程中，您不必经历耗时的试错过程，以找出内部函数依赖哪些其他函数。因此，我所追求的函数的输出将直接用于snowfall::sfExport()和/或snowfall::sfSouce。

编辑 2012-08-08

由于存在重复性，因此已经有一些近期的关闭投票，明天我将检查答案如何与其他问题合并。

- Rappster

---

请参见在R中生成调用图。关键词是调用图。 - Guy Coder

@KarstenW：谢谢，总是很高兴看到不同的方法！我只是从帖子中复制了它，并没有多想。 - Rappster

虽然foodweb函数默认会生成一个图形，但它还会（隐式地）返回一个包含调用信息和矩阵等其他内容的对象。请查看foodweb帮助页面中的“Value”部分，以及同一页面上记录的callers.of和callees.of。 - Brian Diggs

@BrianDiggs：很酷，这听起来更像样了。谢谢！ - Rappster

@guycoder：嘿，没问题，我不想听起来不感激，只是在你的第一篇帖子后没有看到直接链接。非常感谢！ - Rappster

Answer 1

尝试这个示例：

library(codetools)

ff <- function(f) {
  leaf <- function (e, w) {
    r <- try(eval(e), silent = TRUE)
    if(!is.null(r) && is.function(r)) ret <<- c(ret, as.character(e))
  }
  call <- function (e, w) {
    walkCode(e[[1]], w)
    for (a in as.list(e[-1])) if (!missing(a)) walkCode(a, w)
  }
  ret <- c()
  walkCode(body(f), makeCodeWalker(call = call, leaf = leaf, write = cat))
  unique(ret)
}

然后，

> ff(data.frame)
 [1] "{"               "<-"              "if"              "&&"              "is.null"         "row.names"       "function"        "is.character"   
 [9] "new"             "as.character"    "anyDuplicated"   "return"          "||"              "all"             "=="              "stop"           
[17] "gettextf"        "warning"         "paste"           "which"           "duplicated"      "["               "as.list"         "substitute"     
[25] "list"            "-"               "missing"         "length"          "<"               "!"               "is.object"       "is.integer"     
[33] "any"             "is.na"           "unique"          "integer"         "structure"       "character"       "names"           "!="             
[41] "nzchar"          "for"             "seq_len"         "[["              "is.list"         "as.data.frame"   ".row_names_info" ">"              
[49] "deparse"         "substr"          "nchar"           "attr"            "abs"             "max"             "("               "%%"             
[57] "unclass"         "seq_along"       "is.vector"       "is.factor"       "rep"             "class"           "inherits"        "break"          
[65] "next"            "unlist"          "make.names"      "match"           ".set_row_names" 
> ff(read.table)
 [1] "{"              "if"             "&&"             "missing"        "file"           "!"              "text"           "<-"             "textConnection"
[10] "on.exit"        "close"          "is.character"   "nzchar"         "inherits"       "stop"           "isOpen"         "open"           ">"             
[19] "readLines"      "<"              "min"            "("              "+"              "lines"          ".Internal"      "quote"          "length"        
[28] "all"            "=="             "pushBack"       "c"              "stdin"          "scan"           "col"            "numeric"        "-"             
[37] "for"            "seq_along"      "["              "max"            "!="             "warning"        "paste0"         ":"              "make.names"    
[46] "names"          "is.null"        "rep"            "match"          "any"            "<="             "rep.int"        "list"           "%in%"          
[55] "sapply"         "do.call"        "data"           "flush"          "[["             "which"          "is.logical"     "is.numeric"     "|"             
[64] "gettextf"       "&"              "is.na"          "type.convert"   "character"      "as.factor"      "as.Date"        "as.POSIXct"     "::"            
[73] "methods"        "as"             "row.names"      ".set_row_names" "as.integer"     "||"             "is.object"      "is.integer"     "as.character"  
[82] "anyDuplicated"  "class"          "attr"          

- kohske

---

非常感谢您的回答和指向codetools！我还没有时间检查到目前为止的两个答案，所以我先从Edward的答案开始，因为我喜欢在转向贡献包之前了解如何使用基本的R功能来完成它的细节。但是codetools似乎非常有前途。 - Rappster

似乎Codetools方法比Edwards方法慢一些，这实际上让我感到意外（请参见我的答案）。 - Rappster

Answer 2

这里可能有更好的方法，但这是我尝试的方法：

listFunctions <- function(function.name, recursive = FALSE, 
                          checked.functions = NULL){

    # Get the function's code:
    function.code <- deparse(get(function.name))

    # break code up into sections preceding left brackets:
    left.brackets <- c(unlist(strsplit(function.code, 
                                       split="[[:space:]]*\\(")))

    called.functions <- unique(c(unlist(sapply(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))
        return(last.word[last.word.is.function])
    }))))

    if (recursive){

        # checked.functions: We need to keep track of which functions 
        # we've checked to avoid infinite loops.
        functs.to.check <- called.functions[!(called.functions %in%
                                          checked.functions)]

        called.functions <- unique(c(called.functions,
            do.call(c, lapply(functs.to.check, function(x) {
                listFunctions(x, recursive = T,
                              checked.functions = c(checked.functions,          
                                                    called.functions))
                }))))
    }
    return(called.functions)
}

结果如下：

> listFunctions("listFunctions", recursive = FALSE)
 [1] "function"      "deparse"       "get"           "c"            
 [5] "unlist"        "strsplit"      "unique"        "sapply"       
 [9] "tail"          "tryCatch"      "is.function"   "return"       
[13] "if"            "do.call"       "lapply"        "listFunctions"

> system.time(all.functions <- listFunctions("listFunctions", recursive = TRUE))
   user  system elapsed 
  92.31    0.08   93.49 

> length(all.functions)
  [1] 518

从上面可以看到，递归版本返回了很多函数。这个问题在于它返回了每一个在过程中被调用的函数，随着过程的进行，显然会累积起来。无论如何，我希望你能使用这个（或修改它）以适应你的需要。

- Edward

---

谢谢，我今天参考了你的方法并稍加改动。更改了一些东西（主要是为已经检查过的函数添加一个“global”缓冲区；我认为这就是你的递归代码运行时间如此之长的原因），并添加了一些功能（请看我的回答）。 - Rappster

很好，你的方法处理时间只有依赖于“codetools”功能的0.6870！ - Rappster

Answer 3

免责声明

本回答基于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

- Rappster