日志记录当前函数名称

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) 
} 

现在，我工作了很多与（自制）的功能，并使用一些logfuntions的看到了进步，这工作得很好。我注意到什么，不过，是我几乎总是使用这些功能是这样的：

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]]))) 
    } 
} 

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

• 我偶尔使用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)) 

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) 
} 

如前所述在迄今为止安德里回答的评论中，关于do.call仍然存在一些问题。我现在要停止花费时间，但已在r-devel mailinglist上发布相关问题。如果/当我在那里得到答复并且它可用时，我将更新这些功能。