Nothing
`%>%` <- function(...) {
dots <- eval(substitute(alist(...)))
if (length(dots) != 2L)
stopf("`%>%` called with invalid number of arguments")
lhs <- dots[[1L]]; rhs <- dots[[2L]]
if (!is.call(rhs))
stopf("right-hand side of rhs is not a call")
data <- c(rhs[[1L]], lhs, as.list(rhs[-1L]))
call <- as.call(data)
nm <- names(rhs)
if (length(nm))
names(call) <- c("", "", nm[-1L])
eval(call, envir = parent.frame())
}
`%NA%` <- function(x, y) {
if (length(x) && is.na(x)) y else x
}
`%&&%` <- function(x, y) {
if (length(x)) y
}
lines <- function(...) {
paste(..., sep = "\n")
}
is_named <- function(x) {
nm <- names(x)
!is.null(nm) && all(nzchar(nm))
}
named <- function(object, names = object) {
names(object) <- names
object
}
empty <- function(x) {
length(x) == 0L
}
zlength <- function(x) {
length(x) != 0L
}
trim <- function(x) {
gsub("^\\s+|\\s+$", "", x, perl = TRUE)
}
trimws <- function(x) {
gsub("^\\s+|\\s+$", "", x, perl = TRUE)
}
case <- function(...) {
dots <- eval(substitute(alist(...)))
for (i in seq_along(dots)) {
if (identical(dots[[i]], quote(expr = )))
next
dot <- eval(dots[[i]], envir = parent.frame())
if (!inherits(dot, "formula"))
return(dot)
# Silence R CMD check note
expr <- NULL
cond <- NULL
# use delayed assignments below so we can allow return statements to
# be handled in the lexical scope where they were defined
if (length(dot) == 2L) {
do.call(delayedAssign, list("expr", dot[[2L]], eval.env = environment(dot)))
return(expr)
}
do.call(delayedAssign, list("cond", dot[[2L]], eval.env = environment(dot)))
do.call(delayedAssign, list("expr", dot[[3L]], eval.env = environment(dot)))
if (cond) return(expr)
}
}
compose <- function(wrapper, callback) {
function(...) wrapper(callback(...))
}
catch <- function(expr) {
tryCatch(
withCallingHandlers(expr, error = renv_error_capture),
error = renv_error_tag
)
}
catchall <- function(expr) {
tryCatch(
withCallingHandlers(expr, condition = renv_error_capture),
condition = renv_error_tag
)
}
# nocov start
ask <- function(question, default = FALSE) {
if (renv_tests_running())
return(TRUE)
enabled <- getOption("renv.prompt.enabled", default = TRUE)
if (!enabled)
return(default)
if (!interactive())
return(default)
# be verbose in this scope, as we're asking the user for input
renv_scope_options(renv.verbose = TRUE)
repeat {
# solicit user's answer
selection <- if (default) "[Y/n]" else "[y/N]"
prompt <- sprintf("%s %s: ", question, selection)
response <- tryCatch(
tolower(trimws(readline(prompt))),
interrupt = identity
)
# check for interrupts; treat as abort request
cancel_if(inherits(response, "interrupt"))
# use default when no response
if (!nzchar(response))
return(default)
# check for 'yes' responses
if (response %in% c("y", "yes")) {
writef("")
return(TRUE)
}
# check for 'no' responses
if (response %in% c("n", "no")) {
writef("")
return(FALSE)
}
# ask the user again
writef("- Unrecognized response: please enter 'y' or 'n', or type Ctrl + C to cancel.")
}
}
proceed <- function(default = TRUE) {
ask("Do you want to proceed?", default = default)
}
menu <- function(choices, title, default = 1L) {
testing <- getOption("renv.menu.choice", integer())
if (length(testing)) {
selected <- testing[[1]]
options(renv.menu.choice = testing[-1])
} else if (testing()) {
selected <- default
} else {
selected <- NULL
}
if (!is.null(selected)) {
title <- paste(title, collapse = "\n")
body <- paste(sprintf("%i: %s", seq_along(choices), choices), collapse = "\n")
footer <- sprintf("Selection: %s\n", selected)
writef(paste(c(title, body, footer), collapse = "\n\n"))
return(names(choices)[selected])
}
if (!interactive()) {
value <- if (is.numeric(default)) names(choices)[default] else default
return(value)
}
idx <- tryCatch(
utils::menu(choices, paste(title, collapse = "\n"), graphics = FALSE),
interrupt = function(cnd) 0L
)
if (idx == 0L)
return("cancel")
names(choices)[idx]
}
# nocov end
inject <- function(contents,
pattern,
replacement,
anchor = NULL,
fixed = FALSE)
{
# first, check to see if the pattern matches a line
index <- grep(pattern, contents, perl = !fixed, fixed = fixed)
if (length(index)) {
contents[index] <- replacement
return(contents)
}
# otherwise, check for the anchor, and insert after
index <- if (!is.null(anchor))
grep(anchor, contents, perl = !fixed, fixed = fixed)
if (!length(index))
return(c(contents, replacement))
c(
head(contents, n = index),
replacement,
tail(contents, n = -index)
)
}
deparsed <- function(value, width = 60L) {
paste(deparse(value, width.cutoff = width), collapse = "\n")
}
read <- function(file) {
renv_scope_options(warn = -1L)
contents <- readLines(file, warn = FALSE)
paste(contents, collapse = "\n")
}
plural <- function(word, n) {
if (n == 1) word else paste(word, "s", sep = "")
}
nplural <- function(word, n) {
paste(n, plural(word, n))
}
trunc <- function(text, n = 78) {
long <- nchar(text) > n
text[long] <- sprintf("%s <...>", substring(text[long], 1, n - 6))
text
}
endswith <- function(string, suffix) {
substring(string, nchar(string) - nchar(suffix) + 1) == suffix
}
# like tools::file_ext, but includes leading '.', and preserves
# '.tar.gz', '.tar.bz' and so on
fileext <- function(path, default = "") {
indices <- regexpr("[.]((?:tar[.])?[[:alnum:]]+)$", path, perl = TRUE)
ifelse(indices > -1L, substring(path, indices), default)
}
visited <- function(name, envir) {
value <- envir[[name]] %||% FALSE
envir[[name]] <- TRUE
value
}
rowapply <- function(X, FUN, ...) {
lapply(seq_len(NROW(X)), function(I) {
FUN(X[I, , drop = FALSE], ...)
})
}
comspec <- function() {
Sys.getenv("COMSPEC", unset = Sys.which("cmd.exe"))
}
nullfile <- function() {
if (renv_platform_windows()) "NUL" else "/dev/null"
}
quietly <- function(expr, sink = TRUE) {
if (sink) {
sink(file = nullfile())
defer(sink(NULL))
}
withCallingHandlers(
expr,
warning = function(c) invokeRestart("muffleWarning"),
message = function(c) invokeRestart("muffleMessage"),
packageStartupMessage = function(c) invokeRestart("muffleMessage")
)
}
# NOTE: This function can be used in preference to `as.*()` if you'd like
# to preserve attributes on the incoming object 'x'.
convert <- function(x, type) {
storage.mode(x) <- type
x
}
remap <- function(x, map) {
# TODO: use match?
remapped <- x
enumerate(map, function(key, val) {
remapped[remapped == key] <<- val
})
remapped
}
keep <- function(x, keys) {
x[intersect(keys, names(x))]
}
exclude <- function(x, keys) {
x[setdiff(names(x), keys)]
}
invoke <- function(callback, ...) {
callback(...)
}
dequote <- function(strings) {
for (quote in c("'", '"')) {
# find strings matching pattern
pattern <- paste0(quote, "(.*)", quote)
matches <- grep(pattern, strings, perl = TRUE)
if (empty(matches))
next
# remove outer quotes
strings[matches] <- gsub(pattern, "\\1", strings[matches], perl = TRUE)
# un-escape inner quotes
pattern <- paste0("\\", quote)
strings[matches] <- gsub(pattern, quote, strings[matches], fixed = TRUE)
}
strings
}
nth <- function(x, i) {
x[[i]]
}
heredoc <- function(text, leave = 0) {
# remove leading, trailing whitespace
trimmed <- gsub("^\\s*\\n|\\n\\s*$", "", text)
# split into lines
lines <- strsplit(trimmed, "\n", fixed = TRUE)[[1L]]
# compute common indent
indent <- regexpr("[^[:space:]]", lines)
common <- min(setdiff(indent, -1L)) - leave
paste(substring(lines, common), collapse = "\n")
}
find <- function(x, f, ...) {
for (i in seq_along(x))
if (!is.null(value <- f(x[[i]], ...)))
return(value)
}
recursing <- function() {
nf <- sys.nframe()
if (nf < 2L)
return(FALSE)
np <- sys.parent()
fn <- sys.function(np)
for (i in seq_len(np - 1L))
if (identical(fn, sys.function(i)))
return(TRUE)
FALSE
}
csort <- function(x, decreasing = FALSE, ...) {
renv_scope_locale("LC_COLLATE", "C")
sort(x, decreasing, ...)
}
fsub <- function(pattern, replacement, x, ignore.case = FALSE, useBytes = FALSE) {
sub(pattern, replacement, x, ignore.case = ignore.case, useBytes = useBytes, fixed = TRUE)
}
rows <- function(data, indices) {
# convert logical values
if (is.logical(indices)) {
if (length(indices) < nrow(data))
indices <- rep(indices, length.out = nrow(data))
indices <- which(indices, useNames = FALSE)
}
# build output list
output <- vector("list", length(data))
for (i in seq_along(data))
output[[i]] <- .subset2(data, i)[indices]
# copy relevant attributes
attrs <- attributes(data)
attrs[["row.names"]] <- .set_row_names(length(indices))
attributes(output) <- attrs
# return new data.frame
output
}
cols <- function(data, indices) {
# perform subset
output <- .subset(data, indices)
# copy relevant attributes
attrs <- attributes(data)
attrs[["names"]] <- attr(output, "names", exact = TRUE)
attributes(output) <- attrs
# return output
output
}
stringify <- function(object, collapse = " ") {
if (is.symbol(object))
return(as.character(object))
paste(
deparse(object, width.cutoff = 500L),
collapse = collapse
)
}
env <- function(...) {
list2env(list(...), envir = new.env(parent = emptyenv()))
}
env2list <- function(env) {
as.list.environment(env, all.names = TRUE)
}
chop <- function(x, split = "\n", fixed = TRUE, perl = FALSE, useBytes = FALSE) {
strsplit(x, split, !perl, perl, useBytes)[[1L]]
}
prof <- function(expr, ...) {
profile <- tempfile("renv-profile-", fileext = ".Rprof")
Rprof(profile, ...)
result <- expr
Rprof(NULL)
print(summaryRprof(profile))
invisible(result)
}
recycle <- function(data) {
# compute number of columns
n <- lengths(data, use.names = FALSE)
nrow <- max(n)
# start recycling
for (i in seq_along(data)) {
if (n[[i]] == 0L) {
length(data[[i]]) <- nrow
} else if (n[[i]] != nrow) {
data[[i]] <- rep.int(data[[i]], nrow / n[[i]])
}
}
data
}
take <- function(data, index = NULL) {
if (is.null(index)) data else .subset2(data, index)
}
cancel <- function() {
renv_snapshot_auto_suppress_next()
if (testing())
stop("Operation canceled", call. = FALSE)
message("- Operation canceled.")
invokeRestart("abort")
}
cancel_if <- function(cnd) {
if (cnd) cancel()
}
rep_named <- function(names, x) {
values <- rep_len(x, length(names))
names(values) <- names
values
}
wait_until <- function(callback, ...) {
repeat if (callback(...)) return(TRUE)
}
timer <- function(units = "secs") {
.time <- Sys.time()
.units <- units
list(
now = function() {
Sys.time()
},
elapsed = function() {
difftime(Sys.time(), .time, units = .units)
}
)
}
summon <- function() {
envir <- do.call(attach, list(what = NULL, name = "renv"))
renv <- renv_envir_self()
list2env(as.list(renv), envir = envir)
}
assert <- function(...) stopifnot(...)
overlay <- function(lhs, rhs) {
modifyList(as.list(lhs), as.list(rhs))
}
# the 'top' renv function in the call stack
topfun <- function() {
self <- renv_envir_self()
frames <- sys.frames()
for (i in seq_along(frames))
if (identical(self, parent.env(frames[[i]])))
return(sys.function(i))
}
warnify <- function(cnd) {
class(cnd) <- c("warning", "condition")
warning(cnd)
}
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.