1 |
#' Register handlers for logging messages, warnings and errors |
|
2 |
#' |
|
3 |
#' @param namespace (`character(1)`) the logger namespace |
|
4 |
#' @param package (`character(1)`) the package name |
|
5 |
#' |
|
6 |
#' @return `NULL` invisibly. Called for its side effects. |
|
7 |
#' |
|
8 |
#' @details |
|
9 |
#' This function registers global handlers for messages, warnings and errors. |
|
10 |
#' The handlers will investigate the call stack and if it contains a function |
|
11 |
#' from the package, the message, warning or error will be logged into the respective |
|
12 |
#' namespace. |
|
13 |
#' |
|
14 |
#' The handlers are registered only once per package and type. Consecutive calls will no effect. |
|
15 |
#' Registering handlers for package `base` is not supported. |
|
16 |
#' |
|
17 |
#' Use `TEAL.LOG_MUFFLE` environmental variable or `teal.log_muffle` R option to optionally |
|
18 |
#' control recover strategies. If `TRUE` (a default value) then the handler will jump to muffle |
|
19 |
#' restart for a given type of condition and doesn't continue (with output to the console). |
|
20 |
#' Applicable for message and warning types only. The errors won't be suppressed. |
|
21 |
#' |
|
22 |
#' @note Registering handlers is forbidden within `tryCatch()` or `withCallingHandlers()`. |
|
23 |
#' Because of this, handlers are registered only if it is possible. |
|
24 |
#' |
|
25 |
#' @seealso [globalCallingHandlers()] |
|
26 |
#' |
|
27 |
#' @export |
|
28 |
#' |
|
29 |
#' @examples |
|
30 |
#' \dontrun{ |
|
31 |
#' register_handlers("teal.logger") |
|
32 |
#' # see the outcome |
|
33 |
#' globalCallingHandlers() |
|
34 |
#' } |
|
35 |
register_handlers <- function(namespace, package = namespace) { |
|
36 | 10x |
if (register_handlers_possible()) { |
37 | 10x |
register_handler_type(namespace = namespace, package = package, type = "message") |
38 | 3x |
register_handler_type(namespace = namespace, package = package, type = "warning") |
39 | 3x |
register_handler_type(namespace = namespace, package = package, type = "error") |
40 |
} |
|
41 | ||
42 | 3x |
invisible(NULL) |
43 |
} |
|
44 | ||
45 |
register_handler_type <- function( |
|
46 |
namespace, |
|
47 |
package = namespace, |
|
48 |
type = c("error", "warning", "message")) { |
|
49 | 16x |
if (!(is.character(namespace) && length(namespace) == 1 && !is.na(namespace))) { |
50 | 3x |
stop("namespace argument must be a single string.") |
51 |
} |
|
52 | 13x |
if (!(namespace %in% logger::log_namespaces())) { |
53 | 1x |
stop("namespace argument must be a pre-registered logger namespace.") |
54 |
} |
|
55 | 12x |
if (!(is.character(package) && length(package) == 1 && !is.na(package))) { |
56 | 3x |
stop("package argument must be a single string.") |
57 |
} |
|
58 | 9x |
match.arg(type) |
59 | ||
60 | 9x |
registered_handlers_namespaces[[package]] <- namespace |
61 | ||
62 |
# avoid re-registering handlers |
|
63 | 9x |
gch <- globalCallingHandlers()[names(globalCallingHandlers()) == type] |
64 | 9x |
if (length(gch) > 0 && any(sapply(gch, attr, "type") == "teal.logger_handler")) { |
65 | 3x |
return(invisible(NULL)) |
66 |
} |
|
67 | ||
68 |
# create a handler object |
|
69 |
# loop through the call stack starting from the bottom (the last call) |
|
70 |
# if a function is from pre-registered package then log using pre-specified namespace |
|
71 | 6x |
logger_fun <- switch(type, |
72 | 6x |
error = logger::log_error, |
73 | 6x |
warning = logger::log_warn, |
74 | 6x |
message = logger::log_info |
75 |
) |
|
76 |
# nocov start |
|
77 |
handler_fun <- function(m) { |
|
78 |
i <- sys.nframe() - 1L # loop starting from the bottom of the stack and go up |
|
79 |
while (i > 0L) { # exclude 0L as this value will detect the current `handler_fun()` function |
|
80 |
env_sys_fun_i <- environment(sys.function(i)) |
|
81 |
pkg_sys_fun_i <- if (!is.null(env_sys_fun_i)) { # primitive functions don't have environment |
|
82 |
methods::getPackageName(env_sys_fun_i) |
|
83 |
} else { |
|
84 |
"" |
|
85 |
} |
|
86 |
if (pkg_sys_fun_i %in% ls(envir = registered_handlers_namespaces)) { |
|
87 |
msg <- parse_logger_message(m) |
|
88 | ||
89 |
log_namespace <- registered_handlers_namespaces[[pkg_sys_fun_i]] |
|
90 |
logger_fun(msg, namespace = log_namespace) |
|
91 | ||
92 |
# muffle restart |
|
93 |
if (isTRUE(as.logical(get_val("TEAL.LOG_MUFFLE", "teal.log_muffle", TRUE)))) { |
|
94 |
if (type == "message") { |
|
95 |
invokeRestart("muffleMessage") |
|
96 |
} |
|
97 |
if (type == "warning") { |
|
98 |
invokeRestart("muffleWarning") |
|
99 |
} |
|
100 |
} |
|
101 | ||
102 |
break |
|
103 |
} |
|
104 |
i <- i - 1L |
|
105 |
} |
|
106 |
m |
|
107 |
} |
|
108 |
# nocov end |
|
109 |
# add attributes to enable checking if the handler is already registered |
|
110 | 6x |
handler_obj <- structure( |
111 | 6x |
handler_fun, |
112 | 6x |
type = "teal.logger_handler" |
113 |
) |
|
114 | ||
115 |
# construct & eval the call - globalCallingHandlers() requires named arguments |
|
116 | 6x |
do.call( |
117 | 6x |
globalCallingHandlers, |
118 | 6x |
stats::setNames(list(handler_obj), type) |
119 |
) |
|
120 | ||
121 | 6x |
invisible(NULL) |
122 |
} |
|
123 | ||
124 |
parse_logger_message <- function(m) { |
|
125 | 8x |
stopifnot(inherits(m, "condition")) |
126 | ||
127 | 7x |
type <- class(m)[2] |
128 | 7x |
msg <- m$message |
129 | 7x |
if (type %in% c("error", "warning") && !is.null(m$call)) { |
130 | 4x |
msg <- sprintf("In %s: %s", sQuote(paste0(format(m$call), collapse = "")), msg) |
131 |
} |
|
132 | 7x |
return(msg) |
133 |
} |
|
134 | ||
135 |
register_handlers_possible <- function() { |
|
136 | 2x |
for (i in seq_len(sys.nframe())) { |
137 | 12x |
if (identical(sys.function(i), tryCatch) || identical(sys.function(i), withCallingHandlers)) { |
138 | 2x |
return(FALSE) |
139 |
} |
|
140 |
} |
|
141 |
return(TRUE) # nocov: impossible to cover because testthat introduces it's own handlers and we want to return FALSE |
|
142 |
} |
1 |
#' Auto logging input changes in Shiny app |
|
2 |
#' |
|
3 |
#' This is to be called in the \code{server} section of the Shiny app. |
|
4 |
#' |
|
5 |
#' Function having very similar behavior as [logger::log_shiny_input_changes()] but adjusted for `teal` needs. |
|
6 |
#' |
|
7 |
#' @param input passed from Shiny `server` |
|
8 |
#' @param excluded_inputs (`character`) character vector of input names to exclude from logging |
|
9 |
#' @param excluded_pattern (`character(1)`) `regexp` pattern of names to be excluded from logging |
|
10 |
#' @param namespace (`character(1)`) the name of the namespace |
|
11 |
#' @param session the Shiny session |
|
12 |
#' @examples |
|
13 |
#' \dontrun{ |
|
14 |
#' library(shiny) |
|
15 |
#' |
|
16 |
#' ui <- bootstrapPage( |
|
17 |
#' numericInput("mean1", "mean1", 0), |
|
18 |
#' numericInput("mean2", "mean2", 0), |
|
19 |
#' numericInput("sd", "sd", 1), |
|
20 |
#' textInput("title", "title", "title"), |
|
21 |
#' textInput("foo", "This is not used at all, still gets logged", "foo"), |
|
22 |
#' passwordInput("password", "Password not to be logged", "secret"), |
|
23 |
#' plotOutput("plot") |
|
24 |
#' ) |
|
25 |
#' |
|
26 |
#' server <- function(input, output) { |
|
27 |
#' log_shiny_input_changes(input, excluded_inputs = "password", excluded_pattern = "mean") |
|
28 |
#' |
|
29 |
#' output$plot <- renderPlot({ |
|
30 |
#' hist(rnorm(1e3, input$mean, input$sd), main = input$title) |
|
31 |
#' }) |
|
32 |
#' } |
|
33 |
#' |
|
34 |
#' shinyApp(ui = ui, server = server) |
|
35 |
#' } |
|
36 |
#' @export |
|
37 |
log_shiny_input_changes <- function( |
|
38 |
input, |
|
39 |
namespace = NA_character_, |
|
40 |
excluded_inputs = character(), |
|
41 |
excluded_pattern = "_width$", |
|
42 |
session = shiny::getDefaultReactiveDomain()) { |
|
43 | ! |
stopifnot(inherits(input, "reactivevalues")) |
44 | ! |
stopifnot(is.character(namespace) && length(namespace) == 1) |
45 | ! |
stopifnot(is.character(excluded_inputs)) |
46 | ! |
stopifnot(is.character(excluded_pattern) && length(excluded_pattern) == 1) |
47 | ! |
stopifnot(inherits(session, "session_proxy")) |
48 | ||
49 | ! |
if (logger::TRACE > logger::as.loglevel(get_val("TEAL.LOG_LEVEL", "teal.log_level", "INFO"))) { |
50 |
# to avoid setting observers when not needed |
|
51 | ! |
return(invisible(NULL)) |
52 |
} |
|
53 | ||
54 | ! |
ns <- session$ns(character(0)) |
55 | ! |
reactive_input_list <- shiny::reactive({ |
56 | ! |
input_list <- shiny::reactiveValuesToList(input) |
57 | ! |
input_list[!grepl(excluded_pattern, names(input_list))] |
58 |
}) |
|
59 | ! |
shiny_input_values <- shiny::reactiveVal(shiny::isolate(reactive_input_list())) |
60 | ||
61 | ! |
shiny::observeEvent(reactive_input_list(), { |
62 | ! |
old_input_values <- shiny_input_values() |
63 | ! |
new_input_values <- reactive_input_list() |
64 | ! |
names <- intersect(names(old_input_values), names(new_input_values)) |
65 | ! |
for (name in names) { |
66 | ! |
old <- old_input_values[[name]] |
67 | ! |
new <- new_input_values[[name]] |
68 | ! |
if (!identical(old, new)) { |
69 | ! |
message <- trimws("{ns} Shiny input change detected in {name}: {old} -> {new}") |
70 | ! |
logger::log_trace(message, namespace = namespace) |
71 |
} |
|
72 |
} |
|
73 | ! |
shiny_input_values(new_input_values) |
74 |
}) |
|
75 |
} |
1 |
#' Logs the basic information about the session. |
|
2 |
#' |
|
3 |
#' @return `invisible(NULL)` |
|
4 |
#' @export |
|
5 |
#' |
|
6 |
log_system_info <- function() { |
|
7 | 1x |
paste_pkgs_name_with_version <- function(names) { |
8 | 2x |
vapply( |
9 | 2x |
names, |
10 | 2x |
FUN = function(name) paste(name, utils::packageVersion(name)), |
11 | 2x |
FUN.VALUE = character(1), |
12 | 2x |
USE.NAMES = FALSE |
13 |
) |
|
14 |
} |
|
15 | ||
16 | 1x |
info <- utils::sessionInfo() |
17 | ||
18 | 1x |
logger::log_trace("Platform: { info$platform }") |
19 | 1x |
logger::log_trace("Running under: { info$running }") |
20 | 1x |
logger::log_trace("{ info$R.version$version.string }") |
21 | 1x |
logger::log_trace("Base packages: { paste(info$basePkgs, collapse = ' ') }") |
22 | ||
23 |
# Paste package names and versions |
|
24 | 1x |
pasted_names_and_versions <- paste(paste_pkgs_name_with_version(names(info$otherPkgs)), collapse = ", ") |
25 | 1x |
logger::log_trace("Other attached packages: { pasted_names_and_versions }") |
26 | ||
27 | 1x |
pasted_names_and_versions <- paste(paste_pkgs_name_with_version(names(info$loadedOnly)), collapse = ", ") |
28 | 1x |
logger::log_trace("Loaded packages: { pasted_names_and_versions }") |
29 |
} |
|
30 | ||
31 |
#' Get value from environmental variable or R option or default in that order if the previous one is missing. |
|
32 |
#' @param env_var_name (`character(1)`) name of the system variable |
|
33 |
#' @param option_name (`character(1)`) name of the option |
|
34 |
#' @param default optional, default value if both `Sys.getenv(env_var_name)` and `getOption(option_name)` are empty |
|
35 |
#' @return an object of any class |
|
36 |
#' @keywords internal |
|
37 |
get_val <- function(env_var_name, option_name, default = NULL) { |
|
38 | 25x |
value <- Sys.getenv(env_var_name) |
39 | 21x |
if (is.null(value) || value == "") value <- getOption(option_name, default = default) |
40 | 24x |
return(value) |
41 |
} |
1 |
#' Registers a logger instance in a given logging namespace. |
|
2 |
#' |
|
3 |
#' @description `r lifecycle::badge("experimental")` |
|
4 |
#' |
|
5 |
#' @note It's a thin wrapper around the `logger` package. |
|
6 |
#' |
|
7 |
#' @details Creates a new logging namespace specified by the `namespace` argument. |
|
8 |
#' When the `layout` and `level` arguments are set to `NULL` (default), the function |
|
9 |
#' gets the values for them from system variables or R options. |
|
10 |
#' When deciding what to use (either argument, an R option or system variable), the function |
|
11 |
#' picks the first non `NULL` value, checking in order: |
|
12 |
#' 1. Function argument. |
|
13 |
#' 2. System variable. |
|
14 |
#' 3. R option. |
|
15 |
#' |
|
16 |
#' `layout` and `level` can be set as system environment variables, respectively: |
|
17 |
#' * `teal.log_layout` as `TEAL.LOG_LAYOUT`, |
|
18 |
#' * `teal.log_level` as `TEAL.LOG_LEVEL`. |
|
19 |
#' |
|
20 |
#' If neither the argument nor the environment variable is set the function uses the following R options: |
|
21 |
#' * `options(teal.log_layout)`, which is passed to [logger::layout_glue_generator()], |
|
22 |
#' * `options(teal.log_level)`, which is passed to [logger::log_threshold()] |
|
23 |
#' |
|
24 |
#' |
|
25 |
#' The logs are output to `stdout` by default. Check `logger` for more information |
|
26 |
#' about layouts and how to use `logger`. |
|
27 |
#' |
|
28 |
#' @seealso The package vignettes for more help: `browseVignettes("teal.logger")`. |
|
29 |
#' |
|
30 |
#' @param namespace (`character(1)` or `NA_character_`)\cr |
|
31 |
#' the name of the logging namespace |
|
32 |
#' @param layout (`character(1)`)\cr |
|
33 |
#' the log layout. Alongside the standard logging variables provided by the `logging` package |
|
34 |
#' (e.g. `pid`) the `token` variable can be used which will write the last 8 characters of the |
|
35 |
#' shiny session token to the log. |
|
36 |
#' @param level (`character(1)` or `call`) the log level. Can be passed as |
|
37 |
#' character or one of the `logger`'s objects. |
|
38 |
#' See [logger::log_threshold()] for more information. |
|
39 |
#' |
|
40 |
#' @return `invisible(NULL)` |
|
41 |
#' @export |
|
42 |
#' |
|
43 |
#' @examples |
|
44 |
#' options(teal.log_layout = "{msg}") |
|
45 |
#' options(teal.log_level = "ERROR") |
|
46 |
#' register_logger(namespace = "new_namespace") |
|
47 |
#' \donttest{ |
|
48 |
#' logger::log_info("Hello from new_namespace", namespace = "new_namespace") |
|
49 |
#' } |
|
50 |
#' |
|
51 |
register_logger <- function(namespace = NA_character_, |
|
52 |
layout = NULL, |
|
53 |
level = NULL) { |
|
54 | 12x |
if (!((is.character(namespace) && length(namespace) == 1) || is.na(namespace))) { |
55 | 1x |
stop("namespace argument to register_logger must be a single string or NA.") |
56 |
} |
|
57 | ||
58 | 11x |
if (is.null(level)) { |
59 | 9x |
level <- get_val("TEAL.LOG_LEVEL", "teal.log_level", "INFO") |
60 |
} |
|
61 | ||
62 | 11x |
tryCatch( |
63 | 11x |
logger::log_threshold(level, namespace = namespace), |
64 | 11x |
error = function(condition) { |
65 | 1x |
stop(paste( |
66 | 1x |
"The log level passed to logger::log_threshold was invalid.", |
67 | 1x |
"Make sure you pass or set the correct log level.", |
68 | 1x |
"See `logger::log_threshold` for more information" |
69 |
)) |
|
70 |
} |
|
71 |
) |
|
72 | ||
73 | 10x |
if (is.null(layout)) { |
74 | 9x |
layout <- get_val( |
75 | 9x |
"TEAL.LOG_LAYOUT", |
76 | 9x |
"teal.log_layout", |
77 | 9x |
"[{level}] {format(time, \"%Y-%m-%d %H:%M:%OS4\")} pid:{pid} token:[{token}] {ans} {msg}" |
78 |
) |
|
79 |
} |
|
80 | ||
81 | 10x |
tryCatch( |
82 | 10x |
expr = { |
83 | 10x |
logger::log_layout(layout_teal_glue_generator(layout), namespace = namespace) |
84 | 10x |
logger::log_appender(logger::appender_file(nullfile()), namespace = namespace) |
85 | 10x |
logger::log_success("Set up the logger", namespace = namespace) |
86 | 9x |
logger::log_appender(logger::appender_stdout, namespace = namespace) |
87 |
}, |
|
88 | 10x |
error = function(condition) { |
89 | 1x |
stop(paste( |
90 | 1x |
"Error setting the layout of the logger.", |
91 | 1x |
"Make sure you pass or set the correct log layout.", |
92 | 1x |
"See `logger::layout` for more information." |
93 |
)) |
|
94 |
} |
|
95 |
) |
|
96 | ||
97 | 9x |
invisible(NULL) |
98 |
} |
|
99 | ||
100 | ||
101 |
#' Generate log layout function using common variables available via glue syntax including shiny session token |
|
102 |
#' |
|
103 |
#' @inheritParams register_logger |
|
104 |
#' @return function taking `level` and `msg` arguments - keeping the original call creating the generator |
|
105 |
#' in the generator attribute that is returned when calling log_layout for the currently used layout |
|
106 |
#' @details this function behaves in the same way as [logger::layout_glue_generator()] |
|
107 |
#' but allows the shiny session token (last 8 chars) to be included in the logging layout |
|
108 |
#' @keywords internal |
|
109 |
layout_teal_glue_generator <- function(layout) { |
|
110 | 10x |
force(layout) |
111 | 10x |
structure( |
112 | 10x |
function(level, msg, namespace = NA_character_, .logcall = sys.call(), .topcall = sys.call(-1), |
113 | 10x |
.topenv = parent.frame()) { |
114 | 10x |
if (!inherits(level, "loglevel")) { |
115 | ! |
stop("Invalid log level, see ?logger::log_levels") |
116 |
} |
|
117 | 10x |
with(logger::get_logger_meta_variables( |
118 | 10x |
log_level = level, namespace = namespace, .logcall = .logcall, .topcall = .topcall, |
119 | 10x |
.topenv = .topenv |
120 |
), { |
|
121 | 10x |
token <- substr(shiny::getDefaultReactiveDomain()$token, 25, 32) |
122 | 10x |
if (length(token) == 0) { |
123 | 10x |
token <- "" |
124 |
} |
|
125 | 10x |
glue::glue(layout) |
126 |
}) |
|
127 |
}, |
|
128 | 10x |
generator = deparse(match.call()) |
129 |
) |
|
130 |
} |
1 |
#' Suppress logger logs |
|
2 |
#' |
|
3 |
#' This function suppresses `logger` when running tests via `testthat`. |
|
4 |
#' To suppress logs for a single test, add this function |
|
5 |
#' call within the `testthat::test_that` expression. To suppress logs for an entire |
|
6 |
#' test file, call this function at the start of the file. |
|
7 |
#' |
|
8 |
#' @return `NULL` invisible |
|
9 |
#' @export |
|
10 |
#' @examplesIf require("logger") && require("testthat") |
|
11 |
#' testthat::test_that("An example test", { |
|
12 |
#' suppress_logs() |
|
13 |
#' testthat::expect_true(TRUE) |
|
14 |
#' }) |
|
15 |
#' |
|
16 |
suppress_logs <- function() { |
|
17 | ! |
old_log_appenders <- lapply(logger::log_namespaces(), function(ns) logger::log_appender(namespace = ns)) |
18 | ! |
old_log_namespaces <- logger::log_namespaces() |
19 | ! |
logger::log_appender(logger::appender_file(nullfile()), namespace = logger::log_namespaces()) |
20 | ! |
withr::defer_parent( |
21 | ! |
mapply( |
22 | ! |
function(appender, namespace) { |
23 | ! |
logger::log_appender(eval(appender), namespace) |
24 |
}, |
|
25 | ! |
old_log_appenders, |
26 | ! |
old_log_namespaces |
27 |
) |
|
28 |
) |
|
29 | ! |
invisible(NULL) |
30 |
} |
1 |
#' Teal `log_formatter` |
|
2 |
#' |
|
3 |
#' Custom `log_formatter` supporting atomic vectors. By default `glue::glue` |
|
4 |
#' returns n-element vector when vector is provided as an input. This function |
|
5 |
#' generates `"[elem1, elem2, ...]"` for atomic vectors. Function also handles |
|
6 |
#' `NULL` value which normally causes `logger` to return empty character. |
|
7 |
#' @name teal_logger_formatter |
|
8 |
#' @return Nothing. Called for its side effects. |
|
9 |
#' @keywords internal |
|
10 |
teal_logger_formatter <- function() { |
|
11 | ! |
logger::log_formatter( |
12 | ! |
function(..., .logcall = sys.call(), .topcall = sys.call(-1), .topenv = parent.frame()) { |
13 | ! |
logger::formatter_glue( |
14 |
..., |
|
15 | ! |
.logcall = .logcall, .topcall = .topcall, .topenv = .topenv, |
16 | ! |
.transformer = teal_logger_transformer |
17 |
) |
|
18 |
} |
|
19 |
) |
|
20 |
} |
|
21 | ||
22 |
#' @rdname teal_logger_formatter |
|
23 |
#' @inheritParams glue::identity_transformer |
|
24 |
teal_logger_transformer <- function(text, envir) { |
|
25 | 10x |
value <- glue::identity_transformer(text, envir) |
26 | 10x |
expr <- dput(value, file = nullfile()) |
27 | 10x |
deparse1(expr) |
28 |
} |