记录当前函数名
我有一些自定义的日志函数，它们是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)
}这很好，但它并不总是有效的，因为：
- my函数与
lapply类型的函数中使用的匿名函数分散在一起，如下所示：
aFunc<-function(somedataframe) { result<-lapply(seq_along(somedataframe)，function(i){ catw("working on col"，i，"/"，ncol(Somedataframe)#在这里做更多的工作并返回一些返回(seq_along(is.na(somedataframe[i])}}
->对于这些情况，显然(也可以理解)我需要在catw函数的sys.parent调用中使用n=3。
- 我偶尔会用到
do.call：看起来我现在的实现也不能工作(再说一次，我可以稍微理解它，尽管我还没有完全弄明白。
所以，我的问题是:有没有一种方法可以找到调用栈中更高层的第一个命名函数(跳过日志记录函数本身，也许还有其他一些“众所周知的”异常)，这样我就可以为所有情况编写一个单一版本的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))回答 2
Stack Overflow用户
发布于 2011-09-05 22:55:04
编辑:完全重写函数
此函数的新版本使用调用堆栈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 testbStack Overflow用户
发布于 2011-09-06 22:37:49
我想我应该添加到目前为止取得的进展，完全基于Andrie的工作。我很确定其他人会喜欢这个，所以它现在是我正在开发的包(不是在CRAN上，但现在是在R-Forge上)的一部分，叫做addendum (包括文档)，在夜间构建之后。
函数来查找callstack上的“当前命名最低的函数”，其中包含一些花哨的东西：
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)
}到目前为止，在对Andrie回答的评论中提到，关于do.call仍然存在一些问题。我暂时不会再花时间在这个问题上，但我已经在r-devel mailinglist上发布了相关的问题。如果/当我在那里得到一个响应，并且它是可用的，我将更新函数。
https://stackoverflow.com/questions/7307987
复制相似问题