| 1 | #' Registers a logger instance in a given logging namespace. | |
| 2 | #' | |
| 3 | #' @description `r lifecycle::badge("stable")` | |
| 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 | #' 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$mean1, 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") || inherits(session, "ShinySession")) | 
| 48 | ||
| 49 | # Log even if written in lower case or numeric values | |
| 50 | ! |   log_level <- get_val("TEAL.LOG_LEVEL", "teal.log_level", "INFO") | 
| 51 | ! | if (!is.numeric(log_level)) log_level <- toupper(log_level) | 
| 52 | ! |   if (logger::TRACE > logger::as.loglevel(log_level)) { | 
| 53 | # to avoid setting observers when not needed | |
| 54 | ! | return(invisible(NULL)) | 
| 55 | } | |
| 56 | ||
| 57 | ! | ns <- session$ns(character(0)) | 
| 58 | ! |   reactive_input_list <- shiny::reactive({ | 
| 59 | ! | input_list <- shiny::reactiveValuesToList(input) | 
| 60 | ! | input_list[!grepl(excluded_pattern, names(input_list))] | 
| 61 | }) | |
| 62 | ! | shiny_input_values <- shiny::reactiveVal(shiny::isolate(reactive_input_list())) | 
| 63 | ||
| 64 | ! |   shiny::observeEvent(reactive_input_list(), { | 
| 65 | ! | old_input_values <- shiny_input_values() | 
| 66 | ! | new_input_values <- reactive_input_list() | 
| 67 | ! | names <- intersect(names(old_input_values), names(new_input_values)) | 
| 68 | ! |     for (name in names) { | 
| 69 | ! | old <- old_input_values[[name]] | 
| 70 | ! | new <- new_input_values[[name]] | 
| 71 | ! |       if (!identical(old, new)) { | 
| 72 | ! |         message <- trimws("{ns} Shiny input change detected in {name}: {old} -> {new}") | 
| 73 | ! | logger::log_trace(message, namespace = namespace) | 
| 74 | } | |
| 75 | } | |
| 76 | ! | shiny_input_values(new_input_values) | 
| 77 | }) | |
| 78 | } | 
| 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 | #' 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(logger::skip_formatter(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 | 11x | stopifnot(inherits(m, "condition")) | 
| 126 | ||
| 127 | 10x | type <- class(m)[2] | 
| 128 | 10x | msg <- m$message | 
| 129 | 10x |   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 | 10x | return(paste(msg, collapse = "\n")) | 
| 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 | #' 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 | } | 
| 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 | } |