Tests for call log

.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()

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

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)

R/utils.R

@@ -162,36 +162,44 @@
 #'
 #' @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) {
     # Truncate the call stack after the `call`
     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 @@
 #'
 #' @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 {

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))
+})

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()

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))
+})

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)")
+  )
+})