diff --git a/.lintr b/.lintr index 93aa917..cb15310 100644 --- a/.lintr +++ b/.lintr @@ -2,7 +2,7 @@ linters: list( absolute_path_linter(), any_duplicated_linter(), any_is_na_linter(), - assignment_linter(allow_cascading_assign = FALSE), + assignment_linter(), backport_linter("4.0.0"), boolean_arithmetic_linter(), brace_linter(allow_single_line = TRUE), @@ -22,7 +22,6 @@ linters: list( expect_null_linter(), expect_true_false_linter(), expect_type_linter(), - extraction_operator_linter(), fixed_regex_linter(), for_loop_index_linter(), function_argument_linter(), @@ -77,7 +76,7 @@ linters: list( # undesirable_function_linter, # To configure unnecessary_concatenation_linter(), unnecessary_lambda_linter(), - unnecessary_nested_if_linter(), + unnecessary_nesting_linter(), unreachable_code_linter(), vector_logic_linter(), whitespace_linter() diff --git a/DESCRIPTION b/DESCRIPTION index e2ef0cd..bda08a6 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -22,7 +22,7 @@ Suggests: utils URL: https://github.com/MEO265/loggit2, https://r-loggit.org/ BugReports: https://github.com/MEO265/loggit2/issues -RoxygenNote: 7.3.1 +RoxygenNote: 7.3.2 Encoding: UTF-8 Roxygen: list(markdown = TRUE) VignetteBuilder: knitr diff --git a/R/configurations.R b/R/configurations.R index 3037033..c5b94ee 100644 --- a/R/configurations.R +++ b/R/configurations.R @@ -185,10 +185,11 @@ get_echo <- function() { #' @export set_call_options <- function(..., .arg_list, confirm = TRUE) { base::stopifnot( - "Only one of `...` or `.arg_list` can be provided." = xor(...length() > 0L, !missing(.arg_list)) + "Only one of `...` or `.arg_list` can be provided." = !(...length() > 0L && !missing(.arg_list)) ) - if (...length() > 0L) return(set_call_options(.arg_list = list(...), confirm = confirm)) + # If no .arg_list is provided, use the ... arguments to call with .arg_list + if (missing(.arg_list)) return(set_call_options(.arg_list = list(...), confirm = confirm)) base::stopifnot( ".arg_list must be a list" = is.list(.arg_list), @@ -197,6 +198,13 @@ set_call_options <- function(..., .arg_list, confirm = TRUE) { length(.arg_list) == 0L || !is.null(names(.arg_list)) && all(names(.arg_list) != "") ) + # Warn if unexpected arguments are provided + if (!all(names(.arg_list) %in% c("log_call", "full_stack"))) { + base::warning( + "Unexpected arguments provided: ", toString(setdiff(names(.arg_list), c("log_call", "full_stack"))) + ) + } + old <- get_call_options() default <- list(log_call = FALSE, full_stack = FALSE) diff --git a/R/utils.R b/R/utils.R index 59a4300..0026976 100644 --- a/R/utils.R +++ b/R/utils.R @@ -162,13 +162,15 @@ convert_lvl_input <- function(level) { #' #' @param call Call object. #' @param full_stack Include the full call stack? +#' @param default_cutoff Number of calls to cut from the end of the call stack if no matching call is found. #' #' @return Deparsed call as string. #' -#' @details The full call stack can only be determined if the call is in the current context. +#' @details The full call stack can only be determined if the call is in the current context. The default cutoff is 4 +#' because the only known case is an primitive error in `with_loggit()` which adds 4 calls to the stack. #' #' @keywords internal -call_2_string <- function(call, full_stack = FALSE) { +call_2_string <- function(call, full_stack = FALSE, default_cutoff = 4L) { if (is.null(call)) return(NA_character_) call_str <- deparse1(call) if (full_stack) { @@ -176,22 +178,28 @@ call_2_string <- function(call, full_stack = FALSE) { raw_call_stack <- sys.calls() call_stack <- vapply(raw_call_stack, deparse1, FUN.VALUE = character(1L)) call_match <- match(call_str, rev(call_stack)) + call_match_pos <- length(call_stack) + if (!is.na(call_match)) call_match_pos <- call_match_pos - call_match + 1L # Shorten to 150 characters call_stack <- vapply(call_stack, substr, FUN.VALUE = character(1L), start = 1L, stop = 150L) call_stack <- gsub("\n", "", call_stack, fixed = TRUE) call_stack <- gsub("\\s+", " ", call_stack) call_stack <- paste0(call_stack, vapply(raw_call_stack, get_file_loc, FUN.VALUE = character(1L))) - base::stopifnot("Call not found in context" = !is.na(call_match)) - call_match <- length(call_stack) - call_match + 1L # Ignore any wrapper environments above the global R environment # For example necessary in JetBrains IDEs - parents <- sys.parents()[seq_len(call_match)] + parents <- sys.parents()[seq_len(call_match_pos)] base_id <- match(0L, parents, nomatch = 0L) - parents <- parents[base_id:call_match] + parents <- parents[base_id:call_match_pos] funcs <- lapply(parents, sys.function) pkgs <- vapply(funcs, get_package_name, FUN.VALUE = character(1L)) pkgs[[1L]] <- "" - call_stack <- paste0(call_stack[base_id:call_match], pkgs) + call_stack <- paste0(call_stack[base_id:call_match_pos], pkgs) + if (is.na(call_match)) { + # Cut the last `default_cutoff` calls from the stack + call_stack <- call_stack[seq_len(max(length(call_stack) - default_cutoff, 0L))] + # And add the call to the end + call_stack <- c(call_stack, paste("Original Call: ", call_str)) + } call_str <- paste(call_stack, collapse = "\n") } return(call_str) @@ -226,8 +234,11 @@ get_file_loc <- function(x) { #' #' @keywords internal get_package_name <- function(x) { - name <- environmentName(environment(x)) + if (is.primitive(x)) { + return(" [in base]") + } + name <- environmentName(environment(x)) if (nchar(name) == 0L || name %in% c("R_EmptyEnv", "R_GlobalEnv")) { return("") } else { diff --git a/man/call_2_string.Rd b/man/call_2_string.Rd index bc5b811..f5046b0 100644 --- a/man/call_2_string.Rd +++ b/man/call_2_string.Rd @@ -4,12 +4,14 @@ \alias{call_2_string} \title{Convert Call to String} \usage{ -call_2_string(call, full_stack = FALSE) +call_2_string(call, full_stack = FALSE, default_cutoff = 4L) } \arguments{ \item{call}{Call object.} \item{full_stack}{Include the full call stack?} + +\item{default_cutoff}{Number of calls to cut from the end of the call stack if no matching call is found.} } \value{ Deparsed call as string. @@ -19,5 +21,6 @@ Converts a call object to a string and optionally determines the full call stack } \details{ The full call stack can only be determined if the call is in the current context. +The default cutoff is 4 because the only known case is an primitive error in \code{with_loggit()} which adds 4 calls to the stack. } \keyword{internal} diff --git a/tests/testthat/test-configurations.R b/tests/testthat/test-configurations.R index 35fdba8..dce9ccd 100644 --- a/tests/testthat/test-configurations.R +++ b/tests/testthat/test-configurations.R @@ -92,3 +92,62 @@ test_that("test log_lvl configuration", { expect_output(suppressWarnings(warning("test", .loggit = FALSE)), regexp = NA) expect_output(try(stop("test", .loggit = FALSE), silent = TRUE), regexp = NA) }) + +test_that("test call option configuration", { + old <- get_call_options() + on.exit(set_call_options(.arg_list = old, confirm = FALSE)) + + # error when both ... and .arg_list provided + expect_error( + set_call_options(a = TRUE, .arg_list = list(a = TRUE)), + "Only one of `...` or `.arg_list` can be provided" + ) + + # error when .arg_list is not a list + expect_error( + set_call_options(.arg_list = "notalist"), + ".arg_list must be a list" + ) + + # error when .arg_list is not named + bad_list <- list(TRUE, named = 1L) + expect_error( + set_call_options(.arg_list = bad_list), + "All arguments must be named" + ) + + # warnig when .arg_list has unexpected arguments + expect_warning( + set_call_options(.arg_list = list(log_call = TRUE, full_stack = TRUE, unexpected = TRUE), confirm = FALSE), + "Unexpected arguments provided: unexpected" + ) + + # no args: returns old, sets defaults, and prints message + set <- set_call_options(confirm = FALSE, log_call = TRUE, full_stack = FALSE) # Init for test + expect_message( + old <- set_call_options(), + "Call options set to log_call = FALSE, full_stack = FALSE." + ) + expect_identical(old, list(log_call = TRUE, full_stack = FALSE)) + + # sets options via ... and returns old + set_call_options(log_call = TRUE, full_stack = TRUE, confirm = FALSE) # Init for test + expect_message( + old <- set_call_options(log_call = FALSE, full_stack = TRUE), + "Call options set to log_call = FALSE, full_stack = TRUE." + ) + expect_identical(old, list(log_call = TRUE, full_stack = TRUE)) + + # set options via .arg_list and returns old + set_call_options(log_call = TRUE, full_stack = FALSE, confirm = FALSE) # Init for test + expect_message( + old <- set_call_options(.arg_list = list(log_call = TRUE, full_stack = TRUE)), + "Call options set to log_call = TRUE, full_stack = TRUE." + ) + expect_identical(old, list(log_call = TRUE, full_stack = FALSE)) + + # call confirm = FALSE, no message, returns old + set_call_options(log_call = FALSE, full_stack = TRUE, confirm = FALSE) # Init for test + expect_silent(old <- set_call_options(.arg_list = list(log_call = FALSE, full_stack = FALSE), confirm = FALSE)) + expect_identical(old, list(log_call = FALSE, full_stack = TRUE)) +}) diff --git a/tests/testthat/test-loggit.R b/tests/testthat/test-loggit.R index b37c76f..6a27474 100644 --- a/tests/testthat/test-loggit.R +++ b/tests/testthat/test-loggit.R @@ -56,3 +56,43 @@ test_that("Log file is returned via read_logs()", { expect_true(is.data.frame(log_df)) }) cleanup() + +test_that("loggit warns on use of reserved fields", { + expect_warning( + loggit(log_lvl = "INFO", log_msg = "foo", timestamp = "2023-01-01", echo = FALSE), + regexp = "^The 'timestamp' and 'log_call' fields are reserved and will be ignored.$" + ) + + expect_warning( + loggit(log_lvl = "INFO", log_msg = "foo", log_call = "some call", echo = FALSE), + regexp = "^The 'timestamp' and 'log_call' fields are reserved and will be ignored.$" + ) + + expect_warning( + loggit(log_lvl = "INFO", log_msg = "foo", timestamp = "2023-01-01", log_call = "some call", echo = FALSE), + regexp = "^The 'timestamp' and 'log_call' fields are reserved and will be ignored.$" + ) +}) +cleanup() + +test_that("loggit handles call options correctly", { + old_options <- get_call_options() + on.exit(set_call_options(.arg_list = old_options, confirm = FALSE), add = TRUE) + set_call_options(log_call = TRUE, full_stack = FALSE, confirm = FALSE) + loggit(log_lvl = "INFO", log_msg = "test call options", echo = FALSE) + log_df <- read_logs() + expect_true("log_call" %in% names(log_df)) + expect_true(is.na((log_df[["log_call"]]))) +}) +cleanup() + +test_that("loggit handles call options correctly (with ...)", { + old_options <- get_call_options() + on.exit(set_call_options(.arg_list = old_options, confirm = FALSE), add = TRUE) + set_call_options(log_call = TRUE, full_stack = FALSE, confirm = FALSE) + loggit(log_lvl = "INFO", log_msg = "test call options with dots", echo = FALSE, custom_field = "value") + log_df <- read_logs() + expect_true("custom_field" %in% names(log_df)) + expect_identical(log_df[["custom_field"]], "value") +}) +cleanup() diff --git a/tests/testthat/test-setup.R b/tests/testthat/test-setup.R index fdd1d25..8d4dc56 100644 --- a/tests/testthat/test-setup.R +++ b/tests/testthat/test-setup.R @@ -93,3 +93,10 @@ test_that("setup_log_level", { expect_identical(get_log_level(), expected = 4L) }) + +test_that("setup_call_options", { + old_call_options <- get_call_options() + on.exit(set_call_options(.arg_list = old_call_options, confirm = FALSE)) + expect_silent(setup_call_options()) + expect_identical(get_call_options(), expected = list(log_call = FALSE, full_stack = FALSE)) +}) diff --git a/tests/testthat/test-utils.R b/tests/testthat/test-utils.R index 77bdffd..8be6f92 100644 --- a/tests/testthat/test-utils.R +++ b/tests/testthat/test-utils.R @@ -146,3 +146,66 @@ test_that("convert_lvl_input", { expect_error(convert_lvl_input(level = "INVALID")) }) + +test_that("call_2_string", { + # Test with empty call + expect_identical(call_2_string(NULL), NA_character_) + expect_identical(call_2_string(NULL, full_stack = TRUE), NA_character_) + + # Test without full stack + test_call <- quote(loggit("INFO", "Test message")) + expect_identical(call_2_string(test_call), "loggit(\"INFO\", \"Test message\")") + test_call_complex <- quote(loggit("INFO", paste0("Test", " message"))) + expect_identical(call_2_string(test_call_complex), "loggit(\"INFO\", paste0(\"Test\", \" message\"))") +}) + +test_that("get_file_loc", { + # Test with a call that has no file location + call_obj <- quote(a + 1L) + expect_identical(get_file_loc(call_obj), "") + + tmp <- tempfile(fileext = ".R") + writeLines(c( + "foo <- function(x) {\n1L + 1L\n}", + "foo2 <- function(x) {2L + 2L}" + ), tmp) + env <- new.env() + source(tmp, local = env, keep.source = TRUE) + expected <- paste0(" [at ", basename(tmp), "#1]") + expect_identical(get_file_loc(env[["foo"]]), expected) + expected <- paste0(" [at ", basename(tmp), "#4]") + expect_identical(get_file_loc(env[["foo2"]]), expected) + + tmp <- tempfile(fileext = ".R") + writeLines("bar <- function(x) {1L + 1L}", tmp) + env <- new.env() + source(tmp, local = env, keep.source = FALSE) + expect_identical(get_file_loc(env[["bar"]]), "") +}) + + +test_that("get_package_name handles various environments", { + # primitive function + expect_identical(get_package_name(sum), " [in base]") + # base function + expect_identical(get_package_name(mean), " [in base]") + # utils if available + if (requireNamespace("utils", quietly = TRUE)) { + expect_identical(get_package_name(utils::write.csv), " [in utils]") + } + # user-defined in global env + myfun <- function() NULL + expect_identical(get_package_name(myfun), "") + # user-defined in anonymous env + e <- new.env(parent = emptyenv()) + dummy <- function() NULL + environment(dummy) <- e + expect_identical(get_package_name(dummy), "") +}) + +test_that("call_2_string (full_stack=TRUE) handels call not in current context", { + ext_call <- quote(some_function(1L, 2L)) + expect_true( + endsWith(call_2_string(ext_call, full_stack = TRUE), "Original Call: some_function(1L, 2L)") + ) +})