Имя функции текущего журнала

У меня есть несколько пользовательских логических функций, которые являются расширениями 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 начинается с имени вызываемой функции. Очень аккуратно, пока я не начну реорганизовывать свой код и переименовывать функции и т.д.

Благодаря старому списку R-списка от Брайана Рипли, если я не ошибаюсь, я нашел этот код для получения "текущего имени функции":

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 в вызове sys.parent в моей функции catw.

  • Я иногда использую do.call: это моя текущая реализация тоже не работает (я еще раз могу это понять, хотя Я не понял это полностью.

Итак, мой вопрос: есть ли способ найти первую именованную функцию выше в callstack (пропустить самую функцию ведения журнала и, возможно, некоторые другие "известные" исключения), что позволило бы мне написать одну единственную версию 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))

ОТВЕТЫ

Ответ 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

Ответ 2

Я думал, что добавлю прогресс, достигнутый до сих пор, полностью основанный на работе Андри. Довольно уверен, что другим людям это понравится, так что теперь это часть пакета, который я разрабатываю (не на 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)
}

Как уже упоминалось в комментариях к Андри, до сих пор все еще есть некоторые проблемы относительно do.call. На данный момент я собираюсь прекратить тратить время, но разместил связанный с ним вопрос в r-devel mailinglist. Если/когда я получаю ответ там, и он можно использовать, я обновлю функции.