Nothing
as_log_levels <- function(x){
assert(is_integerish(x) && identical(length(names(x)), length(x)))
assert(all_are_distinct(x))
assert(all_are_distinct(names(x)))
assert(
!anyNA(x) & all (x > 0),
"Log levels must be positive integers. The log levels `0` (off) and `NA` ",
"(all) are reserved."
)
x <- setNames(as.integer(x), names(x))
structure(sort(x), class = c("log_levels", "integer"))
}
DEFAULT_LOG_LEVELS <- c("fatal", "error", "warn", "info", "debug", "trace")
# manage options ----------------------------------------------------------
#' Manage Log Levels
#'
#' Display, add and remove character labels for log levels.
#'
#' @return a named `character` vector of the globally available log levels
#' (`add_log_levels()` and `remove_log_levels()` return invisibly).
#' @export
#'
#'
#' @section Default Log Levels:
#'
#' lgr comes with the following predefined log levels that are identical to
#' the log levels of log4j.
#'
#'\tabular{rll}{
#' Level \tab Name \tab Description \cr
#' `0` \tab off \tab A log level of 0/off tells a Logger or Appender to suspend all logging \cr
#' `100` \tab fatal \tab Critical error that leads to program abort. Should always indicate a `stop()` or similar \cr
#' `200` \tab error \tab A severe error that does not trigger program abort\cr
#' `300` \tab warn \tab A potentially harmful situation, like `warning()`\cr
#' `400` \tab info \tab An informational message on the progress of the application\cr
#' `500` \tab debug \tab Finer grained informational messages that are mostly useful for debugging\cr
#' `600` \tab trace \tab An even finer grained message than debug\cr
#' `NA` \tab all \tab A log level of NA/all tells a Logger or Appender to process all log events
#' }
#' @aliases log_levels log_level
#' @examples
#' get_log_levels()
#' add_log_levels(c(errorish = 250))
#' get_log_levels()
#' remove_log_levels("errorish")
#' get_log_levels()
get_log_levels <- function(){
getOption("lgr.log_levels")
}
#' @param levels a named `character` vector (see examples)
#' @rdname get_log_levels
#' @export
add_log_levels <- function(
levels
){
levels_cur <- getOption("lgr.log_levels")
assert(
!is.null(levels_cur),
"lgr.log_levels option is not set. something is very wrong with lgr, please file a bug report"
)
assert(
is_integerish(levels),
"`levels` must be a named integer vector"
)
assert(length(names(levels)) && all_are_distinct(names(levels)))
levels_new <- setNames(as.integer(levels), names(levels))
levels_upd <- levels_new[levels_new %in% levels_cur]
if (length(levels_upd)){
message(
"Replacing existing log levels '",
fmt_log_levels(levels_new[levels_new %in% levels_cur]),
"' with '",
fmt_log_levels(levels_upd), "'"
)
}
res <- as_log_levels(named_union(levels_cur, levels_new))
options(lgr.log_levels = res)
invisible(get_log_levels())
}
#' union for named vectors. names of `y` override names of `x`
#' @noRd
named_union <- function(x, y){
assert(identical(length(names(x)), length(x)))
assert(identical(length(names(y)), length(y)))
r <- union(x, y)
names(r)[r %in% x] <- names(x[x %in% r])
names(r)[r %in% y] <- names(y[y %in% r])
r
}
#' @param level_names a `character` vector of the names of the levels to remove
#' @rdname get_log_levels
#' @export
remove_log_levels <- function(
level_names
){
assert(is.character(level_names))
assert(
!any(DEFAULT_LOG_LEVELS %in% level_names),
"Cannot remove default log levels"
)
current_lvls <- getOption("lgr.log_levels")
assert(all(level_names %in% names(current_lvls)))
res <- current_lvls[!names(current_lvls) %in% level_names]
res <- as_log_levels(res)
options(lgr.log_levels = res)
invisible(get_log_levels())
}
# format ------------------------------------------------------------------
fmt_log_levels <- function(
x
){
paste0(names(sort(x)), " (", sort(x), ")", collapse = ", ")
}
#' Colorize Levels
#'
#' @param x `numeric` or `character` levels to be colored. Unlike in many other
#' functions in lgr, `character` levels are *not* case sensitive in this
#' function and leading/trailing whitespace is ignored to make it more
#' comfortable to use `colorize_levels()` inside formatting functions.
#' @param transform a `function` to transform `x` (for example `toupper()`)
#' @inheritParams format.LogEvent
#'
#' @return a `character` vector wit color ANSI codes
#' @family formatting utils
#' @export
#'
#' @examples
#' cat(colorize_levels(c(100, 200)))
#' cat(colorize_levels(c("trace", "warn ", "DEBUG")))
#' cat(colorize_levels(c("trace", "warn ", "DEBUG"), transform = function(x) strtrim(x, 1) ))
colorize_levels <- function(
x,
colors = getOption("lgr.colors", NULL),
transform = identity
){
if (length(x) && length(colors)){
if (is.character(x))
dd <- standardize_log_levels(trimws(tolower(x)))
else
dd <- standardize_log_levels(x)
cn <- standardize_log_levels( tolower(names(colors)))
for (i in seq_along(colors)){
sel <- dd == cn[[i]]
x[sel] <- colors[[i]](transform(x[sel]))
}
}
x
}
# standardize ------------------------------------------------------------
#' Standardize User-Input Log Levels to Their Integer Representation
#'
#' These are helper functions for verifying log levels and converting them from
#' their character to their integer representations. This is primarily useful
#' if you want to build your own [Loggers], [Appenders] or [Layouts] and need
#' to handle log levels in a way that is consistent with \pkg{lgr} .
#'
#' @param x a `character` or `integer` scalar, or vector for
#' standardize_log_levels
#' @param log_levels named `integer` vector of valid log levels
#'
#' @return An unnamed `integer` vector
#' @family docs relevant for extending lgr
#' @export
#' @examples
#'
#' standardize_threshold("info")
#' standardize_threshold("all")
#' is_threshold("all")
#' is_threshold("foobar")
#'
#' standardize_log_level("info")
#' # all is a valid threshold, but not a valid log level
#' try(is.na(standardize_log_level("all")))
#' is_log_level("all")
#'
#' # standardized_log_level intentionally only works with scalars, because many
#' # functions require scalar log level inputs
#' try(standardize_log_level(c("info", "fatal")))
#'
#' # You can still use standardize_log_levels() (plural) to work with vectors
#' standardize_log_levels(c("info", "fatal"))
standardize_threshold <- function(
x,
log_levels = c(getOption("lgr.log_levels"), c("all" = NA_integer_, "off" = 0L))
){
assert(is_scalar(x), "A threshold must be a scalar (a vector of length 1)" )
if (is.na(x)){
return(NA_integer_)
}
if (is_integerish(x) && x >= 0){
return(as.integer(x))
}
if (is.character(x) && (x %in% names(log_levels)) ){
return(unname(log_levels[match(x, names(log_levels))]))
}
stop(error_msg_log_levels(deparse(substitute(x)), log_levels))
}
#' @rdname standardize_threshold
#' @export
is_threshold <- function(x){
tryCatch(
{standardize_threshold(x); TRUE},
error = function(...) FALSE
)
}
#' @rdname standardize_threshold
#' @export
standardize_log_level <- function(
x,
log_levels = getOption("lgr.log_levels")
){
assert(is_scalar(x), "'", deparse(substitute(x)), "' must be a scalar log level")
if (is_integerish(x) && x > 0){
return(as.integer(x))
}
if (is.character(x) && (x %in% names(log_levels)) ){
return(unname(log_levels[match(x, names(log_levels))]))
}
stop(error_msg_log_levels(deparse(substitute(x)), log_levels))
}
#' @rdname standardize_threshold
#' @export
is_log_level <- function(x){
tryCatch(
{standardize_log_level(x); TRUE},
error = function(...) FALSE
)
}
#' @rdname standardize_threshold
#' @export
standardize_log_levels <- function(
x,
log_levels = getOption("lgr.log_levels")
){
if (is_integerish(x) && all(x > 0)){
return(as.integer(x))
}
if (is.character(x) && all(x %in% names(log_levels)) ){
return(unname(log_levels[match(x, names(log_levels))]))
}
stop(error_msg_log_levels(deparse(substitute(x)), log_levels))
}
#' @rdname standardize_threshold
#' @export
is_log_levels <- function(x){
tryCatch(
{standardize_log_levels(x); TRUE},
error = function(...) FALSE
)
}
error_msg_log_levels <- function(varname, log_levels){
ll_text <-
paste(sprintf("%s (%s)", names(log_levels), log_levels), collapse = ", ")
paste0(
"'", varname, "' must either the numeric or character representation ",
"of one of the following log levels: ", ll_text
)
}
# label/unlabel -----------------------------------------------------------
#' Label/Unlabel Log Levels
#'
#' @param levels an `integer` vector of log levels
#' @param labels a `character` vector of log level labels. Please note that
#' log levels are lowercase by default, even if many appenders print them
#' in uppercase.
#' @inheritParams standardize_threshold
#'
#' @return a `character` vector for `label_levels()` and an integer vector for
#' `unlabel_levels`
#'
#' @seealso [get_log_levels()]
#' @family formatting utils
#' @export
#' @examples
#' x <- label_levels(c(seq(0, 600, by = 100), NA))
#' print(x)
#' unlabel_levels(x)
label_levels <- function(
levels,
log_levels = getOption("lgr.log_levels")
){
if (!is.numeric(levels))
stop("Expected numeric 'levels'")
res <- names(log_levels)[match(levels, log_levels)]
res[is.na(levels)] <- "all"
res[levels == 0] <- "off"
names(res) <- levels
if (anyNA(res))
warning("Some `levels` were not valid numeric log levels, coercing to `NA`")
res
}
#' @rdname label_levels
#' @export
unlabel_levels <- function(
labels,
log_levels = getOption("lgr.log_levels")
){
if (!is.character(labels))
stop("Expected character 'labels'")
res <- log_levels[match(labels, names(log_levels))]
if (!is.null(names(labels)) && any(is.na(res))){
res[is.na(res)] <- as.integer(names(labels)[is.na(res)])
}
if (anyNA(labels) || any(!labels %in% c(names(log_levels), "all", "off")))
warning(
"Some `labels` were not valid character log levels. Please",
"consider adding them to the global log levels with `?add_log_levels`"
)
res[labels == "off"] <- 0L
names(res) <- labels
res
}
Any scripts or data that you put into this service are public.
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.