记录当前函数名称

Question

我有一些自定义日志函数是cat 的扩展。一个基本的例子是这样的：

catt<-function(..., file = "", sep = " ", fill = FALSE, labels = NULL,
    append = FALSE)
{
    cat(..., format(Sys.time(), "(%Y-%m-%d %H:%M:%S)"), "\n", file = file, 
        sep = sep, fill = fill, labels = labels, append = append)
}

现在，我经常使用（自制）函数，并使用其中一些日志函数来查看进度，效果很好。不过，我注意到的是，我几乎总是像这样使用这些函数：

somefunc<-function(blabla)
{
  catt("somefunc: start")
  #do some very useful stuff here
  catt("somefunc: some time later")
  #even more useful stuff
  catt("somefunc: the end")
}

注意对catt 的每次调用都以调用它的函数的名称开头。在我开始重构代码和重命名函数等之前非常整洁。

感谢 Brian Ripley 的一些旧 R-list 帖子，如果我没记错的话，我找到了这段代码来获取“当前函数名”：

catw<-function(..., file = "", sep = " ", fill = FALSE, labels = NULL,
    append = FALSE)
{
    curcall<-sys.call(sys.parent(n=1))
    prefix<-paste(match.call(call=curcall)[[1]], ":", sep="")
    cat(prefix, ..., format(Sys.time(), "(%Y-%m-%d %H:%M:%S)"), "\n",
        file = file, sep = sep, fill = fill, labels = labels, append = append)
}

这很好，但并不总是有效，因为：

• 我的函数分散在lapply 中使用的匿名函数 函数类型，如下所示：

