Nothing
isFALSE <- function(x) {
is.logical(x) && length(x) == 1L && !is.na(x) && !x
}
isNA <- function(x) {
is.logical(x) && length(x) == 1L && is.na(x)
}
stop_if_not <- function(...) {
res <- list(...)
for (ii in 1L:length(res)) {
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], "....")
stopf("%s is not TRUE", sQuote(call), call. = FALSE, domain = NA)
}
}
NULL
}
## 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()
trim <- function(s) sub("[\t\n\f\r ]+$", "", sub("^[\t\n\f\r ]+", "", s))
comma <- function(x, sep = ", ") paste(x, collapse = sep)
commaq <- function(x, sep = ", ") paste(sQuote(x), collapse = sep)
now <- function(x = Sys.time(), format = "[%H:%M:%OS3] ") {
## format(x, format = format) ## slower
format(as.POSIXlt(x, tz = ""), format = format)
}
mdebug <- function(..., debug = NA) {
if (is.na(debug)) debug <- getOption("future.apply.debug", getOption("future.debug", FALSE))
if (!debug) return()
message(now(), ...)
}
mdebugf <- function(..., appendLF = TRUE, debug = NA) {
if (is.na(debug)) debug <- getOption("future.apply.debug", getOption("future.debug", FALSE))
if (!debug) return()
message(now(), sprintf(...), appendLF = appendLF)
}
#' @importFrom utils capture.output
mprint <- function(..., appendLF = TRUE, debug = NA) {
if (is.na(debug)) debug <- getOption("future.apply.debug", getOption("future.debug", FALSE))
if (!debug) return()
message(paste(now(), capture.output(print(...)), sep = "", collapse = "\n"), appendLF = appendLF)
}
#' @importFrom utils capture.output
mstr <- function(..., appendLF = TRUE, debug = NA) {
if (is.na(debug)) debug <- getOption("future.apply.debug", getOption("future.debug", FALSE))
if (!debug) return()
message(paste(now(), capture.output(str(...)), sep = "", collapse = "\n"), appendLF = appendLF)
}
if (getRversion() < "4.0.0") {
## When 'default' is specified, this is 30x faster than
## base::getOption(). The difference is that here we use
## use names(.Options) whereas in 'base' names(options())
## is used.
getOption <- local({
go <- base::getOption
function(x, default = NULL) {
if (missing(default) || match(x, table = names(.Options), nomatch = 0L) > 0L) go(x) else default
}
})
}
#' @importFrom future FutureError
#' @importFrom utils capture.output head str
assert_values2 <- function(nX, values, values2, fcn_name, debug = FALSE) {
if (length(values2) != nX) {
chunk_sizes <- sapply(values, FUN = length)
chunk_sizes <- table(chunk_sizes)
chunk_summary <- sprintf("%d chunks with %s elements",
chunk_sizes, names(chunk_sizes))
chunk_summary <- paste(chunk_summary, collapse = ", ")
msg <- sprintf("Unexpected error in %s(): After gathering and merging the values from %d chunks in to a list, the total number of elements (= %d) does not match the number of input elements in 'X' (= %d). There were in total %d chunks and %d elements (%s)", fcn_name, length(values), length(values2), nX, length(values), sum(chunk_sizes), chunk_summary)
if (debug) {
mdebug(msg)
mprint(chunk_sizes)
mdebug("Results before merge chunks:")
mstr(values)
mdebug("Results after merge chunks:")
mstr(values2)
}
msg <- sprintf("%s. Example of the first few values: %s", msg,
paste(capture.output(str(head(values2, 3L))),
collapse = "\\n"))
ex <- FutureError(msg)
stop(ex)
}
}
stealth_sample.int <- function(n, size = n, replace = FALSE, ...) {
oseed <- .GlobalEnv$.Random.seed
on.exit({
if (is.null(oseed)) {
rm(list = ".Random.seed", envir = .GlobalEnv, inherits = FALSE)
} else {
.GlobalEnv$.Random.seed <- oseed
}
})
sample.int(n = n, size = size, replace = replace, ...)
}
#' @importFrom utils packageVersion
future_version <- local({
ver <- NULL
function() {
if (is.null(ver)) ver <<- packageVersion("future")
ver
}
})
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.