`%||%` <- function(x, y) if (is.null(x)) y else x
`%|||%` <- function(x, y) if (is.null(x) || isTRUE(is.na(x))) y else x
# A reference class that implements a stack data structure.
shtack <- methods::setRefClass('stack', list(elements = 'list'), methods = list(
clear = function() { elements <<- list() },
empty = function() { length(elements) == 0 },
push = function(x) { elements[[length(elements) + 1]] <<- x },
peek = function(n = 1) {
if (isTRUE(n)) return(elements)
els <- seq(length(elements), length(elements) - n + 1)
if (length(els) == 1) elements[[els]]
else elements[els]
},
pop = function() {
if (length(elements) == 0) stop("director:::stack is empty")
tmp <- elements[[length(elements)]]
elements[[length(elements)]] <<- NULL
tmp
},
pop_all = function() { tmp <- elements; elements <<- list(); tmp }
))
#' Whether or not a directory is an idempotent resource.
#'
#' By definition, this means the directory contains a file with the same name
#' (ignoring extension) as the directory.
#'
#' @param dir character. The directory to check.
#' @return \code{TRUE} or \code{FALSE} according as the directory is idempotent.
#' There is no checking to ensure the directory exists.
#' @examples
#' \dontrun{
#' # If we have a directory foo containing foo.R, then
#' is.idempotent_directory('foo')
#' # is TRUE, otherwise it's FALSE.
#' }
is.idempotent_directory <- function(dir) {
# TODO: (RK) Case insensitivity in OSes that don't respect it, i.e. Windows?
# TODO: (RK) File extensions besides .r and .R?
extensionless_exists(file.path(dir, basename(dir)))
}
#' Determine whether an R file exists regardless of case of extension.
#'
#' @param filename character. The filename to test (possibly without extension).
#' @return \code{TRUE} or \code{FALSE} if the filename exists regardless of
#' R extension.
#' @examples
#' \dontrun{
#' # Assume we have a file \code{"foo.R"}. The following all return \code{TRUE}.
#' extensionless_exists('foo.R')
#' extensionless_exists('foo.r')
#' extensionless_exists('foo')
#' }
extensionless_exists <- function(filename) {
file.exists(paste0(strip_r_extension(filename), '.r')) ||
file.exists(paste0(strip_r_extension(filename), '.R'))
# Don't use the any + sapply trick because we can skip the latter check if the
# former succeeds.
}
#' Complete the extension of a file (.r or .R).
#'
#' @note This function assumes at least one file ending in .r or .R exists.
#' @param name character. The filename sans extension.
#' @param base character. A base path to be prefixed to \code{name} when
#' checking if the suffixed versions exist. The final returned string will
#' not include this base.
#' @return \code{name} suffixed by ".r" or ".R" according to which exists.
#' (Many Unix-based systems are extension case-sensitive).
#' @examples
#' \dontrun{
#' # Assume we have a file \code{"foo.R"}.
#' stopifnot(complete_extension("foo") == "foo.R")
#'
#' # Assume we have a file \code{"bar.r"}.
#' stopifnot(complete_extension("bar") == "bar.R")
#' }
complete_extension <- function(name, base = NULL) {
upper_r <- paste0(name, ".R")
filepath <- if (missing(base)) upper_r else file.path(base, upper_r)
if (file.exists(filepath)) {
upper_r
} else {
paste0(name, ".r")
}
}
#' Strip R extension.
#'
#' @param filename character. The filename to strip.
#' @return the filename without the '.r' or '.R' at the end.
strip_r_extension <- function(filename) {
stopifnot(is.character(filename))
gsub("\\.[rR]$", "", filename)
}
#' Strip a root file path from an absolute filename.
#'
#' @param root character. The root path.
#' @param filename character. The full file name.
#' @return the stripped file path.
#' @examples
#' \dontrun{
#' stopifnot("test" == strip_root("foo/bar/test", "test"))
#' }
strip_root <- function(root, filename) {
stopifnot(is.character(root) && is.character(filename))
if (substring(filename, 1, nchar(root)) == root) {
filename <- substring(filename, nchar(root) + 1, nchar(filename))
gsub("^\\/*", "", filename)
} else filename
}
#' Convert an idempotent resource name to a non-idempotent resource name.
#'
#' @param filename character. The filename to convert.
#' @return the non-idempotent filename.
drop_idempotence <- function(filename) {
if (basename(dirname(filename)) == basename(filename))
dirname(filename)
else filename
}
#' Convert a filename to a resource name.
#'
#' @param filename character. The filename.
#' @return the resource name (i.e., stripped of idempotence and extension).
resource_name <- function(filename) {
drop_idempotence(strip_r_extension(filename))
}
#' Get all helper files associated with an idempotent resource directory.
#'
#' @param path character. The *absolute* path of the idempotent resource.
#' @param ... additional parameters to pass to \code{list.files}.
#' @param leave_idempotent logical. Whether or not to leave the
#' idempotent file (non-helper). By default \code{FALSE}.
#' @return a character list of relative helper paths.
#' @examples
#' \dontrun{
#' # If we have a directory structure given by \code{"model/model.R"},
#' # \code{"model/constants.R"}, \code{"model/functions.R"}, then the
#' # below will return \code{c("constants.R", "functions.R")}.
#' get_helpers("model")
#' }
get_helpers <- function(path, ..., leave_idempotent = FALSE) {
helper_files <- list.files(path, pattern = '\\.[rR]$', ...)
if (leave_idempotent) {
helper_files
} else {
same_file <- which(vapply(helper_files,
function(f) basename(strip_r_extension(f)) == basename(path), logical(1)))
helper_files[-same_file]
}
}
#' Whether or not any substring of a string is any of a set of strings.
#'
#' @param string character.
#' @param set_of_strings character.
#' @return logical
#' @examples
#' stopifnot(director:::any_is_substring_of('test', c('blah', 'te', 'woo'))) # TRUE
#' stopifnot(!director:::any_is_substring_of('test', c('blah', 'woo'))) # FALSE
any_is_substring_of <- function(string, set_of_strings) {
any(vapply(set_of_strings,
function(x) substring(string, 1, nchar(x)) == x, logical(1)))
}
#' Enforce parameter types (logical, character, etc.).
#'
#' @param object ANY. An R object to enforce types on.
#' @param admissible_types character. A character vector of allowed types.
#' @param function_name character. The function this enforcement is occurring
#' in, for error messages.
#' @param name character. The name of the parameter whose type is being
#' enforced. By default, the string expression passed in to the first
#' argument, \code{object}.
#' @return Nothing, but error if the type does not match.
#' @examples
#' \dontrun{
#' x <- 1
#' enforce_type(x, "logical", "myfunction")
#' # Will call stop() with the following error:
#' # "In 'myfunction', the 'x' parameter must be a character; instead, I got
#' # a logical.
#' }
enforce_type <- function(object, admissible_types, function_name, name = deparse(substitute(object))) {
## The `is` function takes parameters `object` and `class`, so this
## sneaky call is equivalent to
##
## ```r
## any(sapply(admissible_types, function(type) is(object, type)))
## ```
if (!any(vapply(admissible_types, is, logical(1), object = object))) {
stop(call. = FALSE, "In ", crayon::blue(function_name), ", the ",
crayon::blue(name), " parameter must be a ",
crayon::green(paste(admissible_types, collapse = " or ")),
"; instead, I got a ", crayon::red(class(object)[1]), ".")
}
}
#' A simple caching structure.
#'
#' @return A list of four methods \code{get}, \code{set}, \code{exists}
#' and \code{unset} that modify another list under the hood.
simple_cache <- function() {
cache <- list()
list(
get = function(key) cache[[key]],
## If instead we said `cache[[key]] <<- value`, `NULL` values would be
## cached incorrectly, since assigning `NULL` remove the key.
set = function(key, value) cache[key] <<- structure(list(value), .Names = key),
exists = function(key) is.element(key, names(cache)),
unset = function(key) cache[[key]] <<- NULL
)
}
#' Duplicate a function object.
#'
#' @param original function.
duplicate <- function(original) {
(`environment<-`(eval(call("function", formals(original), body(original))), environment(original)))
}
#' Append to a list or environment, overwriting if necessary.
#'
#' @param obj1. The object to be appended to.
#' @param obj2. The object to append.
#' @examples
#' \dontrun{
#' x <- list(a = 1)
#' x %<<% list(b = 2) # list(a = 1, b = 2)
#' x %<<% list(a = 2) # list(a = 2)
#' y <- list2env(x)
#' y %<<% list(b = 2) # environment with a = 1 and b = 2
#' y %<<% list2env(list(b = 2)) # same as above
#' y %<<% list(a = 2) # environment with a = 2
#' }
`%<<%` <- function(obj1, obj2) {
all_named <- function(x) { !is.null(names(x)) && all(nzchar(names(x))) }
if (is.list(obj1)) stopifnot(all_named(obj1))
if (is.list(obj2)) stopifnot(all_named(obj2))
for (name in ls(obj2)) {
obj1[[name]] <- obj2[[name]]
}
obj1
}
#' Queue with size limit.
#'
#' If you push more elements onto the queue than it has room for, they will
#' fall off screaming and wailing.
#'
#' @param size integer. Maximum number of elements in the queue.
#' @examples
#' \dontrun{
#' q <- sized_queue(size = 2)
#' q$push(1)
#' q$get(1) # 1
#' q$get(2) # NULL
#' q$push(2)
#' q$get(1) # 2
#' q$get(2) # 1
#' q$push(3)
#' q$get(1) # 3
#' q$get(2) # 2
#' q$get(3) # NULL
#' }
sized_queue <- function(size) {
length <- 0
queue <- vector('list', size)
structure(class = "sized_queue", list(
length = function() length,
push = function(el) {
queue <<- append(list(el), queue)[seq_len(size)]
length <<- min(length + 1, size)
el
},
get = function(el) if (el > size) NULL else queue[[el]]
))
}
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.