## From R.utils 2.0.2 (2015-05-23)
hpaste <- function(..., sep = "", collapse = ", ", lastCollapse = NULL, maxHead = if (missing(lastCollapse)) 3 else Inf, maxTail = if (is.finite(maxHead)) 1 else Inf, abbreviate = "...") {
if (is.null(lastCollapse)) lastCollapse <- collapse
# Build vector 'x'
x <- paste(..., sep = sep)
n <- length(x)
# Nothing todo?
if (n == 0) return(x)
if (is.null(collapse)) return(x)
# Abbreviate?
if (n > maxHead + maxTail + 1) {
head <- x[seq_len(maxHead)]
tail <- rev(rev(x)[seq_len(maxTail)])
x <- c(head, abbreviate, tail)
n <- length(x)
}
if (!is.null(collapse) && n > 1) {
if (lastCollapse == collapse) {
x <- paste(x, collapse = collapse)
} else {
xT <- paste(x[1:(n-1)], collapse = collapse)
x <- paste(xT, x[n], sep = lastCollapse)
}
}
x
} # hpaste()
# More efficient than the default utils::capture.output()
#' @importFrom utils capture.output
capture_output <- function(expr, envir = parent.frame(), ...) {
nsinks <- sink.number()
res <- eval({
file <- rawConnection(raw(0L), open = "w")
on.exit(close(file))
capture.output(expr, file = file)
rawToChar(rawConnectionValue(file))
}, envir = envir, enclos = baseenv())
stop_if_not(sink.number() == nsinks)
unlist(strsplit(res, split = "\n", fixed = TRUE), use.names = FALSE)
}
now <- function(x = Sys.time(), format = "[%H:%M:%OS3] ") {
format(as.POSIXlt(x, tz = ""), format = format)
}
mdebug <- function(..., debug = getOption("progressr.debug", FALSE)) {
if (!debug) return()
message(now(), ...)
}
mprintf <- function(..., appendLF = TRUE, debug = getOption("progressr.debug", FALSE)) {
if (!debug) return()
message(now(), sprintf(...), appendLF = appendLF)
}
mdebugf <- mprintf
mprint <- function(..., appendLF = TRUE, debug = getOption("progressr.debug", FALSE)) {
if (!debug) return()
message(paste(now(), capture_output(print(...)), sep = "", collapse = "\n"), appendLF = appendLF)
}
#' @importFrom utils str
mstr <- function(..., appendLF = TRUE, debug = getOption("progressr.debug", FALSE)) {
if (!debug) return()
message(paste(now(), capture_output(str(...)), sep = "", collapse = "\n"), appendLF = appendLF)
}
comma <- function(x, sep = ", ") paste(x, collapse = sep)
commaq <- function(x, sep = ", ") paste(sQuote(x), collapse = sep)
trim <- function(s) sub("[\t\n\f\r ]+$", "", sub("^[\t\n\f\r ]+", "", s))
stop_if_not <- function(..., calls = sys.calls()) {
res <- list(...)
n <- length(res)
if (n == 0L) return()
for (ii in 1L:n) {
res_ii <- .subset2(res, ii)
if (length(res_ii) != 1L || is.na(res_ii) || !res_ii) {
mc <- match.call()
call <- deparse(mc[[ii + 1]], width.cutoff = 60L)
if (length(call) > 1L) call <- paste(call[1L], "...")
msg <- sprintf("%s is not TRUE", sQuote(call))
if (FALSE) {
callstack <- paste(as.character(calls), collapse = " -> ")
msg <- sprintf("%s [call stack: %s]", msg, callstack)
}
stop(msg, call. = FALSE, domain = NA)
}
}
}
## Used for package testing purposes only when we want to perform
## everything except the last part where the backend is called
## This allows us to cover more of the code in package tests
is_fake <- local({
cache <- list()
function(name) {
fake <- cache[[name]]
if (is.null(fake)) {
fake <- name %in% getOption("progressr.tests.fake_handlers")
cache[[name]] <<- fake
}
fake
}
})
known_progression_handlers <- function(exclude = NULL) {
ns <- asNamespace(.packageName)
handlers <- ls(envir = ns, pattern = "^handler_")
handlers <- setdiff(handlers, c("handler_backend_args", "make_progression_handler", "print.progression_handler"))
handlers <- setdiff(handlers, exclude)
handlers <- mget(handlers, envir = ns, inherits = FALSE)
handlers
}
`%||%` <- function(lhs, rhs) {
if (is.null(lhs)) rhs else lhs
}
## From R.utils 2.7.0 (2018-08-26)
query_r_cmd_check <- function(...) {
evidences <- list()
# Command line arguments
args <- commandArgs()
evidences[["vanilla"]] <- is.element("--vanilla", args)
# Check the working directory
pwd <- getwd()
dirname <- basename(pwd)
parent <- basename(dirname(pwd))
pattern <- ".+[.]Rcheck$"
# Is 'R CMD check' checking tests?
evidences[["tests"]] <- (
grepl(pattern, parent) && grepl("^tests(|_.*)$", dirname)
)
# Is the current working directory as expected?
evidences[["pwd"]] <- (evidences[["tests"]] || grepl(pattern, dirname))
# Is 'R CMD check' checking examples?
evidences[["examples"]] <- is.element("CheckExEnv", search())
# SPECIAL: win-builder?
evidences[["win-builder"]] <- (.Platform$OS.type == "windows" && grepl("Rterm[.]exe$", args[1]))
if (evidences[["win-builder"]]) {
n <- length(args)
if (all(c("--no-save", "--no-restore", "--no-site-file", "--no-init-file") %in% args)) {
evidences[["vanilla"]] <- TRUE
}
if (grepl(pattern, parent)) {
evidences[["pwd"]] <- TRUE
}
}
if (!evidences$vanilla || !evidences$pwd) {
res <- "notRunning"
} else if (evidences$tests) {
res <- "checkingTests"
} else if (evidences$examples) {
res <- "checkingExamples"
} else {
res <- "notRunning"
}
attr(res, "evidences") <- evidences
res
}
in_r_cmd_check <- function() { query_r_cmd_check() != "notRunning" }
## Check whether current R process is running as a forked child
is_fork_child <- local({
main_pid <- NULL
function() {
if (is.null(main_pid)) main_pid <<- Sys.getpid()
Sys.getpid() != main_pid
}
})
serialization_size <- function(x) {
size <- length(serialize(x, connection = NULL, xdr = TRUE))
class(size) <- "object_size"
size
}
ansi_pattern <- "(?:(?:\\x{001b}\\[)|\\x{009b})(?:(?:[0-9]{1,3})?(?:(?:;[0-9]{0,3})*)?[A-M|f-m])|\\x{001b}[A-M]"
has_ansi <- function(x) {
grepl(ansi_pattern, x, perl = TRUE, useBytes = TRUE)
}
drop_ansi <- function(x) {
gsub(ansi_pattern, "", x, perl = TRUE, useBytes = TRUE)
}
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.