aFunc<-function(somedataframe)
{
  result<-lapply(seq_along(somedataframe), function(i){
  catw("working on col", i, "/", ncol(somedataframe))
  #do some more stuff here and return something
  return(sum(is.na(somedataframe[[i]])))
  }
}

-> 对于这些情况，显然（并且可以理解）我在 catw 函数中的 sys.parent 调用中需要 n=3。

• 我偶尔使用do.call：看来我目前的实现 也不起作用（我再一次有点理解它，不过 我还没有完全弄清楚。

所以，我的问题是：有没有办法在调用堆栈中找到第一个 named 函数（跳过日志记录函数本身，可能还有其他一些“众所周知的”异常），这将允许我要为所有情况编写一个单一版本的catw（这样我就可以愉快地重构而不用担心我的日志代码）？你会怎么处理这样的事情？

编辑：应该支持这些情况：

testa<-function(par1)
{
    catw("Hello from testa, par1=", par1)
    for(i in 1:2) catw("normal loop from testa, item", i)
    rv<-sapply(1:2, function(i){catw("sapply from testa, item", i);return(i)})
    return(rv)
}

testb<-function(par1, par2)
{
    catw("Hello from testb, par1=", par1)
    for(i in 1:2) catw("normal loop from testb, item", i)
    rv<-sapply(1:2, function(i){catw("sapply from testb, item", i);return(i)})

    catw("Will now call testa from testb")
    rv2<-testa(par1)
    catw("Back from testa call in testb")

    catw("Will now do.call testa from testb")
    rv2<-do.call(testa, list(par1))
    catw("Back from testa do.call in testb")

    return(list(rv, rv2))
}

testa(123)
testb(123,456)
do.call(testb, list(123,456))

Answer 1

编辑：完全重写函数

此函数的新版本使用调用堆栈sys.calls()，而不是match.call。

调用栈包含完整的调用函数。所以现在的诀窍是只提取你真正想要的部分。我在clean_cs 函数中进行了一些手动清理。这会评估调用堆栈中的第一个单词，并为少数已知的边缘情况返回所需的参数，特别是 lapply、sapply 和 do.call。

这种方法的唯一缺点是它会将函数名一直返回到调用堆栈的顶部。也许合乎逻辑的下一步是将这些函数与指定的环境/命名空间进行比较，并在此基础上包含/排除函数名称......

我会在这里停下来。它回答了问题中的用例。

---

新功能：

catw <- function(..., callstack=sys.calls()){
  cs <- callstack
  cs <- clean_cs(cs)
  #browser()
  message(paste(cs, ...))
}

clean_cs <- function(x){
  val <- sapply(x, function(xt){
    z <- strsplit(paste(xt, collapse="\t"), "\t")[[1]]
    switch(z[1],
        "lapply" = z[3], 
        "sapply" = z[3],
        "do.call" = z[2], 
        "function" = "FUN",
        "source" = "###",
        "eval.with.vis" = "###",
        z[1]
        )
    })
  val[grepl("\\<function\\>", val)] <- "FUN"
  val <- val[!grepl("(###|FUN)", val)]
  val <- head(val, -1)
  paste(val, collapse="|")
}

---

测试结果：

testa Hello from testa, par1= 123
testa normal loop from testa, item 1
testa normal loop from testa, item 2
testa sapply from testa, item 1
testa sapply from testa, item 2


testb Hello from testb, par1= 123
testb normal loop from testb, item 1
testb normal loop from testb, item 2
testb sapply from testb, item 1
testb sapply from testb, item 2
testb Will now call testa from testb
testb|testa Hello from testa, par1= 123
testb|testa normal loop from testa, item 1
testb|testa normal loop from testa, item 2
testb|testa sapply from testa, item 1
testb|testa sapply from testa, item 2
testb Back from testa call in testb
testb Will now do.call testa from testb
testb|testa Hello from testa, par1= 123
testb|testa normal loop from testa, item 1
testb|testa normal loop from testa, item 2
testb|testa sapply from testa, item 1
testb|testa sapply from testa, item 2
testb Back from testa do.call in testb


testb Hello from testb, par1= 123
testb normal loop from testb, item 1
testb normal loop from testb, item 2
testb sapply from testb, item 1
testb sapply from testb, item 2
testb Will now call testa from testb
testb|testa Hello from testa, par1= 123
testb|testa normal loop from testa, item 1
testb|testa normal loop from testa, item 2
testb|testa sapply from testa, item 1
testb|testa sapply from testa, item 2
testb Back from testa call in testb
testb Will now do.call testa from testb
testb|testa Hello from testa, par1= 123
testb|testa normal loop from testa, item 1
testb|testa normal loop from testa, item 2
testb|testa sapply from testa, item 1
testb|testa sapply from testa, item 2
testb Back from testa do.call in testb

Answer 2

我想我会添加到目前为止所取得的进展，完全基于 Andrie 的工作。很确定其他人会喜欢这个，所以它现在是我正在开发的包的一部分（不是在 CRAN 上，而是在 R-Forge 上），在夜间构建之后称为 addendum（包括文档）。

在调用堆栈上查找“当前最低命名函数”的函数，带有一些花里胡哨的功能：

curfnfinder<-function(skipframes=0, skipnames="(FUN)|(.+apply)|(replicate)",
    retIfNone="Not in function", retStack=FALSE, extraPrefPerLevel="\t")
{
    prefix<-sapply(3 + skipframes+1:sys.nframe(), function(i){
            currv<-sys.call(sys.parent(n=i))[[1]]
            return(currv)
        })
    prefix[grep(skipnames, prefix)] <- NULL
    prefix<-gsub("function \\(.*", "do.call", prefix)
    if(length(prefix)==0)
    {
        return(retIfNone)
    }
    else if(retStack)
    {
        return(paste(rev(prefix), collapse = "|"))
    }
    else
    {
        retval<-as.character(unlist(prefix[1]))
        if(length(prefix) > 1)
        {
            retval<-paste(paste(rep(extraPrefPerLevel, length(prefix) - 1), collapse=""), retval, sep="")
        }
        return(retval)
    }
}

这可以用在这样的日志记录函数中：

catw<-function(..., file = "", sep = " ", fill = FALSE, labels = NULL,
    append = FALSE, prefix=0)
{
    if(is.numeric(prefix))
    {
        prefix<-curfnfinder(skipframes=prefix+1) #note: the +1 is there to avoid returning catw itself
        prefix<-paste(prefix, ":", sep="")
    }
    cat(prefix, ..., format(Sys.time(), "(%Y-%m-%d %H:%M:%S)"), "\n",
        file = file, sep = sep, fill = fill, labels = labels, append = append)
}

到目前为止，正如 cmets 对 Andrie 的回答所提到的，关于do.call 仍然存在一些问题。我将暂时停止花时间在上面，但已在r-devel mailinglist 上发布了相关问题。如果/当我在那里得到响应并且它可用时，我将更新功能。