### =========================================================================
### Utilities
### -------------------------------------------------------------------------
csv <-function(x) {
paste(x, collapse = ",")
}
pluck <- function(x, name, default=NULL) {
ans <- lapply(x, `[[`, name)
if (!is.null(default)) {
ans[vapply(ans, is.null, logical(1))] <- list(default)
}
ans
}
vpluck <- function(x, name, value, required=TRUE) {
if (required) {
vapply(x, `[[`, value, name)
} else {
if (length(x) > 0L) {
ans <- simplify2array(pluck(x, name, value), higher=FALSE)
} else {
ans <- list()
}
mode(ans) <- mode(value)
ans
}
}
isNA <- function(x) {
is.vector(x) && length(x) == 1L && is.na(x)
}
## uses c() to combine high-level classes like Date
simplify2array2 <- function(x) {
x[vapply(x, is.null, logical(1L))] <- NA # somewhat debatable
uniq.lengths <- unique(lengths(x))
if (length(uniq.lengths) != 1L) {
x
} else if (uniq.lengths == 1L) {
do.call(c, x)
} else {
simplify2array(x, higher=FALSE)
}
}
grouping <- function(x) {
rep(seq_along(x), lengths(x))
}
truncateTable <- function(x, nlevels) {
names(x) <- do.call(paste, c(expand.grid(dimnames(x)), sep=","))
if (length(x) > nlevels) {
x <- c(head(sort(x, decreasing=TRUE), nlevels-1L),
"<other>"=sum(tail(x, -(nlevels-1L))))
}
x
}
formatTable <- function(x, nlevels) {
trunc.tab <- truncateTable(x, nlevels)
c(paste0(names(trunc.tab), rep(": ", length(trunc.tab)), trunc.tab),
rep("", nlevels-length(trunc.tab)))
}
dfToTable <- function(x) {
factors <- x[-length(x)]
levels <- lapply(factors, levels)
tab <- as.table(array(0L, unname(lengths(levels))))
dimnames(tab) <- levels
tab[as.matrix(factors)] <- as.integer(x$count)
tab
}
validHomogeneousList <- function(x, type) {
if (!all(vapply(x, is, type, FUN.VALUE=logical(1L))))
paste("all elements of", class(x), "must be", type, "objects")
}
validHomogeneousTree <- function(x, type) {
if (!all(vapply(x, function(xi) {
if (is.list(xi))
unlist(validHomogeneousTree(xi, type))
else is(xi, type)
}, FUN.VALUE=logical(1L))))
paste("all leaf elements of", class(x), "must be", type, "objects")
}
top_prenv <- get("top_prenv", getNamespace("S4Vectors"))
top_prenv_dots <- get("top_prenv_dots", getNamespace("S4Vectors"))
slotsAsList <- function(x) {
sapply(slotNames(x), slot, object=x, simplify=FALSE)
}
signatureClasses <- function(fun, pos) {
matrix(unlist(findMethods(fun)@signatures), length(fun@signature))[pos,]
}
slotLengths <- function(x) {
vapply(slotNames(x), function(s) length(slot(x, s)), integer(1))
}
slotHasNAs <- function(x) {
vapply(slotNames(x), function(s) any(is.na(slot(x, s))), logical(1))
}
normColIndex <- function(x, f) {
if (is.character(f))
f <- colnames(x) %in% f
else if (is.numeric(f)) {
tmp <- logical(ncol(x))
tmp[f] <- TRUE
f <- tmp
} else if (!is.logical(f)) {
stop("'", deparse(substitute(f)),
"' must be character, numeric or logical")
}
f
}
stripI <- function(x) {
if (is.list(x))
return(lapply(x, stripI))
if (is.call(x) && x[[1L]] == quote(I))
x[[2L]]
else x
}
setMethods <- function (f, signatures = list(), definition,
where = topenv(parent.frame()), ...)
{
for (signature in signatures)
setMethod(f, signature = signature, definition, where = where, ...)
}
VariadicToBinary <- function(variadic, binary)
{
args <- formals(variadic)
args[["..."]] <- NULL
forwardArgs <- setNames(lapply(names(args), as.name), names(args))
reduceBody <- as.call(c(list(binary, quote(..x), quote(..y)),
forwardArgs))
reduceFun <- substitute(function(..x, ..y) BODY, list(BODY=reduceBody))
body(variadic) <- substitute(Reduce(FUN2, list(...)), list(FUN2=reduceFun))
variadic
}
## bquote() loops over anything, even non-language objects, which breaks things
substituteCalls <- function (expr, name, FUN) {
if (is.call(expr)) {
if (expr[[1L]] == as.name(name))
FUN(expr)
else as.call(lapply(expr, substituteCalls, name, FUN))
} else expr
}
bquote2 <- function (expr, where = parent.frame()) {
substituteCalls(expr, ".", function(e) eval(e[[2L]], where))
}
callsToNames <- function(expr, name, where = parent.frame()) {
substituteCalls(expr, name, function(e) as.name(eval(e[[2L]], where)))
}
list2LazyEnv <- function(x, enclos) {
env <- new.env(parent=enclos)
for (nm in names(x)) {
makeActiveBinding(nm, function(v) {
if (missing(v)) {
v <- x[[nm]]
rm(names=nm, env)
}
assign(nm, v, env)
v
})
}
}
varsEnv <- function(expr, frame, parent) {
vars <- all.vars(expr)
objs <- lapply(vars, function(i) frame[[i]]) # could support mget()...
list2env(setNames(objs, vars), parent=parent)
}
funsEnv <- function(expr, frame, parent=.BaseNamespaceEnv) {
### FIXME: we really want an "all.funs()"
nms <- all.names(expr, unique=TRUE)
objs <- mget(nms, frame, mode="function", ifnotfound=list(NULL),
inherits=TRUE)
list2env(Filter(Negate(is.null), objs), parent=parent)
}
startsWith <- function(x, prefix) {
substring(x, 1L, nchar(prefix)) == prefix
}
parseFormulaRHS <- function(x) {
if (length(x) != 2L) {
stop("formula must not have an LHS")
}
as.list(attr(terms(x), "variables")[-1L])
}
rreplace <- function(object, f, classes = "ANY", ...)
{
f <- match.fun(f)
if (!is.character(classes) || any(is.na(classes))) {
stop("'classes' should be character without NAs")
}
.rreplace <- function(obj) {
if (is.recursive(obj)) {
obj[] <- lapply(obj, .rreplace)
}
if (any(vapply(classes, is, object=obj, FUN.VALUE=logical(1L)))) {
f(obj, ...)
} else {
obj
}
}
.rreplace(object)
}
globMatchMatrix <- function(patterns, x) {
ans <- vapply(glob2rx(patterns), grepl, x, FUN.VALUE=logical(length(x)))
if (is.vector(ans)) {
ans <- t(ans)
}
ans
}
### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
### Pretty printing stolen^B^B adapted from S4Vectors
###
### showHeadLines and showTailLines robust to NA, Inf and non-integer
.get_showLines <- function(default, option)
{
opt <- getOption(option, default=default)
if (!is.infinite(opt))
opt <- as.integer(opt)
if (is.na(opt))
opt <- default
opt
}
get_showHeadLines <- function()
{
.get_showLines(5L, "showHeadLines")
}
get_showTailLines <- function()
{
.get_showLines(5L, "showTailLines")
}
prettyRownames <- function(x, len=NULL, nhead=NULL, ntail=NULL)
{
names <- ROWNAMES(x)
if (is.null(nhead) && is.null(ntail)) {
## all lines
if (len == 0L)
character(0)
else if (is.null(names))
paste0("[", seq_len(len), "]")
else
names
} else {
## head and tail
if (!is.null(names)) {
c(head(names, nhead), "...", tail(names, ntail))
} else {
if (nhead == 0L)
s1 <- character(0)
else s1 <- paste0("[", seq_len(nhead), "]")
if (ntail == 0L)
s2 <- character(0)
else s2 <- paste0("[", (len - ntail) + seq_len(ntail), "]")
c(s1, "...", s2)
}
}
}
makeNakedMat_default <- function(x) {
m <- as.matrix(data.frame(x))
mode(m) <- "character"
m
}
### 'makeNakedMat.FUN' must be a function returning a character matrix.
makePrettyMatrixForCompactPrinting <-
function(x, makeNakedMat.FUN=makeNakedMat_default)
{
lx <- NROW(x)
nhead <- get_showHeadLines()
ntail <- get_showTailLines()
if (lx < (nhead + ntail + 1L)) {
ans <- makeNakedMat.FUN(x)
ans_rownames <- prettyRownames(x, lx)
} else {
ans_top <- makeNakedMat.FUN(head(x, nhead))
ans_bottom <- makeNakedMat.FUN(tail(x, ntail))
ans <- rbind(ans_top,
matrix(rep.int("...", ncol(ans_top)), nrow=1L),
ans_bottom)
ans_rownames <- prettyRownames(x, lx, nhead, ntail)
}
rownames(ans) <- format(ans_rownames, justify="right")
ans
}
.qualifyByName <- get(".qualifyByName", getNamespace("S4Vectors"))
labeledLine <- get("labeledLine", getNamespace("S4Vectors"))
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.