日誌記錄當前函數名稱

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上發佈相關問題。如果/當我在那裏得到答覆並且它可用時，我將更新這些功能。