Logging current function name

I have a few custom logfunctions that are extensions of cat. A basic example is something like this:

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

Now, I work a lot with (selfmade) functions, and use some of these logfuntions to see the progress, which works quite well. What I notice, though, is that I almost always use these functions like this:

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

Notice how every call to catt begins with the name of the function it is called from. Very neat until I start to refactor my code and rename functions etc.

Thanks to some old R-list post from Brian Ripley, if I'm not mistaken, I found this code to get the 'current function name':

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

This is very nice, but it doesn't always work, because:

• my functions are scattered with anonymous functions used in lapply type of functions, like this:

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

-> for these cases, apparently (and understandably) I need n=3 in the sys.parent call in my catw function.

• I occasionally use do.call: it appears my current implementation doesn't work either (once again I can somewhat understand it, though I haven't figured it out completely.

So, my question is: is there a way to find the first named function higher in the call开发者_开发技巧stack (skipping the logging function itself, and maybe some other "wellknown" exceptions), which would allow me to write one single version of catw for all cases (so that I can happily refactor without worrying about my logging code)? How would you go about something like this?

Edit: these cases should be supported:

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

---

EDIT : Complete rewrite of function

The new version of this function uses the call stack, sys.calls(), rather than match.call.

The call stack contains the complete calling function. So the trick now is to only extract the bits of it that you really want. I have resorted to a bit of manual cleanup in the clean_cs function. This evaluates the first word in the call stack and returns the desired argument for a small number of known edge cases, in particular lapply, sapply and do.call.

The only downside of this approach is that it will return function names all the way to the top of the call stack. Perhaps a logical next step would be to compare these functions with a spefified environment/namespace and include/exclude function names based on that...

I shall stop here. It answers to the use cases in the question.

---

The new function:

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

---

Test results:

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

---

I thought I'd add the progress made so far, based completely on Andrie's work. Pretty sure other people will enjoy this, so it is now a part of a package I'm developing (not on CRAN but on R-Forge for now) called addendum (including documentation) after the nightly build.

Function to find the 'current lowest named function' on the callstack with some bells and whistles:

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

This can be used in a logging function like this:

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

As mentioned in the comments to Andrie's answer so far, there are still some issues regarding do.call. I'm going to stop spending time on it for now, but have posted the related question on the r-devel mailinglist. If/when I get a response there, and it is usable, I will update the functions.