# missing/null values -----------------------------------------------------
# check if x is NULL or zero length.
# if allow_na=TRUE then also accepts all NA values as none.
is_none <- function(x) {
is.null(x) || length(x) < 1L
}
# check if all values are length zero or NA
all_missing <- function(x) {
is_none(x) || all(is.na(x))
}
# try to grab first non NA value in x, if none, return NULL
first_non_na <- function(x) {
val <- na.omit(x)[1] %:% NA
if (is.na(val)) {
return(NULL)
}
val
}
# return names of object that have non-zero chars
non_empty_names <- function(x, na.rm=TRUE) {
obj_names <- names(x)
obj_names <- obj_names[nzchar(obj_names)]
if (!na.rm) {
return(obj_names)
}
Filter(Negate(is.na), obj_names)
}
assert_names <- function(required, from_obj, ...) {
err <- list(...)
if (is_none(err)) {
fr <- sys.call(-1)
fr <- (is.null(fr)) %?% ".GlobalEnv" %:% deparse(fr[1])
err <- paste0(fr, ".")
} else {
err <- do.call(paste0, err)
}
if (!(required %Names?% from_obj)) {
stop("names missing: ", paste0(required, collapse=", "), "\n", err, call.=FALSE)
}
}
assert <- function(..., err=NULL, envir=parent.frame(), print) {
exprs <- eval(substitute(alist(...)))
force(envir)
if (missing(print)) {
if (is.null(err)) {
print <- TRUE
} else {
print <- FALSE
}
}
err <- paste0(err %:% "\b")
lapply(exprs, function(e) {
result <- eval(e, envir=envir)
expr_str <- dQuote(deparse(e))
if (print) {
msg <- paste(err, "expression", expr_str, "failed")
} else {
msg <- err
}
if (!(length(result) == 1 && is.logical(result))) {
stop("expression ", expr_str, " not logical", call.=FALSE)
}
if (!result) {
stop(msg, call.=FALSE)
}
NULL
})
invisible()
}
char_or_names <- function(x) {
if (!is.character(x)) {
x <- non_empty_names(x)
if (is_none(x)) {
stop("Could not determine names from object", call.=FALSE)
}
}
x
}
# special operators -------------------------------------------------------
# If true then object else null
#
# @details This is primarily used in conjuction with the `%:%` operator. See
# examples.
# @param lhs logical scalar.
# @param rhs object to return if `lhs` is `TRUE`.
# @return object on `rhs` or `NULL`
# @examples
# \donttest{
# `%:%` <- ggdistribute:::`%:%`
# `%?%` <- ggdistribute:::`%?%`
#
# TRUE %?% 1 %:% 0 #> 1
# FALSE %?% 1 %:% 0 #> 0
#
# x <- 0
#
# # expression returns whatever objects are wrapped in between %:%
# (x == 0) %?% "y" %:% "n"
# (x == 1) %?% c("y", "yes") %:% c("n", "No", "false")
#
# # ERROR: The %?% operator captured only 0, which is not logical.
# # x == 0 %?% "y" %:% "n"
#
# # ERROR: The TRUE slot cannot return NULL because NULL is used to
# # decide what to return in %:%
# # `TRUE %?% NULL` and `FALSE %?% obj` would both return NULL.
# # (x == 0) %?% NULL %:% "n"
# }
`%?%` <- function(lhs, rhs) {
if (!is.logical(lhs) || length(lhs) > 1 || anyNA(lhs)) {
stop("Value left of %?% must be logical, of length 1, and not NA.")
}
if (lhs) {
if (is_none(rhs)) {
stop(
"Values right of %?% cannot return NULL or length zero.",
" Try changing LHS to !LHS and reordering expresions after %?%."
)
}
rhs
} else {
NULL
}
}
# if LHS is NULL return RHS
`%:%` <- function(lhs, rhs) {
if (is.null(lhs)) {
rhs
} else {
lhs
}
}
# if LHS is NULL or length zero return RHS
`%||%` <- function(lhs, rhs) {
if (is_none(lhs)) {
rhs
} else {
lhs
}
}
# if LHS is NULL or length zero or all NA return RHS
`%NA%` <- function(lhs, rhs) {
if (all_missing(lhs)) {
rhs
} else {
lhs
}
}
`%Names%` <- function(lhs, rhs) {
lhs <- char_or_names(lhs)
lhs[lhs %chin% non_empty_names(rhs)]
}
`%!Names%` <- function(lhs, rhs) {
lhs <- char_or_names(lhs)
lhs[!(lhs %chin% non_empty_names(rhs))]
}
`%Names?%` <- function(lhs, rhs) {
lhs <- char_or_names(lhs)
all(lhs %chin% non_empty_names(rhs))
}
# transformations ---------------------------------------------------------
range_sequence <- function(x, n) {
limits <- range_no_inf(x)
if (all_missing(limits)) {
return(rep(NA, n))
}
seq(limits[1], limits[2], length.out=n)
}
# rescale x to the scale of y
rescale_as_other <- function(x, y, scalar_adj=1) {
limits <- range_no_inf(y)
if (all_missing(limits)) {
warning("x left as is. No range detected from y.")
return(x)
}
center <- mean(limits)
scale <- diff(limits)
# if the min/max of y is the same then x will start at y and end at y+1
if (scale <= 0) {
scale <- (scalar_adj == 0) %?% 1 %:% scalar_adj
center <- center + scalar_adj * 0.5
}
center + (norm_vec(x) - 0.5) * scale
}
# data objects ------------------------------------------------------------
# data.frame/table is empty
empty <- function(x) {
is.null(x) || nrow(x) == 0 || ncol(x) == 0
}
as_dtbl <- function(x, copy=FALSE) {
if (data.table::is.data.table(x)) {
if (copy) {
return(data.table::copy(x))
}
x
} else {
data.table::as.data.table(x)
}
}
set_col_order <- function(x, first_names) {
cols <- names(x)
not_first <- cols[!cols %chin% first_names]
data.table::setcolorder(x, c(first_names, not_first))
invisible(x)
}
rep.data.table <- function(x, ...) {
args <- list(...)
if (length(args) < 1) {
stop("must provide a `times, lenght.out, or each` argument")
}
n <- c(args[[1]], args$times, args$length.out, args$each)[1]
if (!is.numeric(n)) {
stop("second input argument must be numeric")
}
rbindlist(lapply(seq_len(n), function(...) {
x
}))
}
get_static_data <- function(from, ref=NULL) {
from <- as_dtbl(from)
if (is.null(ref)) {
use_names <- non_empty_names(from)
} else {
use_names <- from %!Names% ref
}
if (length(use_names) < 1) {
return(NULL)
}
is_static_df <- from[, lapply(.SD, function(i) {
uniqueN(i) == 1
}), .SDcols=use_names]
static_cols <- names(Filter(isTRUE, is_static_df))
if (is_none(static_cols)) {
return(NULL)
}
as.data.frame(from[1, static_cols, with=FALSE])
}
# misc --------------------------------------------------------------------
append_diff <- function(x, val=NA) {
c(diff(x), val)
}
unique_apply <- function(x, i, FUN, ...) {
if (is.null(i)) {
i <- integer(length(x)) + 1L
}
if (!is.numeric(i)) {
stop("i must be an integer index")
}
if (length(x) != length(i)) {
stop("i must be the same size as x")
}
FUN <- match.fun(FUN)
unq_i <- !duplicated(i)
unq_v <- FUN(x[unq_i], ...)
unq_v[i]
}
unique_simplex <- function(size_vec, grp_idx=NULL, offset_vec=0) {
size <- size_vec - offset_vec
unique_apply(size, grp_idx, function(x) {
x / sum(x)
})
}
function2chunk <- function(...) {
functions <- as.character(match.call())[-1L]
function_txt <- capture.output(dump(functions, "", control="all"))
cat("\n\n```r\n")
cat(function_txt, sep="\n")
cat("\n```\n\n")
}
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.