Nothing
is_empty_string <- function(x) {
is_scalar_character(x) && x == ""
}
is_truthy <- function(x) {
!(is_empty_string(x) ||
is_na(x) ||
is_null(x) ||
is_false(x))
}
are_truthy <- function(x) {
vapply(x, is_truthy, logical(1))
}
available <- function(x) {
x[are_truthy(x)]
}
compose <- function(..., .sep = "-") {
args <- list(...)
if (is_empty(args) || !all(are_truthy(args))) {
return(NULL)
}
paste(..., sep = .sep)
}
endash <- function(...) {
paste(..., sep = "-", collapse = " ")
}
prefix <- function(...) {
args <- available(list(...))
classes <- args[-1]
default <- args[1]
ns <- names(default)
if (is.null(ns)) {
ns <- default[[1]]
}
pref <- pronoun_get_prefix(ns)
if (is.null(pref)) {
pref <- endash("cas", default[[1]])
}
vapply(classes, function(x) {
if (is_true(x)) {
pref
} else {
endash(pref, x)
}
}, character(1))
}
pick <- function(from, x) {
if (is_null(x)) {
return(NULL)
}
nms <- names(x)
x <- as.character(x)
picked <- from[x]
if (anyNA(picked)) {
invalid <- setdiff(x, names(from))[1]
abortf("invalid value %s", invalid)
}
names(picked) <- nms
picked
}
caller_trace <- function(n = 1) {
trace_back(bottom = caller_env(n + 1))
}
abortf <- function(s, ..., collapse = ", ", trace = caller_trace(2)) {
args <- lapply(list(...), function(x) paste0(bold$red(x), collapse = collapse))
msg <- exec(sprintf, s, !!!args)
abort(msg, trace = trace)
}
# borrowed from rlang
local_exit <- function(expr, frame = caller_env()) {
expr <- enexpr(expr)
if (is_reference(frame, global_env())) {
is_global_frame <- sys.parents() == 0
if (sum(is_global_frame) == 1) {
abort("Can't add an exit event at top-level")
}
}
expr <- call2(on.exit, expr, add = TRUE)
eval_bare(expr, frame)
invisible(expr)
}
assert_subject <- function(x) {
if (!(is_style_pronoun(x) || is_pronoun_box(x) || is_tag(x))) {
abortf("cannot apply style to a %s", class(x))
}
}
is_style_pronoun <- function(x) {
inherits_only(x, "cascadess_style_pronoun")
}
is_pronoun_box <- function(x) {
is_box(x) && is_spliced(x) && is_style_pronoun(unbox(x))
}
is_tag <- function(x) {
inherits_any(x, "shiny.tag")
}
add_class <- function(x, ...) {
if (is_style_pronoun(x)) {
pronoun_add_class(x, ...)
} else if (is_pronoun_box(x)) {
pronoun_box_add_class(x, ...)
} else if (is_tag(x)) {
tag_add_class(x, ...)
}
}
pronoun_add_class <- function(x, ...) {
x$class <- paste(c(x$class, ...), collapse = " ")
splice(x)
}
pronoun_box_add_class <- function(x, ...) {
x <- unbox(x)
if (!is_style_pronoun(x)) {
abortf("unexpected pronoun box contents %s", class(x))
}
pronoun_add_class(x, ...)
}
tag_add_class <- function(x, ...) {
x$attribs$class <- paste(c(x$attribs$class, ...), collapse = " ")
x
}
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.