#' base R safe rbind
#'
#' Send in a list of data.fames with different column names
#'
#' @return one data.frame
#' a safe rbind for variable length columns
#' @noRd
my_reduce_rbind <- function(x){
classes <- lapply(x, inherits, what = "data.frame")
stopifnot(all(unlist(classes)))
# all possible names
df_names <- Reduce(union, lapply(x, names))
df_same_names <- lapply(x, function(y){
missing_names <- setdiff(df_names,names(y))
num_col <- length(missing_names)
if(num_col > 0){
missing_cols <- vapply(missing_names, function(i) NA, NA, USE.NAMES = TRUE)
new_df <- data.frame(matrix(missing_cols, ncol = num_col))
names(new_df) <- names(missing_cols)
y <- cbind(y, new_df, row.names = NULL)
}
y[, df_names]
})
Reduce(rbind, df_same_names)
}
#' if argument is NULL, no line output
#'
#' @keywords internal
#' @noRd
cat0 <- function(prefix = "", x){
if(!is.null(x)){
cat(prefix, x, "\n")
}
}
#' Javascript time to R time
#'
#' @keywords internal
#' @noRd
js_to_posix <- function(x){
as.POSIXct(as.numeric(x) / 1000, origin = "1970-01-01")
}
#' taken from utils:::format.object_size
#'
#' @keywords internal
#' @noRd
format_object_size <- function (x, units = "b", ...){
if(is.na(x)){
return("File had no filesize")
}
units <- match.arg(units, c("b", "auto", "Kb", "Mb", "Gb",
"Tb", "Pb", "B", "KB", "MB", "GB", "TB", "PB", "KiB",
"MiB", "GiB", "TiB", "PiB", "EiB", "ZiB", "YiB"))
if (units == "auto")
units <- if (x >= 1024^4)
"Tb"
else if (x >= 1024^3)
"Gb"
else if (x >= 1024^2)
"Mb"
else if (x >= 1024)
"Kb"
else "b"
switch(units,
b = , B = paste(x, "bytes"),
Kb = , KB = paste(round(x/1024,1L), "Kb"),
Mb = , MB = paste(round(x/1024^2, 1L), "Mb"),
Gb = , GB = paste(round(x/1024^3, 1L), "Gb"),
Tb = , TB = paste(round(x/1024^4, 1L), "Tb"),
Pb = , PB = paste(round(x/1024^5, 1L), "Pb"),
KiB = paste(round(x/1024, 1L), "KiB"),
MiB = paste(round(x/1024^2, 1L), "MiB"),
GiB = paste(round(x/1024^3, 1L), "GiB"),
TiB = paste(round(x/1024^4, 1L), "TiB"),
PiB = paste(round(x/1024^5, 1L), "PiB"),
EiB = paste(round(x/1024^6,1L), "EiB"),
ZiB = paste(round(x/1024^7, 1L), "ZiB"),
YiB = paste(round(x/1024^8, 1L), "YiB"))
}
#' Timestamp to R date
#' @keywords internal
#' @noRd
timestamp_to_r <- function(t){
as.POSIXct(t, format = "%Y-%m-%dT%H:%M:%S")
}
#' A helper function that tests whether an object is either NULL _or_
#' a list of NULLs
#'
#' @keywords internal
#' @noRd
is.NullOb <- function(x) is.null(x) | all(sapply(x, is.null))
#' Recursively step down into list, removing all such objects
#'
#' @keywords internal
#' @noRd
rmNullObs <- function(x) {
x <- Filter(Negate(is.NullOb), x)
lapply(x, function(x) if (is.list(x)) rmNullObs(x) else x)
}
#' Is this a try error?
#'
#' Utility to test errors
#'
#' @param test_me an object created with try()
#'
#' @return Boolean
#'
#' @keywords internal
#' @noRd
is.error <- function(test_me){
inherits(test_me, "try-error")
}
#' Get the error message
#'
#' @param test_me an object that has failed is.error
#'
#' @return The error message
#'
#' @keywords internal
#' @noRd
error.message <- function(test_me){
if(is.error(test_me)) attr(test_me, "condition")$message
}
#' Customer message log level
#'
#' @param ... The message(s)
#' @param level The severity
#'
#' @details 0 = everything, 1 = debug, 2=normal, 3=important
#' @keywords internal
#' @noRd
#' @importFrom cli cli_h1 cli_div cli_alert_info cli_end
myMessage <- function(..., level = 2){
compare_level <- getOption("googleAuthR.verbose")
if(level >= compare_level){
time <- paste(Sys.time(),">")
mm <- paste(...)
if(grepl("^#", mm)){
cli::cli_h1(mm)
} else {
cli::cli_div(theme = list(span.time = list(color = "grey")))
cli::cli_alert_info("{.time {time}} {mm}")
cli::cli_end()
}
}
}
#' Substitute in a (nested) list
#'
#' @param template A template named list
#' @param replace_me A similar named list with different values to substitute
#'
#' @return The template with the values substituted.
#' @keywords internal
#' If replace_me has list names not in template, the value stays the same.
#' @noRd
substitute.list <- function(template, replace_me){
## remove possible NULL entries
template <- rmNullObs(template)
replace_me <- rmNullObs(replace_me)
postwalk(template, function(x) replace.kv(x,replace_me))
}
#' Walk into a list
#'
#' If passed an object such as a nested list, will apply function
#' on inner elements that are not lists.
#'
#' @param x what to check
#' @param func Function to apply if not a list
#' @keywords internal
#' @return the function acting on x or an inner element of x
#' @noRd
postwalk <- function(x,func){
if(is.list(x)){
func(lapply(x,postwalk,func))
} else {
func(x)
}
}
#' Create a modified list
#'
#' @param template a (nested) list with elements to replace
#' @param replace a subset of template with same names but replacement values
#' @keywords internal
#' @return a list like template but with values replace from replace
#' @noRd
replace.kv <- function(template,replace) {
if(!is.list(template)) return(template)
i <- match(names(template),names(replace))
w <- which(!is.na(i))
replace(template,w,replace[i[w]])
}
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.