Merge pull request #164 from parmsam-pfizer/162_alt_export

Add argument for log_write to export log object as Rds

NEWS.md

@@ -1,3 +1,7 @@
+# logrx 0.3.0
+
+- Add `include_rds` argument to `axecute()` to export log as rds file
+
 # logrx 0.2.2
 
  - Hotfix to remove unnecessary `across()` and update `.data$var` top new syntax to match updates in source packages (#172)

R/axecute.R

@@ -10,6 +10,8 @@
 #' @param log_path String. Path to log file
 #' @param remove_log_object Boolean. Should the log object be removed after
 #' writing the log file? Defaults to TRUE
+#' @param include_rds Boolean. Option to export log object as Rds file.
+#' Defaults to FALSE
 #' @param quit_on_error Boolean. Should the session quit with status 1 on error?
 #' Defaults to TRUE
 #' @param to_report String vector. Objects to optionally report, may include as
@@ -34,6 +36,7 @@
 axecute <- function(file, log_name = NA,
                     log_path = NA,
                     remove_log_object = TRUE,
+                    include_rds = FALSE,
                     quit_on_error = TRUE,
                     to_report = c("messages", "output", "result")){
 
@@ -51,7 +54,10 @@ axecute <- function(file, log_name = NA,
    any_errors <- get_log_element("errors")
 
    # write log
-   log_write(file = file, remove_log_object = remove_log_object, to_report = to_report)
+   log_write(file = file,
+             remove_log_object = remove_log_object,
+             include_rds = include_rds,
+             to_report = to_report)
 
    # if error, quit with status = 1 if not interactive
    if(!interactive() & !is.null(any_errors) & quit_on_error) {

R/get.R

@@ -96,7 +96,7 @@ get_file_path <- function(file = NA, normalize = TRUE){
 #' @noRd
 #'
 get_session_info <- function(){
-   return(capture.output(session_info(info = "all")))
+   return(session_info(info = "all"))
 }
 
 

R/log.R

@@ -150,6 +150,8 @@ log_cleanup <- function() {
 #' to a log file
 #'
 #' @param file String. Path to file executed
+#' @param include_rds Boolean. Option to export log object as Rds file.
+#' Defaults to FALSE
 #' @param remove_log_object Boolean. Should the log object be removed after
 #' writing the log file? Defaults to TRUE
 #' @param to_report String vector. Objects to optionally report; additional
@@ -177,6 +179,7 @@ log_cleanup <- function() {
 #' log_write(file)
 log_write <- function(file = NA,
                       remove_log_object = TRUE,
+                      include_rds = FALSE,
                       to_report = c("messages", "output", "result")){
    # Set end time and run time
    set_log_element("end_time", strftime(Sys.time(), usetz = TRUE))
@@ -285,8 +288,39 @@ log_write <- function(file = NA,
                         write_log_element("log_path", "Log path: "))
 
    writeLines(cleaned_log_vec,
-              con = file.path(get_log_element("log_path"),
-                              get_log_element("log_name")))
+                 con = file.path(get_log_element("log_path"),
+                                 get_log_element("log_name")))
+   if (include_rds){
+      rds_fields <- c(
+         "end_time", "start_time", "run_time", "user", "hash_sum",
+         "log_path", "log_name", "file_path", "file_name",
+         "unapproved_packages_functions", "errors", "warnings",
+         "session_info"
+      )
+      log_options <- as.list(getOption('log.rx'))
+      cleaned_log_list <- purrr::map2(
+         log_options,
+         names(log_options),
+         function(i, x){
+            if(x %in% c("messages", "output", "result")){
+               if(x %in% to_report){
+                  return(i)
+               }
+            } else if(x %in% c(names(log_cleanup()), rds_fields)){
+               return(i)
+            }
+         }
+      )
+      saveRDS(cleaned_log_list,
+              file = file.path(
+                 get_log_element("log_path"),
+                 paste0(tools::file_path_sans_ext(
+                    get_log_element("log_name")
+                    ),".Rds")
+                 )
+              )
+   }
+
    if (remove_log_object) {
       log_remove()
    }

R/writer.R

@@ -50,6 +50,7 @@ write_metadata <- function(){
 #'
 write_session_info <- function(){
    session_info <- get_log_element("session_info") %>%
+      capture.output() %>%
       # remove extra dashes on title lines
       map_chr(~ ifelse(nchar(.x) > 80 & grepl("\u2500\u2500\u2500\u2500", .x),
                    substring(.x, 1, 80),

tests/testthat/test-axecute.R

@@ -66,3 +66,35 @@ test_that("to_report works to control log output elements", {
    rm(flines, con, scriptPath, logDir)
    log_remove()
 })
+
+test_that("include_rds works to output log as rds", {
+   options("log.rx" = NULL)
+   scriptPath <- tempfile()
+   logDir <- tempdir()
+   writeLines(
+      c("message('hello logrx')",
+        "cat('this is output')",
+        "data.frame(c(8, 6, 7, 5, 3, 0, 9))"),
+      con = scriptPath)
+
+   # check no log is currently written out
+   expect_warning(expect_error(file(file.path(logDir, "log_out_nested"), "r"), "cannot open the connection"))
+
+   axecute(scriptPath,
+           log_name = "log_out_nested",
+           log_path = logDir,
+           remove_log_object = FALSE,
+           include_rds = TRUE,
+           to_report = c("messages", "result"))
+   con <- file(file.path(logDir, "log_out_nested.Rds"), "r")
+   logRDS <- readRDS(file.path(logDir, "log_out_nested.Rds"))
+
+   expect_type(logRDS, "list")
+   expect_true("messages" %in% names(logRDS))
+   expect_true(all(is.na(logRDS$output)))
+   expect_true("result" %in% names(logRDS))
+   expect_true("start_time" %in% names(logRDS))
+
+   rm(con, scriptPath, logDir, logRDS)
+   log_remove()
+})

tests/testthat/test-get.R

@@ -22,7 +22,7 @@ test_that("when given a file as an argument a non-normalized file path to that f
 })
 
 test_that("session info is captured", {
-   expect_identical(get_session_info(), capture.output(session_info(info = "all")))
+   expect_identical(capture.output(get_session_info()), capture.output(session_info(info = "all")))
 })
 
 test_that("all functions that are masked are found and returned", {