# Logging system
#
# Author: Renaud Gaujoux
# Creation: 25 Apr 2012
###############################################################################
#' @include utils.R options.R
NULL
#' Logging Feature
#'
#' \code{lverbose} returns/sets the current verbosity level.
#'
#' @param val logical/numeric value that sets the verbosity level.
#' @param global logical that indicates if the verbose level of
#' all log handlers should be set to \var{val}.
#'
#' @return the old verbose level
#' @export
#' @rdname logging
lverbose <- local({
.val <- as.integer(FALSE)
function(val, global = FALSE){
if( missing(val) ) return( max(getOption('pkg_verbose_level', 0L), .val) )
oval <- .val
.val <<- max(as.integer(val), 0)
# set value globally
if( global ){
options(pkg_verbose_level = val)
}
invisible(oval)
}
})
#' @describeIn logging tells if all verbose messages are silenced.
#' @export
lsilent <- function(){
l <- lverbose()
is.na(l) || l == 0L
}
#' @describeIn logging tells if verbosity is on, i.e. at level greater than 0.
#' @export
is.verbose <- function(){
l <- lverbose()
!is.na(l) && l >= 0L
}
#' @describeIn logging prints out a message (on sdtout) if the verbosity level is greater than a
#' given value.
#'
#' @param ... parts of a character message that are concatenated and passed to
#' the current logger's write function.
#' @param level verbosity level threshold (numeric value) above which the
#' message should be printed out.
#' This threshold is compared with the current verbosity level as returned by
#' \code{lverbose}.
#' @param appendLF logical indicating if an endline character should be appended
#' at the end of the message.
#' @param sep separation character, used when concatenating all arguments in \code{...}.
#' @param force logical that indicates if one should output messages or return a non
#' null logger, even if the verbose mode is not high enough.
#'
#' @export
lmessage <- function(level, ..., appendLF=TRUE, sep='', force=FALSE){
getLogger(force=force)$lmessage(level, ..., appendLF=appendLF, sep=sep, force=force)
}
#' @describeIn logging prints out a log message (at level 1) using the current logger,
#' typically on stdout.
#' It is a shortcut for \code{lmessage(1L, ...)}.
#'
#' @export
vmessage <- function(...){
lmessage(1L, ...)
}
#' @describeIn logging directly appends some message to the current log line.
#' @export
log_append <- function(...){
if( !is.null(w <- getLogger(new=FALSE)$write) ) w(...)
}
# return a list of data about a given frame (i.e. caller function)
callInfo <- function(n=-1L){
if( n<0L ) n <- n-1
f <- sys.function(n)
e <- sys.frame(n)
sysn <- if( n<0L ) sys.nframe()-n else n
list(fd=digest(f), env=capture.output(e), nframe=sysn)
}
log_lastLF <- sVariable(list(Inf, TRUE))
.LOG_OPTIONS <- setupPackageOptions(NAME='logger', RESET=TRUE,
# should a the next logger be indented
autoindent = TRUE
)
logger.options <- .LOG_OPTIONS$options
logger.getOption <- .LOG_OPTIONS$getOption
getLogger <- local({
# store info for top call
.topCall <- NULL
# list of logger objects
.lastLogger <- list()
function(..., type='STDOUT', new=TRUE, force=FALSE){
# return NULL logger if not in verbose mode
if( !force && !lverbose() ) return( new_logger('NULL') )
# top caller
call1 <- sys.call(1)
topCall <- callInfo(1L)
caller <- callInfo(-1L)
# reset all static variables
if( !identical(.topCall, topCall) ){
.topCall <<- topCall
.lastLogger <<- list()
}
## build logger object
if( !length(.lastLogger) ){ # new stored for future calls
logger <- new_logger(type, ...)
logger$caller(caller)
.lastLogger[[as.character(caller$nframe)]] <<- logger
}else{ # increment indentation
autonew <- missing(new)
if( new ){ # get new logger object
last <- getLogger(new=FALSE)
if( !autonew || (!is.null(last$caller()) && last$caller()$nframe < caller$nframe) ){
# instanciate a new logger object only if the current caller is lower in the stack
logger <- new_logger(type, ...)
logger$caller(caller)
# auto indent if last logger is higher in the stack
if( !logger.getOption('autoindent') ){
# reset autoindent option on.exit
on.exit( logger.options(autoindent=TRUE), add=TRUE)
logger$nindent(last$nindent(), add=FALSE)
} else if( last$caller()$nframe < caller$nframe ){
logger$nindent(last$nindent() + 1L, add=FALSE)
}
.lastLogger[[as.character(caller$nframe)]] <<- logger
}else logger <- last
# add initial new line if the last log message was from a higher logger
logger$breaknext(log_lastLF()[[1L]] < caller$nframe)
}else{
# get logger for exact frame number
if( is.null(logger <- .lastLogger[[as.character(caller$nframe)]]) ){
# get first higher logger
i <- which(as.numeric(names(.lastLogger)) <= caller$nframe)
# str(.lastLogger)
if( length(i) ) logger <- .lastLogger[[tail(i, 1L)]]
else logger <- .lastLogger[[1L]]
}
}
}
# return logger
logger
}
})
new_logger <- function(type, ..., nindent=0L, indent=' '){
.data <- list(
lastLF = TRUE
, breaknext = FALSE
, cindent = indent
, nindent = nindent
, indent = rep(indent, nindent)
, caller = NULL
)
# init logger object
.logger <- list()
.logger$data <- function(value){
if( missing(value) ) .data
else .data <<- value
}
# init type-specific slots
f <- match.fun(paste('new_logger', type, sep=''))
.logger <- f(.logger, ...)
# get last used appendLF value
.logger$lastLF <- function(){ .data$lastLF }
# get initial new line flag
.logger$breaknext <- function(val){
if( missing(val) ) .data$breaknext
else .data$breaknext <<- val
}
# get caller data
.logger$caller <- function(val){
if( missing(val) ) .data$caller
else .data$caller <<- val
}
# get/set indentation
.logger$indent <- function(val){
if( missing(val) ) .data$indent
else{
if( is.numeric(val) ) return( .logger$nindent(val) )
old <- .data$indent
.data$indent <<- val
old
}
}
# get/set number of indentation
.logger$nindent <- function(val, add=TRUE){
if( missing(val) ) .data$nindent
else{
old <- .data$nindent
.data$nindent <<- val + if( add ) .data$nindent else 0L
if( .data$nindent >= 0L )
.data$indent <<- paste(rep(.data$cindent, .data$nindent), collapse='')
old
}
}
# new message with auto-indentation and breakline
.logger$message <- function(..., appendLF=TRUE, sep=''){
if( is.null(.logger$write) ) return()
msg <- if( .data$breaknext || isTRUE(logger.getOption('breaknext')) ){
logger.options(breaknext=NULL)
.data$breaknext <<- FALSE
"\n"
}
# add indentation if on a new line
lastLFframe <- log_lastLF()
callerFrame <- .logger$caller()$nframe
if( .data$lastLF || lastLFframe[[2L]] || (is.finite(lastLFframe[[1L]]) && lastLFframe[[1L]] >= callerFrame) )
msg <- paste(msg, .data$indent, sep='')
msg <- paste(msg, paste(..., sep='', collapse=sep), if( appendLF ) "\n", sep='')
# store in global variable the frame number if it the line is left open
log_lastLF(list(if( !appendLF ) callerFrame else Inf, appendLF))
.data$lastLF <<- appendLF
# call logger write function
.logger$write(msg)
}
# log message with specific level
.logger$lmessage <- function(level, ..., force=FALSE){
if( force || lverbose() >= level ) .logger$message(...)
}
# show info about the logger
.logger$show <- function(){
cat("<Type: ", class(.logger)[1L], ">\n", sep='')
.logger$info()
}
# wrap into a logger object
structure(.logger, class=c(paste('logger', type, sep=''), 'logger'))
}
# NULL logger
new_loggerNULL <- function(.logger, ...){
# write to log
.logger$write <- NULL
# special info
.logger$info <- function(){
cat("Output: NULL\n")
}
# return logger object
.logger
}
# Logger that writes on the standard output
new_loggerSTDOUT <- function(.logger, ...){
# append to log
.logger$write <- function(...){
cat(..., sep='')
}
.logger$info <- function(){
cat("Output: stdout\n")
}
# return logger object
.logger
}
# Logger that writes on the standard error
new_loggerSTDERR <- function(.logger, ...){
# append to log
.logger$write <- function(...){
message(..., appendLF=FALSE)
}
.logger$info <- function(){
cat("Output: stderr\n")
}
# return logger object
.logger
}
#' General Log Formating
#'
#' Generate a formatted diagnostic message.
#' This function is a shortcut for \code{message(sprintf(...))}.
#'
#' @inheritParams base::sprintf
#' @inheritParams base::message
#'
#' @return Returns nothing. Used for their side effects of printing messages/warnings.
#' @seealso \code{\link{sprintf}}, \code{\link{message}}
#' @export
#' @examples
#'
#' messagef("Hello %s number %i", 'world', 4)
#'
messagef <- function(fmt, ..., domain = NULL, appendLF = TRUE) message(sprintf(fmt, ...), domain = domain, appendLF = appendLF)
#' @describeIn messagef throws a simple note as an immediate warning.
#' It is a shorcut for `warning(..., immediate. = TRUE, call. = FALSE)`.
#'
#' @inheritParams base::warning
#' @export
wnote <- function(..., immediate. = TRUE){
warning(..., immediate. = immediate., call. = FALSE)
}
#' Simple Text Iteration Counter
#'
#' @param n number of total steps
#' @param i0 starting step
#' @param title character string to use as title
#' @param extra character vector providing extra text to add at each step
#' @param verbose logical that toggles the counter
#'
#' @return A function that can be used to increment progress.
#' @export
#' @examples
#'
#' progress <- iterCount(LETTERS)
#' res <- sapply(LETTERS, function(x){
#' Sys.sleep(.1)
#' progress()
#' })
#' # terminate counter
#' i_end <- progress(NULL)
#' i_end
#'
iterCount <- function(n = 100, i0 = 0L, title = 'Iterations', extra = NULL, verbose = TRUE){
if( !verbose ) return( function(...) NULL )
if( length(n) > 1L || is.character(n) ){
extra <- extra %||% n
n <- length(n)
}
# setup
size_i <- nchar(as.character(n))
if( nzchar(title) ) title <- paste0(title, ': ')
.msg_fmt <- sprintf("%s%%%ii/%i", title, size_i, n)
inc_msg <- function(i, addon = extra[i]){
if( !length(addon) || is.na(addon) ) sprintf(.msg_fmt, i, '')
else paste0(sprintf(.msg_fmt, i, addon))
}
.cat_msg <- function(msg){
cat(msg)
flush.console()
nchar(msg)
}
if( !is.null(extra) ){
.msg_fmt <- paste0(.msg_fmt, " (%s)")
.msg_size <- inc_msg(n, extra[which.max(nchar(extra))])
}else .msg_size <- inc_msg(n)
.msg_size <- nchar(.msg_size)
.back <- paste0(rep("\b", .msg_size), collapse ='')
.i <- i0
.last_msg_size <- .cat_msg(inc_msg(i0))
# increment function
function(i, appendLF = i == n){
if( missing(i) ) i <- .i
else if( is.null(i) ){
if( .i < n ) cat("\n")
i_stop <- .i
.i <<- i0
return(invisible(i_stop))
}
.i <<- i+1
msg <- paste0(substr(.back, 1L, .last_msg_size), msg0 <- inc_msg(.i))
.cat_msg(msg)
.last_msg_size <<- nchar(msg0)
if( appendLF ) cat("\n")
invisible(.i)
}
}
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.