Feature Request: Build in option to use callr rather than source

[bms63]

Feature Idea

Build in option to use callr rather than source

Relevant Input

No response

Relevant Output

No response

Reproducible Example/Pseudo Code

No response

[kodesiba]

https://callr.r-lib.org/articles/r-session.html

[bms63]

Old logging code

#' safely_n_quietly
#'
#' Code to safely run an r script and collect the output
#' This code is from https://github.com/tidyverse/purrr/issues/426
#' @param .f Function to run
#' @param otherwise Otherwise is equvalent to the otherwise of safely
#' @importFrom purrr quietly safely discard
#' @importFrom stringr str_detect
#' @return Returns list of output from running the code
#' @keywords internal
run_safely_n_quietly <- function(file_name) {
  retfun <- purrr::quietly(purrr::safely(source, quiet = FALSE))
  ret <- retfun(file_name, local = TRUE)
  list(
    result = ret$result$result,
    output = ret$output,
    messages = ret$messages %>%
      purrr::discard(~stringr::str_detect(., "^Error:")), # Remove error messages so there isn't a repeat
    warnings = ret$warnings,
    error = ret$result$error
  )
}


#' log_format
#'
#' Writes the log file
#' @param log_ls list of output from running the code with safely_n_quitely and info=session.info
#' Structure of log_ls: start = code start tim, stop = code stop time, time_diff = time difference
#' @param username string of the username who ran the code
#' @param filename file location and name to be pasted into the log
#' @param inc_messages Boolean to include messages or not
#' @keywords internal
#' @return writes formartted log to the console to be picked up by rscript function
log_format <- function(log_ls, username, filename, inc_messages = TRUE) {
  usr <- ifelse(username == " ", "", paste0("\nCode Run By: ", username, "\n"))
  msg <- ifelse(inc_messages,
                paste0("\nMessages:\n", paste(log_ls$output$messages, collapse = "\n")),
                "")
  fn <- ifelse(filename == " ", "", paste0(
    "\n*** R session history log file: \n   ",
    filename
  ))
  paste0(c(
    "*******************************************************************
*                                                                 *
* GlaxoSmithKline                                                 *
*                                                                 *
* Session history log file                                        *
*                                                                 *
*******************************************************************",
fn, usr,
"\nErrors:\n", capture.output(log_ls$output$error),
"\nWarnings:\n", paste(log_ls$output$warnings, collapse = "\n"),
msg,
"\n\nSession Info:\n", capture.output(log_ls$info),
"\n\n\nRun time logging commenced at: ", as.character(log_ls$start),
"\n   Stop Time: ", as.character(log_ls$stop),
"\n", capture.output(log_ls$time_diff), "\n"
  ))
}



#' Create Log
#'
#' This function creates the job that creates the log. Part of the log checks
#' @param file_path string of the path and file name of the file to log
#' @param log_path string of the path and file name of the log
#' @param user_id string of the user name
#' @param inc_messages Boolean to include messages or not
#' @param backend string either "rstudio", "local", or "callr", which controls how the
#'   script is run. By default with the rstudio api, but if that isn't possible
#'   use the callr package
#'
#' @importFrom rstudioapi jobRunScript isAvailable
#' @importFrom callr r_bg
#'
#' @export
#'
#' @examples 
#' 
#' test_file = system.file("examples", "iris.R", package = "gsklog")
#' log_file <- normalizePath(tempfile(fileext = ".log"), winslash = "/", mustWork = FALSE)
#' create_log(file_path= test_file, log_path= log_file, backend = "callr")
#'            
create_log <- function(file_path, log_path, user_id = " ",
                       inc_messages = TRUE,
                       backend = "rstudio"){
  file_ext <- str_extract(file_path, "(?<=\\.)\\w*$")
  log_ext <- str_extract(log_path, "(?<=\\.)\\w*$")
  if(! file_ext %in% c("r", "R", "rmd", "Rmd")){
    stop("gsklog and only log R files")
  }
  if(! log_ext %in% c("txt", "log")){
    stop("log path needs end in a file that is either a .log or a .txt")
  }
  log_loc <- str_remove(log_path, "([^\\/]+$)")
  if(!dir.exists(log_loc)){
    stop(paste0("Log following path does not exist: ", log_loc))
  }
  # Make temporary file that adds additional checks
  temp_file <- make_temp(file_path, run_user = user_id, log_path, inc_messages)
  if(backend == "rstudio"){
    if(rstudioapi::isAvailable()) {
      # Runs the job with rstudio
      job_id <- rstudioapi::jobRunScript(temp_file, workingDir = getwd())
    } else {
      print("RStudio not avaliable, ran locally")
      out <- purrr::quietly(source)(temp_file)
      message(paste0("Job complete\nLog avaliable: ", log_path))
    }
  } else if (backend == "callr"){
    child <- r_bg(function(x) source(x), 
                  args = list(temp_file), 
                  stderr = log_path)
    message("Job submitted\n   Save as object to check the status of longer running scripts")
    return(child) 
  } else if(backend == "local"){
    out <- purrr::quietly(source)(temp_file)
    message(paste0("Job complete\nLog avaliable: ", log_path))
  } else {
    stop("Please specify backend as either 'rstudio', 'local', or 'callr'")
  }
}



#' multi_log
#'
#' Warpper to allow for running multiple files at once
#' @param files List of full file paths for the files to run
#' @param log_locs List of file paths for the log files to go to, either equal to the files or equal to 1
#' @param user_id string of the user name
#' @param inc_messages Boolean to include messages or not
#' @param backend string either "rstudio", "local", or "callr", which controls how the
#'   script is run. By default with the rstudio api, but if that isn't possible
#'   use the callr package
#' @importFrom purrr map map2 discard
#' @importFrom magrittr %>%
#' @importFrom stringr str_remove str_detect
#' @return log files in the specified location
#' @export
#'
#' @examples 
#' 
#' test_file1 = system.file("examples", "iris.R", package = "gsklog")
#' test_file2 = system.file("examples", "iris2.R", package = "gsklog")
#' log_loc <- file.path(tempdir(), "logs"); dir.create(log_loc, showWarnings = FALSE)
#' multi_log(files = c(test_file1, test_file2), 
#'           log_locs = log_loc, 
#'           user_id ="ab123456", 
#'           backend = "callr")
multi_log <- function(files, log_locs, user_id = " ",
                      inc_messages = TRUE,
                      backend = "rstudio"){
  if(! length(log_locs) %in% c(length(files), 1)){
    stop("length of log location must equal the number of files or 1")
  }
  if (length(files) > 1 & length(log_locs) == length(files) & !all(
    stringr::str_detect(log_locs, ".log|.txt"))){
    stop("Log files must have a file name and file type (either .log or .txt)")
  }
  # creating a list of logs if there is only one
  if(length(log_locs) == 1){
    log_locs = purrr::map(files, ~paste0(unlist(log_locs),
                                         stringr::str_remove(basename(.x), "\\.\\w*"),
                                         ".log"))
  }
  # Running all the test files
  out <- purrr::map2(files, log_locs, ~create_log(.x, .y, user_id,
                                                  inc_messages, backend))
  print(paste(length(files), "files run"))
  if(backend == "callr"){
    out
  }
}

[kodesiba]

check .Renviron and .Rprofile objects are included