Nothing
# General utility functions
#
# Author: Renaud Gaujoux
# Creation: 25 Apr 2012
###############################################################################
# or-NULL operator (borrowed from Hadley Wickham)
'%||%' <- function(x, y) if( !is.null(x) ) x else y
#' Get Anywhere
#'
#' Similar to \code{\link{getAnywhere}}, but looks for the value of its argument.
#'
#' @param x a single character string
#'
#' @return The value of [getAnywhere].
#'
#' @export
cgetAnywhere <- function(x){
do.call("getAnywhere", list(x))
}
#' Silencing Functions
#'
#' Generates a wrapper function that silences the output, messages, and/or warnings of a given function.
#'
#' @param f function to silence
#' @param level a single numeric (integer) that indicates the silencing level, which encodes the set of
#' output to be silenced.
#'
#' It is interpreted like unix permission bit system, where each bit of the binary expression of the silencing
#' level corresponds to a given type of output:
#' \itemize{
#' \item 0: nothing silenced;
#' \item 1: \emph{stdout};
#' \item 2: \emph{stderr} messages;
#' \item 4: \emph{stderr} warnings.
#' }
#'
#' For example, level \code{3 = 2 + 1} means silencing \emph{stdout} and \emph{stderr}, while
#' \code{5 = 3 + 2} means silencing \emph{stderr} messages and warnings, but not outputs to \emph{stdout}.
#' The default value is \code{7 = 4 + 2 + 1}, which silences all output.
#'
#' Negative values are supported and mean \emph{"silence everything except the corresponding type"},
#' e.g., \code{level = -1} silences all except \emph{stdout} (computed as the binary complementary of 7, i.e. \code{7 - 1 = 5 = 3 + 2}).
#' See examples.
#' @return a function
#' @export
#' @examples
#'
#' f <- function(){
#' cat("stdout message\n")
#' message("stderr message")
#' warning("stderr warning", immediate. = TRUE)
#' }
#'
#' # example of generated wrapper
#' g <- .silenceF(f)
#' g
#'
#' # use of silencing level
#' for(l in 7:-7){ message("\nLevel: ", l); .silenceF(f, l)() }
#'
#' # inline functions
#' ifun <- .silenceF(function(){ f(); invisible(1) })
#' ifun()
#' ifun <- .silenceF(function(){ f(); 1 })
#' ifun()
#' ifun <- .silenceF(function(){ f(); 1 }, 2L)
#' ifun()
#'
.silenceF <- function(f, level = 7L){
# switch inverse level specification
if( level < 0 ) level <- 7L + level
# early exit if not silencing
if( !level ) return(f)
silencer <- c('utils::capture.output(', 'suppressPackageStartupMessages(suppressMessages(', 'suppressWarnings(')
wrapper <- character()
for( i in 1:3 ){
if( bitwAnd(level, 2^(i-1)) ) wrapper <- c(wrapper, silencer[i])
}
wrapper <- paste0(wrapper, collapse = "")
npar <- length(gregexpr("(", wrapper, fixed = TRUE)[[1]])
# build source code of wrapper function
f_str <- paste0(as.character(substitute(f)), collapse = "")
ca <- match.call()
use_env <- languageEl(ca$f, 1) == as.symbol('function')
if( use_env ) f_str <- 'f'
txt <- sprintf("function(...){ %s res <- withVisible(%s(...))%s; if( res$visible ) res$value else invisible(res$value) }", wrapper, f_str, paste0(rep(")", npar), collapse = ""))
e <- parent.frame()
if( use_env ){
e <- new.env(parent = e)
e$f <- f
}
force(eval(parse(text = txt), e))
}
#' Testing R Version
#'
#' Compares current R version with a given target version, which may be useful
#' for implementing version dependent code.
#'
#' @param x target version to compare with.
#' @param test numeric value that indicates the comparison to be carried out.
#' The comparison is based on the result from
#' \code{utils::compareVersion(R.version, x)}:
#' \itemize{
#' \item 1: is R.version > \code{x}?
#' \item 0: is R.version = \code{x}?
#' \item -1: is R.version < \code{x}?
#' }
#'
#' @return a logical
#' @export
#' @examples
#'
#' testRversion("2.14")
#' testRversion("2.15")
#' testRversion("10")
#' testRversion("10", test = -1)
#' testRversion("< 10")
#' testRversion(Rversion())
#' testRversion(paste0('=', Rversion()))
#'
testRversion <- function(x, test=1L){
rv <- Rversion()
op <- '=='
if( grepl("^[=<>]", str_trim(x)) ){
m <- str_match(x, "^([<>=]=?)(.*)")
if( is.na(m[, 1]) ) stop('Invalid version specification: ', x)
op <- m[, 2]
if( op == '=' ) op <- '=='
x <- str_trim(m[, 3L])
if( !missing(test) ) warning("Ignoring argument `test`: comparison operator was passed in argument `x`")
test <- 0L
}
do.call(op, list(utils::compareVersion(rv, x), test))
}
#' Complete R version
#'
#' Returns the complete R version, e.g. 2.15.0
#'
#' @return A character string.
#' @export
#' @examples
#' Rversion()
#'
Rversion <- function(){
paste(R.version$major, R.version$minor, sep='.')
}
#' Formatting Utilities
#'
#' \code{str_out} formats character vectors for use in show methods or
#' error/warning messages.
#'
#' @param x character vector
#' @param max maximum number of values to appear in the list. If \code{x} has
#' more elements than \code{max}, a \code{"..."} suffix is appended.
#' @param quote a logical indicating whether the values should be quoted with
#' single quotes (defaults) or not.
#' @param use.names a logical indicating whether names should be added to the
#' list as \code{NAME=VAL, ...} or not (default).
#' @param sep separator character
#' @param total logical that indicates if the total number of elements should be
#' appended to the formatted string as \code{"'a', ..., 'z' (<N> total)"}.
#'
#' @return a single character string
#'
#' @examples
#'
#' x <- letters[1:10]
#' str_out(x)
#' str_out(x, 8)
#' str_out(x, Inf)
#' str_out(x, quote=FALSE)
#' str_out(x, total = TRUE)
#'
#' @export
str_out <- function(x, max=3L, quote=is.character(x), use.names=FALSE, sep=", ", total = FALSE){
if( is_NA(max) ) max <- Inf
suffix <- NULL
nTotal <- length(x)
if( max > 2 && length(x) > max ){
suffix <- "..."
x <- c(head(x, max-1), tail(x, 1))
}
x <- head(x, max)
# add quotes if necessary
quote <-
if( isTRUE(quote) ) "'"
else if( is.character(quote) ) quote
if( !is.null(quote) ) x <- unlist(lapply(x, function(v) paste(quote,v,quote, sep='')))
else if( all(sapply(x, isInteger)) ) x <- unlist(lapply(x, function(v) str_c(v,'L')))
# add names if necessary
if( use.names && !is.null(names(x)) ){
nm <- str_c(names(x),'=')
x <- paste(ifelse(nm=='=','',nm), x, sep='')
}
# insert suffix
if( !is.null(suffix) ){
x <- c(head(x, length(x)-1L), suffix, tail(x, 1L))
}
s <- paste(paste(x, collapse=sep), sep='')
if( total ) s <- paste0(s, ' (', format(nTotal, big.mark=",", scientific=F), ' total)')
# return formatted string
s
}
#' @describeIn str_out builds formatted string from a list of complex values.
#'
#' @param object an R object
#' @param exdent extra indentation passed to str_wrap, and used if the output
#' should spread over more than one lines.
#'
#' @export
str_desc <- function(object, exdent=0L){
p <- sapply(object, function(x){
if( is.atomic(x) && length(x) == 1L ) x
else paste("<", class(x), ">", sep='')
})
str_wrap(str_out(p, NA, use.names=TRUE, quote=FALSE), exdent=exdent)
}
#' @describeIn str_out extracts and formats a function signature.
#' It typically formats the output \code{capture.output(args(object))}.
#'
#' @export
#' @examples
#' str_fun(install.packages)
str_fun <- function(object){
s <- capture.output(args(object))
paste(s[-length(s)], collapse="\n")
}
#' @describeIn str_out outputs the class(es) of an object using \code{str_out}.
#'
#' @param ... other arguments passed to [str_out].
#'
#' @export
#' @examples
#' str_class(matrix())
str_class <- function(x, max = Inf, ...){
str_out(class(x), max = max, ...)
}
#' @describeIn str_out formats a package name and version
#'
#' @param pkg package name
#' @param lib.loc path to a library of R packages
#'
#' @export
str_pkg <- function(pkg, lib.loc = NULL){
sprintf("%s (version %s)", pkg, packageVersion(pkg, lib.loc = lib.loc))
}
#' @describeIn str_out computes md5sum on character vector using \code{\link[tools]{md5sum}}.
#'
#' @importFrom tools md5sum
#' @export
str_md5sum <- function(x){
tmp <- tempfile()
on.exit( unlink(tmp) )
cat(x, sep = "\n", file = tmp)
md5sum(tmp)
}
#' @describeIn str_out computes hash of a character vector using \code{\link[digest]{digest}}.
#'
#' @inheritParams digest::digest
#' @import digest
#' @export
str_hash <- function(x, algo = 'md5'){
digest(x, algo = algo, serialize = FALSE)
}
#' @describeIn str_out builds a string that describes the dimension of an object, in the form
#' `n x m` for 2D-objects, `n x m x p` for 3D-objects, and so on.
#'
#' @param dims a numeric vector of dimensions.
#' Default is to use the input object dimensions (via function `dims()`)
#'
#' @export
str_dim <- function(x, dims = dim(x)){
if( !is.null(dims) ) paste0(dims, collapse = ' x ')
else length(x)
}
# From example in ?toupper
capwords <- function(s, strict = FALSE) {
cap <- function(s) paste(toupper(substring(s,1,1)),
{s <- substring(s,2); if(strict) tolower(s) else s},
sep = "", collapse = " " )
sapply(strsplit(s, split = " "), cap, USE.NAMES = !is.null(names(s)))
}
#' Finding Differences Between Strings
#'
#' Computes which characters differ between two strings.
#'
#' @param x a single string
#' @param y a single string
#' @return an integer vector containing the index of all mis-matched characters
#' in the first string.
#' @export
#'
#' @examples
#'
#' # strings to compare
#' x <- "once upon a time"
#' y <- "once upon a time there was"
#' z <- "once upon two times"
#'
#' # diff: x - y
#' d <- str_diff(x, y)
#' d
#' str(d)
#'
#' # other comparisons
#' str_diff(y, x)
#' str_diff(x, x)
#' str_diff(x, z)
#' str_diff(y, z)
#'
str_diff <- function(x, y){
sx <- strsplit(x,'')[[1]]
sy <- strsplit(y,'')[[1]]
n <- min(length(sx), length(sy))
res <- mapply('!=', head(sx,n), head(sy,n))
wres <- which(res)
if( length(sx) > length(sy) )
wres <- c(wres, (n+1):length(sx))
attr(wres, 'str') <- list(x=x,y=y)
class(wres) <- 'str_diff'
wres
}
#' @export
print.str_diff <- function(x, ...){
s <- attr(x, 'str')
n <- max(nchar(s$x), nchar(s$y))
d <- rep('.', n)
d[x] <- '*'
if( (n2 <- nchar(s$y)-nchar(s$x)) )
d[(n-abs(n2)+1):n] <- if( n2 > 0L ) '-' else '+'
cat(str_c(s$x, collapse=''), "\n")
cat(str_c(d, collapse=''), "\n")
cat(str_c(s$y, collapse=''), "\n")
}
#' Extracting Local Function Definition
#'
#' @description
#' \code{extractLocalFun} Extracts local function from wrapper functions of the following type, typically
#' used in S4 methods:
#' \samp{
#' function(a, b, ...)\{
#' .local <- function(a, b, c, d, ...)\{\}
#' .local(a, b, ...)
#' \}
#' }
#'
#' @param f definition of the wrapper function
#'
#' @return a function
#' @export
#' @rdname formals
extractLocalFun <- function(f){
bf <- body(f)
txt <- as.character(bf)[2]
# in R-2.14.2 -- at least, as.character does not return the complete body
# so some text manipulation is necessary
if( !grepl("\\{", txt) ){
sf <- capture.output(print(bf))
w <- tail(grep("^\\s*\\.local\\(", sf), 1L)
txt <- paste(sf[-w], collapse="\n")
}
expr <- parse(text=txt)
e <- new.env()
eval(expr, e)
}
#' Extended Formal Extraction
#'
#' Works for methods that are created (setMethod) as a wrapper function to an
#' internal function named .local.
#'
#' @return a paired list like the one returned by \code{\link{formals}}.
#'
#' @export
#' @import codetools
#' @rdname formals
allFormals <- function(f){
# look inside method for S4 methods
if( is(f, 'MethodDefinition') ){
# check if the method is defined as a wrapper function
f <- f@.Data
lf <- try(codetools::getAssignedVar(body(f)), silent=TRUE)
if( !identical(lf, '.local') ) return( formals(f) )
# extract arguments from local function
lfun <- extractLocalFun(f)
res <- formals(lfun)
# set default values from the generic, only for arguments that have no
# default values in the method
generic_args <- formals(f)
meth_no_default <- sapply(res, is.symbol)
gen_no_default <- sapply(generic_args, is.symbol)
generic_args <- generic_args[ !gen_no_default ]
generic_args <- generic_args[ names(generic_args) %in% names(res[meth_no_default]) ]
if( length(generic_args) ){
res[names(generic_args)] <- generic_args
}
# return complete list of arguments
res
}else if( is.function(f) ) formals(f)
}
#' Alternative S4 Constructor
#'
#' An alternative version of \code{\link{new}} to create objects based on a list
#' of values.
#'
#' @param class Class name to instanciate
#' @param ... extra arguments from which slot values are extracted by exact
#' matching of names.
#'
#' @return An S4 object.
#'
#' @export
#' @examples
#'
#' setClass('A', contain='character', representation(x='numeric', y='character'))
#'
#' # identical behaviour with standard calls
#' identical(new('A'), new2('A'))
#' identical(new('A', x=1), new2('A', x=1))
#'
#' # but if passing that are names not slots
#' identical(new('A'), new2('A', b=1))
#' identical(new('A', x=1), new2('A', x=1, b=3))
#' identical(new('A', x=1), new2('A', x=1, b=3))
#'
#' # standard `new` would coerce first unnamed argument into parent of 'A' (i.e. 'character')
#' new('A', list(x=1))
#' new('A', list(x=1, y='other'))
#' # `new2` rather use it to initialise the slots it can find in the list
#' identical(new('A', x=1), new2('A', list(x=1)))
#' identical(new('A', x=1, y='other'), new2('A', list(x=1, y='other')))
#'
#'
new2 <- function(class, ...){
sl <- getSlots(class)
if( nargs() == 1L ) return( new(class) )
dots <- list(...)
if( nargs() == 2L && is.null(names(dots)) ){
l <- dots[[1]]
if( !is.list(l) )
stop("Invalid call: single unnamed argument must be a list")
dots <- l
}
if( is.null(names(dots)) || any(names(dots)=='') )
stop("Invalid call: all slot arguments must be named")
dots <- dots[names(dots) %in% names(sl)]
do.call('new', c(list(class), dots))
}
#' One-off Global Variables
#'
#' Defines a function that allow to get/assign a global variable whose value is
#' ensured to be reset after each access.
#'
#' @param default default value to which the global variable is reset after each
#' access. Default is \code{NULL}.
#'
#' @return a function with one argument (\code{value}) that provides get/set access
#' to a global variable.
#' If called with a value, it assigns this value to the global variable.
#' If called with no argument, it returns the current value of the global variable and
#' reset it to its default value -- as defined at its creation.
#'
#' @export
#'
#' @examples
#'
#' x <- oneoffVariable(0)
#' # returns default value
#' x()
#' # assign a value
#' x(3)
#' # get the value
#' x()
#' # second call returns default value again
#' x()
#'
oneoffVariable <- function(default=NULL){
.var <- default
function(value){
if( missing(value) ){
res <- .var
.var <<- default
res
}else
.var <<- value
}
}
## Exit Error Checker
##
## This function defines a function that checks if an error has been
## thrown after its definition.
## It may be used to perform tasks on function exit depending on
## how the function exit (normal return or with an error).
##
## The function \code{errorCheck} itself is meant to be called at
## the beginning of functions that use \code{\link{on.exit}} to
## perform tasks when exiting.
## The error checker function returned, when used in \code{on.exit}
## expressions, enables to distinguish between a normal exit and
## an exit due to an error, allowing is to perform tasks specific
## to each scenario.
##
## IMPORTANT: this function is not 100\% perfect in the sense that
## it will detect an error as soon as one has been thrown, even it
## is catched before the exit -- with \code{\link{try}} or
## \code{\link{tryCatch}}.
##
## @export
## @examples
##
## # define some function
## f <- function(err){
##
## # initialise an error checker
## isError <- errorCheck()
##
## # do something on exit that depends on the error status
## on.exit({
## if(isError()) cat("with error: cleanup\n")
## else cat("no error: do nothing\n")
## })
##
## # throw an error here
## if( err ) stop('There is an error')
##
## 1+1
## }
##
## # without error
## f(FALSE)
## # with error
## try( f(TRUE) )
##
#errorCheck <- function(){
#
# # initialise with unique error message
# .err <- tryCatch(stop('ERROR_CHECK:', digest(tempfile())), error=function(e) conditionMessage(e))
# tb_digest <- function() digest(capture.output(traceback(max.lines=NULL)))
# .traceback <- tb_digest()
#
# function(){
# # error message is different
# # tb_digest() != .traceback
# length(grep(.err, msg, fixed=TRUE, invert=TRUE)) == 1L
# }
#}
#' Global Static Variable
#'
#' \code{sVariable} defines a function that acts as a global
#' static variable.
#'
#' @param default default value for the static variable.
#'
#' @return A function that can be used to set/get the static variable.
#' @export
#' @examples
#'
#' # define variable
#' x <- sVariable(1)
#' # get value (default)
#' x()
#' # set new value: return old value
#' old <- x(3)
#' old
#' # get new value
#' x()
#'
sVariable <- function(default=NULL){
.val <- default
function(value){
if( missing(value) ) .val
else{
old <- .val
.val <<- value
old
}
}
}
#' Exit Error Checks
#'
#' \code{exitCheck} provides a mechanism to distinguish the exit status
#' in \code{\link{on.exit}} expressions.
#'
#' It generates a function that is used wihtin a function's body to
#' "flag" normal exits and in its \code{\link{on.exit}} expression
#' to check the exit status of a function.
#' Note that it will correctly detect errors only if all normal exit
#' are wrapped into a call to it.
#'
#' @return Either `x` or the success status when called without arguments.
#'
#' @export
#'
#' @examples
#'
#' # define some function
#' f <- function(err){
#'
#' # initialise an error checker
#' success <- exitCheck()
#'
#' # do something on exit that depends on the error status
#' on.exit({
#' if(success()) cat("Exit with no error: do nothing\n")
#' else cat("Exit with error: cleaning up the mess ...\n")
#' })
#'
#' # throw an error here
#' if( err ) stop('There is an error')
#'
#' success(1+1)
#' }
#'
#' # without error
#' f(FALSE)
#' # with error
#' try( f(TRUE) )
#'
exitCheck <- function(){
.success <- FALSE
function(x){
if( nargs() == 0L ) .success
else{
.success <<- TRUE
x
}
}
}
#' Ordering Version Numbers
#'
#' Orders a vector of version numbers, in natural order.
#'
#' @param x a character vector of version numbers
#' @param decreasing a logical that indicates if the ordering should be decreasing
#'
#' @return A character vector.
#' @export
#' @examples
#'
#' v <- c('1.0', '1.03', '1.2')
#' order(v)
#' orderVersion(v)
#'
orderVersion <- function(x, ..., decreasing=FALSE){
NAs <- which(is.na(x))
tx <- gsub("[^0-9]+",".", paste('_', x, sep=''))
stx <- strsplit(tx, ".", fixed=TRUE)
mtx <- max(sapply(stx, length))
tx <- sapply(stx,
function(v) paste(sprintf("%06i", c(as.integer(v[-1]),rep(0, mtx-length(v)+1))), collapse='.')
)
res <- order(tx, ..., decreasing = decreasing)
# put NAs at the end
if( length(NAs) ){
res <- c(setdiff(res, NAs), NAs)
}
res
}
#' @param ... extra parameters passed to \code{orderVersion} and \code{\link{order}}
#'
#' @export
#' @rdname orderVersion
#' @examples
#'
#' sort(v)
#' sortVersion(v)
sortVersion <- function(x, ...){
x[orderVersion(x, ...)]
}
#' Checking for Missing Arguments
#'
#' This function is identical to \code{\link{hasArg}}, except that
#' it accepts the argument name as a character string.
#' This avoids to have a check NOTE about invisible binding variable.
#'
#' @param name the name of an argument as a character string.
#'
#' @return A logical flag.
#' @export
#' @examples
#'
#' f <- function(...){ hasArg2('abc') }
#' f(a=1)
#' f(abc=1)
#' f(b=1)
#'
hasArg2 <- function (name)
{
name <- as.name(name)
## apply methods::hasArg
aname <- as.character(substitute(name))
fnames <- names(formals(sys.function(sys.parent())))
if (is.na(match(aname, fnames))) {
if (is.na(match("...", fnames)))
FALSE
else {
dotsCall <- eval(quote(substitute(list(...))), sys.parent())
!is.na(match(aname, names(dotsCall)))
}
}
else eval(substitute(!missing(name)), sys.frame(sys.parent()))
##
}
#' Exposing Object Attributes
#'
#' The function \code{ExposeAttribute} creates an S3 object that
#' exposes all attributes of any R object, by making them accessible via
#' methods \code{\link{$}} and/or \code{\link{$<-}}.
#'
#' @param object any R object whose attributes need to be exposed
#' @param ... attributes, and optionally their respective values or
#' access permissions.
#' See argument \code{value} of \code{attr_mode} for details on the
#' way of specifying these.
#' @param .MODE access mode:
#' \describe{
#' \item{\dQuote{r}:}{ (read-only) only method \code{$} is defined}
#' \item{\dQuote{w}:}{ (write-only) only method \code{$<-} is defined}
#' \item{\dQuote{rw}:}{ (read-write) both methods \code{$} and \code{$<-}
#' are defined}
#' }
#' @param .VALUE logical that indicates if the values of named arguments
#' in \code{...} should be considered as attribute assignments,
#' i.e. that the result object has these attributes set with the specified values.
#' In this case all these attributes will have the access permission
#' as defined by argument \code{.MODE}.
#'
#' @return `ExposeAttribute` returns an S3 object of class `ExposeAttribute`.
#' @export
ExposeAttribute <- function(object, ..., .MODE='rw', .VALUE=FALSE){
# setup exposed arguments
args <- list(...)
if( length(args) ){
# use the same mode for all attributes
if( isString(.MODE) == 1L )
.MODE <- rep(.MODE, length(args))
else if( length(.MODE) != length(args) ){
stop("Argument .MODE must provide an access mode for each argument in `...`.")
}
if( is.null(names(args)) ) # add names if necessary
args <- setNames(args, rep('', length(args)))
un <- names(args)==''
if( any(!sapply(args[un], isString)) )
stop("All unnamed argument must be the name of an attribute, i.e. a character string.")
# set attributes that have values if requested
if( .VALUE ){
sapply(names(args)[!un], function(x){
attr(object, x) <<- args[[x]]
})
}else{ # or use the values as access permission
.MODE[!un] <- args[!un]
}
#
# store exposed attributes with names as regular expressions
eargs <- ifelse(un, args, names(args))
eargs <- as.list(setNames(.MODE, eargs))
# add ereg start-end
names(eargs) <- paste('^', names(eargs), '$', sep='')
}else{
eargs <- .MODE
}
# store access rights
attr(object, '.ExposeAttribute') <- eargs
class(object) <- c(class(object), 'ExposeAttribute')
object
}
.getEAmode <- function(x, name, ..., RAW..=FALSE){
ea <- attr(x, '.ExposeAttribute')
if( is.null(ea) ) return()
if( is.character(ea) && !RAW.. )
ea <- list(`^.*$`=ea)
if( missing(name) ) return(ea)
name <- name[name != '.ExposeAttribute']
# determine access mode
m <- lapply(names(ea), function(p){
m <- grep(p, name, value=TRUE)
setNames(rep(ea[[p]], length(m)), m)
})
unlist(m)
#
}
#' @export
.DollarNames.ExposeAttribute <- function(x, pattern=""){
att <- grep(pattern, names(attributes(x)), value=TRUE)
if( nchar(pattern) > 1 )
att <- unique(c(substring(pattern, 2), att))
# filter out based on the access permissions
mode <- .getEAmode(x, att)
if( !length(mode) ) return(character())
mode <- mode[mode != '']
# add `<-` suffix to write only attributes
if( length(wonly <- which(mode=='w')) )
names(mode)[wonly] <- paste(names(mode)[wonly], '<- ')
names(mode)
}
#' @export
`$.ExposeAttribute` <- function(x, name){
if( is.null(attr(x, name)) )
stop("Object `", deparse(substitute(x)),"` has no attribute '", name, "'.")
mode <- .getEAmode(x, name)
if( !length(mode) ){
stop("Could not access attribute via `$`: attribute '", name, "' is not exposed. Use `attr(x, '", name, "').")
}
if( !any(grepl('r', mode)) ){
stop("Could not access exposed attribute '", name, "': permission denied [mode='", mode,"'].")
}
attr(x, name)
}
#' @export
`$<-.ExposeAttribute` <- function(x, name, value){
mode <- .getEAmode(x, name)
if( !length(mode) ){
stop("Could not write attribute via `$<-`: attribute '", name, "' is not exposed. Use `attr(x, '", name, "') <- value.")
}
if( !any(grepl('w', mode)) ){
stop("Could not write attribute '", name, "': permission denied [mode='", mode,"'].")
}
attr(x, name) <- value
x
}
#' @export
print.ExposeAttribute <- function(x, ...){
# remove EA stuff
attr_mode(x) <- NULL
# call next print method
print(x, ...)
}
#' \code{attr_mode} and \code{attr_mode<-} get and sets the access mode of
#' \code{ExposeAttribute} objects.
#'
#' @param x an \code{ExposeAttribute} object
#' @param value replacement value for mode.
#' It can be \code{NULL} to remove the ExposeAttribute wrapper,
#' a single character string to define a permission for all atributes
#' (e.g., \code{'rw'} or \code{'r'}), or a list specifying access permission
#' for specific attributes or classes of attributes defined by regular expressions.
#' For example, \code{list(a='r', b='w', `blabla.*`='rw')} set attribute \code{'a'}
#' as read-only, attribute \code{'b'} as write-only, all attributes that start with
#' \code{'blabla'} in read-write access.
#'
#' @export
#' @rdname ExposeAttribute
attr_mode <- function(x){
.getEAmode(x, RAW..=TRUE)
}
#' @export
#' @rdname ExposeAttribute
`attr_mode<-` <- function(x, value){
if( is.null(value) ){
attr(x, '.ExposeAttribute') <- NULL
class(x) <- class(x)[!class(x) %in% "ExposeAttribute"]
}else if( isString(value) ){
x <- ExposeAttribute(x, .MODE=value)
}else if( is.list(value) ){
args <- c(list(x), names(value), list(.MODE=setNames(value, NULL), .VALUE=FALSE))
x <- do.call('ExposeAttribute', args)
}else{
stop("Invalid value: a character string or a list is expected")
}
x
}
#' Checking R User
#'
#' Tests if the current R user is amongst a given set of users.
#'
#' @param user the usernames to check for, as a character vector.
#'
#' @return A logical flag
#' @export
userIs <- function(user){
setNames(Sys.info()['user'], NULL) %in% user
}
#' Expanding Lists
#'
#' \code{expand_list} expands a named list with a given set of default items,
#' if these are not already in the list, partially matching their names.
#'
#' @param x input list
#' @param ... extra named arguments defining the default items.
#' A list of default values can also be passed as a a single unnamed argument.
#' @param .exact logical that indicates if the names in \code{x} should be
#' partially matched against the defaults.
#' @param .names logical that only used when \code{.exact=FALSE} and indicates
#' that the names of items in \code{x} that partially match some defaults should
#' be expanded in the returned list.
#'
#' @return a list
#'
#' @export
#' @examples
#'
#' expand_list(list(a=1, b=2), c=3)
#' expand_list(list(a=1, b=2, c=4), c=3)
#' # with a list
#' expand_list(list(a=1, b=2), list(c=3, d=10))
#' # no partial match
#' expand_list(list(a=1, b=2, c=5), cd=3)
#' # partial match with names expanded
#' expand_list(list(a=1, b=2, c=5), cd=3, .exact=FALSE)
#' # partial match without expanding names
#' expand_list(list(a=1, b=2, c=5), cd=3, .exact=FALSE, .names=FALSE)
#'
#' # works also inside a function to expand a call with default arguments
#' f <- function(...){
#' cl <- match.call()
#' expand_list(cl, list(a=3, b=4), .exact=FALSE)
#' }
#' f()
#' f(c=1)
#' f(a=2)
#' f(c=1, a=2)
#'
expand_list <- function(x, ..., .exact=TRUE, .names=!.exact){
# extract defaults from ... arguments
defaults <- list(...)
if( length(defaults) == 1L && is.null(names(defaults)) ){
defaults <- defaults[[1L]]
}
# early exit if no defaults
if( !length(defaults) ) return(x)
# match names from x in defaults
x_ex <- x
if( !.exact ){
i <- pmatch(names(x), names(defaults))
# first expand names if necessary
if( length(w <- which(!is.na(i))) ){
names(x_ex)[w] <- names(defaults)[i[w]]
# apply to as well if necessary
if( .names ) names(x)[w] <- names(defaults)[i[w]]
}
}
# expand list
i <- match(names(defaults), names(x_ex))
if( length(w <- which(is.na(i))) ){
n <- names(defaults)[w]
lapply(n, function(m){
if( is.null(defaults[[m]]) ) x[m] <<- list(NULL)
else x[[m]] <<- defaults[[m]]
})
}
x
}
#' @describeIn expand_list expands the \code{...} arguments of the function
#' in which it is called with default values, using \code{expand_list}.
#' It can \strong{only} be called from inside a function.
#'
#' @param .exclude optional character vector of argument names to exclude
#' from expansion.
#'
#' @export
#' @examples
#' # expanding dot arguments
#'
#' f <- function(...){
#' expand_dots(list(a=2, bcd='a', xxx=20), .exclude='xxx')
#' }
#'
#' # add default value for all arguments
#' f()
#' # add default value for `bcd` only
#' f(a=10)
#' # expand names
#' f(a=10, b=4)
#'
expand_dots <- function(..., .exclude=NULL){
dotsCall <- as.list(eval(quote(substitute(list(...))), sys.parent()))
if( length(dotsCall) >= 1L ) dotsCall <- dotsCall[-1L]
# extract defaults from ... arguments
defaults <- list(...)
if( length(defaults) == 1L && is.null(names(defaults)) ){
defaults <- defaults[[1L]]
}
if( length(defaults) ){
excl <- names(allFormals(sys.function(sys.parent())))
if( !is.null(.exclude) ) excl <- c(excl, .exclude)
defaults <- defaults[!names(defaults) %in% excl]
dotsCall <- expand_list(dotsCall, defaults, .exact=FALSE)
}
#
# return expanded dot args
dotsCall
}
#' Check Environment Variables
#'
#' Tells if some environment variable(s) are defined.
#'
#' @param x environment variable name, as a character vector.
#'
#' @return A logical flag.
#' @export
#' @examples
#'
#' hasEnvar('_R_CHECK_TIMINGS_')
#' hasEnvar('ABCD')
#'
hasEnvar <- function(x){
is.na(Sys.getenv(x, unset = NA, names = FALSE))
}
#' Substituting Strings Against a Mapping Table
#'
#' Match the elements of a character vectors against a mapping table,
#' that can specify multiple exact or partial matches.
#'
#' @param x character vector to match
#' @param maps mapping tables.
#' May be a character vector, a list of character vectors or a function.
#' @param nomatch character string to be used for non-matched elements of \code{x}.
#' If \code{NULL}, these elements are left unchanged.
#' @param partial logical that indicates if partial matches are allowed,
#' in which case mappings are used as regular expressions.
#' @param rev logical that indicates if the mapping should be interpreted in the
#' reverse way.
#'
#' @return A character vector.
#' @export
charmap <- function(x, maps, nomatch = NULL, partial = FALSE, rev = FALSE){
x <- as.character(x)
res <- setNames(as.character(rep(NA, length(x))), x)
if( !is.list(maps) ) maps <- list(maps)
for( k in seq_along(maps) ){
# stop as soon as all type is mapped
if( !length(i <- which(is.na(res))) ) break;
# match unmapped type
ct <- names(res)[i]
map <- maps[[k]]
if( is.function(map) ){
m <- map(ct)
}else if( is.character(map) ){
if( is.null(names(map)) ) map <- setNames(rep(names(maps)[k], length(map)), map)
m <- .charmap(ct, map, partial = partial, rev = rev)
}else if( is.list(map) ){
map <- unlist2(map)
m <- .charmap(ct, setNames(names(map), map), partial = partial, rev = rev)
}else stop("Invalid cell type map [", class(map), ']')
# update result map
if( !is.null(m) ) res[i] <- m
}
if( anyNA(res) ){
i <- is.na(res)
if( is.null(nomatch) ) res[i] <- x[i]
else res[i] <- nomatch
}
res
}
.charmap <- function(x, map, partial = FALSE, rev = FALSE){
map <- if( !rev ) setNames(as.character(map), names(map))
else if( !is.null(names(map)) ) setNames(names(map), as.character(map))
else stop("Impossible to map data: the provided map has no names.")
if( isFALSE(partial) ) i <- match(tolower(x), tolower(names(map)))
else if( isTRUE(partial) ){
i <- sapply(tolower(x), function(x){
m <- pmatch(tolower(names(map)), x)
i <- which(!is.na(m))[1L]
if( !length(i) ) NA else i
})
}else{
i <- rep(NA, length(x))
sapply(seq_along(map), function(j){
e <- names(map)[j]
mi <- grep(e, x)
if( length(mi) ) i[mi] <<- j
})
}
ok <- !is.na(i)
i[ok] <- as.character(map[i[ok]])
as.character(i)
}
#' Open a File Graphic Device
#'
#' Opens a graphic device depending on the file extension.
#'
#' @param filename path to the image file to create.
#' @param width output width
#' @param height output height
#' @param ... other arguments passed to the relevant device function
#' such as \code{\link{png}} or \code{\link{pdf}}.
#'
#' importFrom grDevices bmp jpeg pdf png svg tiff
#'
#' @return The value of the called device function.
#' @export
gfile <- function(filename, width, height, ...){
# Get file type
r = regexpr("\\.[a-zA-Z]*$", filename)
if(r == -1) stop("Improper filename")
ending = substr(filename, r + 1, r + attr(r, "match.length"))
f = switch(ending,
pdf = function(x, ...) pdf(x, ...),
svg = function(x, ...) svg(x, ...),
png = function(x, ...) png(x, ...),
jpeg = function(x, ...) jpeg(x, ...),
jpg = function(x, ...) jpeg(x, ...),
tiff = function(x, ...) tiff(x, compression = "lzw", ...),
bmp = function(x, ...) bmp(x, ...),
stop("File type should be: pdf, svg, png, bmp, jpg, tiff")
)
args <- c(list(filename), list(...))
if( !missing(width) ){
args$width <- as.numeric(width)
args$height <- as.numeric(height)
if( !ending %in% c('pdf','svg') && is.null(args[['res']]) ){
args$units <- "in"
args$res <- 300
}
}
do.call('f', args)
}
#' Flatten a List Conserving Names
#'
#' `unlist_` is a replacement for [base::unlist] that does not mangle the names.
#'
#' Use this function if you don't like the mangled names returned by the standard `unlist` function from the base package.
#' Using `unlist` with annotation data is dangerous and it is highly recommended to use `unlist_` instead.
#'
#' @inheritParams AnnotationDbi::unlist2
#'
#' @return A vector.
#'
#' @author Herve Pages
#' @source Bioconductor AnnotationDbi::unlist2
#' @export
#' @examples
#' x <- list(A=c(b=-4, 2, b=7), B=3:-1, c(a=1, a=-2), C=list(c(2:-1, d=55), e=99))
#' unlist(x)
#' unlist_(x)
#'
#' # annotation maps (as in AnnotationDbi objects
#' egids2pbids <- list('10' = 'a', '100' = c('b', 'c'), '1000' = c('d', 'e'))
#' egids2pbids
#'
#' unlist(egids2pbids) # 1001, 1002, 10001 and 10002 are not real
#' # Entrez ids but are the result of unlist()
#' # mangling the names!
#' unlist_(egids2pbids) # much cleaner! yes the names are not unique
#' # but at least they are correct...
#'
unlist_ <- function (x, recursive = TRUE, use.names = TRUE, what.names = "inherited")
{
ans <- unlist(x, recursive, FALSE)
if (!use.names)
return(ans)
if (!is.character(what.names) || length(what.names) != 1)
stop("'what.names' must be a single string")
what.names <- match.arg(what.names, c("inherited", "full"))
names(ans) <- unlist(make.name.tree(x, recursive, what.names),
recursive, FALSE)
ans
}
# taken from Bioconductor AnnotatiobnDbi::make.name.tree
make.name.tree <- function (x, recursive, what.names)
{
if (!is.character(what.names) || length(what.names) != 1)
stop("'what.names' must be a single string")
what.names <- match.arg(what.names, c("inherited", "full"))
.make.name.tree.rec <- function(x, parent_name, depth) {
if (length(x) == 0)
return(character(0))
x_names <- names(x)
if (is.null(x_names))
x_names <- rep.int(parent_name, length(x))
else if (what.names == "full")
x_names <- paste0(parent_name, x_names)
else x_names[x_names == ""] <- parent_name
if (!is.list(x) || (!recursive && depth >= 1L))
return(x_names)
if (what.names == "full")
x_names <- paste0(x_names, ".")
lapply(seq_len(length(x)), function(i) .make.name.tree.rec(x[[i]],
x_names[i], depth + 1L))
}
.make.name.tree.rec(x, "", 0L)
}
#' Reordering Columns
#'
#' Reorders columns according to a prefered target order
#'
#' Column names will be reordered so that their order match the one in `target`.
#' Any column that does not appear in `target` will be put after those that are
#' listed in `target`.
#'
#' @param x an object with columns, such as a `matrix` or a `data.frame`,
#' or from a class that support subsetting via `x[, i, drop = FALSE]` and has a method `colnames`.
#' @param target a character or named numeric vector that specifies the column prefered order.
#' If a numeric vector, then its names are assumed to correspond to columns,
#' and its values determine the target order -- according to argument `decreasing`.
#' @param decreasing logical that indicates in which direction a numeric target vector should
#' be ordered.
#'
#' @return an object of the same type and dimension
#'
#' @export
#'
reorder_columns <- function(x, target, decreasing = FALSE){
if( is.numeric(target) ){
target <- names(target)[order(target, decreasing = decreasing)]
}
x[, order(match(colnames(x), target)), drop = FALSE]
}
#' Converting Factors to Character Vectors
#'
#' Converts all `factor` variables to character vectors in a `data.frame`
#' or phenotypic data.
#'
#' @param x `data.frame` or `ExpressionSet` object
#'
#' @return an object of the same class as `x`.
#'
#' @export
factor2character <- function(x){
if( is(x, 'ExpressionSet') ){
if( !requireNamespace('Biobase') ){
stop("Missing dependency: package 'Biobase' is required to handle ExpressionSet objects.\n"
, " Try installing with: source('https://bioconductor.org/biocLite.R')")
}
Biobase::pData(x) <- factor2character(Biobase::pData(x))
return(x)
}
for(v in colnames(x)){
if( is.factor(x[[v]]) ) x[[v]] <- as.character(x[[v]])
}
x
}
#' Compute Function Digest Hash
#'
#' Computes a digest hash of the body and signature of a function.
#' Note that the hash is not affected by attributes or the
#' function's environment.
#'
#' The hash itself is computed using [digest::digest].
#'
#' @param fun a function
#' @param n a single numeric that indicates the length of the hash.
#'
#' @return a character string
#'
#' @import digest
#' @importFrom assertthat is.number
#' @export
digest_function <- function(fun, n = Inf){
assert_that(is.number(n) & n>0, msg = "Invalid argument 'n': must be Inf or a positive number.")
# get function body (handle primitive in a special way)
bd <- if( !is.primitive(fun) ) body(fun) else capture.output(fun)
attributes(bd) <- NULL
bd <- as.character(bd)
# include formals in the hash for non-primitive functions
if( !is.primitive(fun) ) bd <- list(bd, formals(fun))
hash <- digest::digest(bd)
# limit to a given size if requested
if( is.finite(n) ) hash <- substr(hash, 1L, n)
hash
}
#' System Call Stack Utilities
#'
#' @name sys_call_stack
NULL
#' @describeIn sys_call_stack computes digest hash for each function in the call stack.
#' @param n a single frame
#'
#' @return * `sys.function_digest` returns a character vector of length `n`.
#' @export
sys.function_digest <- function(n = NULL){
assert_that(is.null(n) || (is.number(n) & n>0), msg = "Invalid argument 'n': must be NULL or a positive number.")
n <- n %||% sys.nframe()
sapply(1:n, function(i){
f <- sys.function(i)
digest_function(f)
})
}
#' @describeIn sys_call_stack returns the index of the frame that calls a given function.
#' @param fun the function object to find in the call stack.
#'
#' @return * `sys.function_nframe` returns a integer vector.
#' @export
sys.function_nframe <- function(fun){
which(sys.function_digest() == digest_function(fun))
}
#' @describeIn sys_call_stack returns the frame that calls a given function.
#'
#' @return * `sys.function_frame` returns an environment.
#' @export
sys.function_frame <- function(fun){
n <- sys.function_nframe(fun)
if( length(n) > 1L )
warning(sprintf("Multiple call frames found for target function '%s': using last call.", digest_function(fun)))
else if( !length(n) )
stop(sprintf("No call frames found for target function '%s'", digest_function(fun)))
sys.frame(n)
}
#' @describeIn sys_call_stack returns path to the script that is being sourced either
#' by [base::source] or [base::sys.source].
#' @export
sys.source_file <- function(){
res <- try(sys.function_frame(base::source), silent = TRUE)
if( is(res, "try-error") ){
res <- try(sys.function_frame(base::sys.source), silent = TRUE)
if( is(res, "try-error") ) stop("Could not find call frame for 'source' or 'sys.source'")
res[["file"]]
}else{
if( isString(res[["ofile"]]) ) res[["ofile"]]
else res[["filename"]]
}
}
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.