Nothing
# Utilities ---------------------------------------------------------------
#' @noRd
update_status <- function() {
if (!is.null(options("logr.on")[[1]])) {
if(options("logr.on")[[1]] == FALSE)
e$log_status <- "off"
else if (options("logr.on")[[1]] == TRUE & e$log_status == "off")
e$log_status <- "on"
}
if (!is.null(options("logr.autolog")[[1]])) {
if(options("logr.autolog")[[1]] == FALSE)
e$autolog <- FALSE
else if (options("logr.autolog")[[1]] == TRUE)
e$autolog <- TRUE
}
if (!is.null(options("logr.notes")[[1]])) {
if(options("logr.notes")[[1]] == FALSE)
e$log_show_notes <- FALSE
else if (options("logr.notes")[[1]] == TRUE)
e$log_show_notes <- TRUE
}
if (!is.null(options("logr.compact")[[1]])) {
if(options("logr.compact")[[1]] == FALSE)
e$log_blank_after <- TRUE
else if (options("logr.compact")[[1]] == TRUE)
e$log_blank_after <- FALSE
}
}
#' Function to print the log header
#' @import common
#' @noRd
print_log_header <- function(log_path) {
log_quiet(paste(e$separator), blank_after = FALSE)
log_quiet(paste("Log Path:", log_path), blank_after = FALSE)
ppth <- NULL
tryCatch({
ppth <- common::Sys.path()
}, error = function(e) { ppth <- NULL})
if (!is.null(ppth)) {
if (file.exists(ppth))
log_quiet(paste("Program Path:", ppth), blank_after = FALSE)
}
log_quiet(paste("Working Directory:", getwd()), blank_after = FALSE)
inf <- Sys.info()
log_quiet(paste("User Name:", inf["user"]), blank_after = FALSE)
vr <- sub("R version ", "", R.Version()["version.string"])
log_quiet(paste("R Version:", vr), blank_after = FALSE)
log_quiet(paste("Machine:", inf["nodename"], inf["machine"]),
blank_after = FALSE)
log_quiet(paste("Operating System:", inf["sysname"], inf["release"],
inf["version"]),
blank_after = FALSE)
log_quiet(get_base_package_versions(), blank_after = FALSE)
log_quiet(get_other_package_versions(), blank_after = FALSE)
log_quiet(paste("Log Start Time:", Sys.time()), blank_after = FALSE)
log_quiet(paste(e$separator), blank_after = e$log_blank_after)
}
#' Function to print the log footer
#' @noRd
print_log_footer <- function(has_warnings = FALSE) {
tc <- Sys.time()
if (!is.null(e$log_show_notes)) {
if (e$log_show_notes == "TRUE" & has_warnings) {
# Force notes after warning print, before the footer
log_quiet(paste("NOTE: Log Print Time:", Sys.time()), blank_after = FALSE)
log_quiet(paste("NOTE: Log Elapsed Time:", get_time_diff(tc)),
blank_after = e$log_blank_after)
}
}
# Calculate total elapsed execution time
ts <- e$log_start_time
#tn <- as.POSIXct(as.double(ts), origin = "1970-01-01")
lt <- difftime(tc, ts, units = "secs")
# Print the log footer
log_quiet(paste(e$separator), blank_after = FALSE)
log_quiet(paste("Log End Time:", tc), blank_after = FALSE)
log_quiet(paste("Log Elapsed Time:", dhms(as.numeric(lt))), blank_after = FALSE)
log_quiet(paste(e$separator), blank_after = FALSE)
}
#' Get time difference between last log_print call and current call
#' @noRd
get_time_diff <- function(x) {
# Pull timestamp out of environment variable
ts <- e$log_time
# Convert string to time
#tn <- as.POSIXct(as.double(ts), origin = "1970-01-01")
# Get difference
ret <- x - ts
# Set new timestamp
e$log_time = x
return(ret)
}
#' Little function to format time in seconds into
#' days, hours, minutes, and seconds. Stolen from StackOverflow.
#' Did not want to create a dependency on external package to do it.
#' @noRd
dhms <- function(t){
paste(t %/% (60*60*24)
,paste(formatC(t %/% (60*60) %% 24, width = 2, format = "d", flag = "0")
,formatC(t %/% 60 %% 60, width = 2, format = "d", flag = "0")
,formatC(t %% 60, width = 2, format = "d", flag = "0")
,sep = ":"
)
)
}
#' @description Should not be this complicated. Unfortunately, tidylog
#' decided to use a Unicode ellipsis character in their log entries.
#' This character causes gsub to crash. grep just gives a warning.
#' So we suppressWarnings, find the lines with strings to replace,
#' then loop through each and tryCatch to suppress the error. Horrible pain.
#'
#' This whole thing is necessary because crayon codes are still being printed
#' to the log. So the purpose of the function is to remove the crayon
#' color codes. Generally, should not have to do this.
#' @noRd
clear_codes <- function(path = NULL) {
if (is.null(path))
pth <- e$log_path
else
pth <- path
if (file.exists(pth)) {
lns <- readLines(pth, encoding = "UTF-8")
f <- file(pth, open = "w", encoding = "native.enc")
#f <- file(pth, open = "w", encoding = "UTF-8")
# lns <- gsub("[90m", "", lns, fixed = TRUE)
res90 <- suppressWarnings(grep("\033[90m", lns, fixed = TRUE))
res39 <- suppressWarnings(grep("\033[39m", lns, fixed = TRUE))
#lns <- gsub("\033[39m", "", lns, fixed = TRUE, useBytes = TRUE)
if (length(res90) > 0 | length(res39) > 0) {
# print(res90)
# print(res39)
if (length(res90) > 0) {
for (ln in res90) {
tryCatch({
lns[ln] <- gsub("\033[90m", "", lns[ln], fixed = TRUE)
})
}
}
if (length(res39) > 0) {
for (ln in res39) {
tryCatch({
lns[ln] <- gsub("\033[39m", "", lns[ln], fixed = TRUE)
})
}
}
}
# Print the string
writeLines(lns, con = f, useBytes = TRUE)
# Close file
close(f)
}
}
#' @import utils
#' @noRd
get_base_package_versions <- function() {
si <- sessionInfo()
bp <- si$basePkgs
bpstr <- ""
cntr <- 0
for (nm in bp) {
cntr <- cntr + 1
if (cntr > 6) {
cntr <- 0
if (nm != bp[[length(bp)]]) {
bpstr <- paste0(bpstr, nm, "\n", " ")
} else {
bpstr <- paste0(bpstr, nm)
}
} else {
bpstr <- paste0(bpstr, nm, " ")
}
}
ret <- paste0("Base Packages: ", bpstr, "\n")
return(ret)
}
#' @import utils
#' @noRd
get_other_package_versions <- function() {
si <- sessionInfo()
oth <- si$otherPkgs
othstr <- ""
cntr <- 0
ret <- c()
for (nm in names(oth)) {
cntr <- cntr + 1
if (cntr > 4) {
cntr <- 0
if (nm != names(oth)[[length(oth)]]) {
othstr <- paste0(othstr, nm, "_", oth[[nm]]$Version, "\n",
" ")
} else {
othstr <- paste0(othstr, nm, "_", oth[[nm]]$Version)
}
} else {
othstr <- paste0(othstr, nm, "_", oth[[nm]]$Version, " ")
}
}
if (othstr != "") {
ret <- paste0("Other Packages: ", othstr)
}
return(ret)
}
read_suspended_log <- function(file_name) {
lns <- readLines(file_name, encoding = "UTF-8")
ret <- list()
hlen <- 17
if (length(lns) > hlen) {
slns <- lns[seq(length(lns) - hlen, length(lns))]
spos <- grep("Log suspended", slns, fixed = TRUE)
ret[["StartPos"]] <- length(lns) - hlen + spos - 3
seqparms <- seq(spos + 3, length(slns))
parmlns <- strsplit(slns[seqparms], ":", fixed = TRUE)
for (i in seq_len(length(parmlns))) {
ln <- parmlns[[i]]
nm <- ln[1]
if (!is.na(nm)) {
if (nm != "" && length(ln) > 1) {
tval <- ln[seq(2, length(ln))]
ret[[nm]] <- trimws(paste0(tval, collapse = ":"))
}
}
}
}
return(ret)
}
print_resume_header <- function(file_name, startpos, suspendtime) {
lns <- readLines(file_name, encoding = "UTF-8")
mlns <- lns[seq(1, startpos)]
st <- Sys.time()
stm <- difftime(st, as.POSIXct(suspendtime), units = "secs")
mlns[length(mlns) + 1] <- e$separator
mlns[length(mlns) + 1] <- "Log Suspended: " %p% suspendtime
mlns[length(mlns) + 1] <- "Log Resumed: " %p% st
mlns[length(mlns) + 1] <- "Elapsed Time: " %p% dhms(as.numeric(stm))
mlns[length(mlns) + 1] <- e$separator
blnk <- TRUE
if (!is.null(e$log_blank_after)) {
blnk <- e$log_blank_after
}
if (blnk) {
mlns[length(mlns) + 1] <- ""
}
file.remove(file_name)
f <- file(file_name, open = "a", encoding = "native.enc")
# Print the string
writeLines(enc2utf8(mlns), con = f, useBytes = TRUE)
close(f)
return(file_name)
}
disconnect_handlers <- function() {
# Detach error handler
options(error = NULL, warning.expression = NULL)
if (!is.null(e$autolog)) {
if (e$autolog) {
options("tidylog.display" = NULL)
# Detach tidylog if not attached by user
if (!is.null(e$tidylog_loaded)) {
if (e$tidylog_loaded == FALSE) {
do.call("detach", list(name = "package:tidylog", unload = TRUE))
}
}
}
}
}
path_valid <- function(pth) {
ret <- TRUE
if (!file.exists(pth)) {
nret <- tryCatch({
f <- file(pth, open = "a", encoding = "UTF-8")
close(f)
if (file.exists(pth))
file.remove(pth)
pth
}, warning = function(cond) {
NULL
}, error = function(cond) {
NULL
})
} else {
nret <- tryCatch({
normalizePath(pth, mustWork = TRUE)
}, warning = function() {
NULL
}, error = function(cond) {
NULL
})
}
if (is.null(nret))
ret <- FALSE
return(ret)
}
Any scripts or data that you put into this service are public.
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.