Nothing
which0 <- function(x) {
which(x) %len% 0L
}
# isTRUE, isFALSE, ...
isNA <- function(x) { # nolint: object_name_linter.
is.logical(x) && length(x) == 1L && is.na(x)
}
# modified from https://github.com/tidyverse/purrr/blob/5aca9df41452f272fcef792dbc6d584be8be7167/R/utils.R # nolint: line_length_linter.
use_color <- function() {
rn("crayon") && crayon::has_color()
}
# nolint start: brace_linter.
crayon_blue <- function(x) { if (use_color()) crayon::blue(x) else x }
crayon_green <- function(x) { if (use_color()) crayon::green(x) else x }
crayon_cyan <- function(x) { if (use_color()) crayon::cyan(x) else x }
# nolint end: brace_linter.
#' Parse and evaluate text
#'
#' A wrapper for eval(parse(text = .))
#'
#' @param x A character string to parse
#' @param envir The environment in which to evaluate the code
#' @return The evaluation of `x` after parsing
#' @export
ept <- function(x, envir = parent.frame()) {
eval(parse(text = x), envir = envir)
}
# Removes object's attributes before printing
print_no_attr <- function(x, ...) {
print(remove_attributes(x)) # nocovr
}
#' That
#'
#' Grammatical correctness
#'
#' @details
#' See `fortunes::fortune(175)`.
#'
#' @inheritParams base::which
#' @return see [base::which()]
#'
#' @export
#' @seealso [base::which()]
that <- function(x, arr.ind = FALSE, useNames = TRUE) { # nolint: object_name_linter, line_length_linter.
# TODO consider that() as #seq_along(x)[x]?
which(x, arr.ind = arr.ind, useNames = useNames)
}
#' Length checkers
#'
#' Checks lengths
#'
#' @description
#' Several length checks exist:
#'
#' * `is_length0`: Not `NULL` but is length `0`
#' * `no_length`: Length of `0`
#' * `has_length`: Length is not `0`
#'
#' _NB_: `length(NULL)` is `0`
#'
#' @param x A vector
#' @name length_check
#' @noRd
is_length0 <- function(x) {
!is.null(x) && no_length(x)
}
#' @rdname length_check
#' @noRd
no_length <- function(x) {
length(x) == 0L
}
#' @rdname length_check
#' @noRd
has_length <- function(x) {
!no_length(x)
}
is_unique <- function(x) {
anyDuplicated(x) == 0L
}
is_atomic0 <- function(x) {
is.atomic(x) && !is.null(x)
}
# nolint start: brace_linter.
cat0 <- function(...) { cat(..., sep = "") }
catln <- function(...) { cat(..., sep = "\n") }
charexpr <- function(x) { as.character(as.expression(x)) }
# nolint end: brace_linter.
mark_temp <- function(ext = "") {
if (!grepl("^[.]", ext) && !identical(ext, "") && !is.na(ext)) {
ext <- paste0(".", ext)
}
# Retrieves the outer most function this was called in and save the raw
# components to be converted when needed
sn <- sys.nframe()
oc <- outer_call(sn - 2L)
oc <- substr(oc, 1, 40)
oc <- collapse0(iconv(oc, toRaw = TRUE)[[1]])
oc <- paste0(oc, "__")
norm_path(tempfile(oc, fileext = ext))
}
check_is_vector <- function(x, mode = "any") {
if (
isS4(x) ||
inherits(x, c("data.frame", "matrix", "array")) ||
!is.vector(remove_attributes(x), mode)
) {
x <- deparse1(substitute(x))
stop(cond_check_is_vector_mode(x, mode))
}
invisible()
}
cond_check_is_vector_mode <- function(x, mode) {
new_condition(
paste(x, "must be a vector of mode", mode),
"check_is_vector_mode"
)
}
add_attributes <- function(x, ...) {
attributes(x) <- c(attributes(x), rlang::list2(...))
x
}
remove_attributes <- function(x, attr = NULL) {
if (is.null(attr)) {
attributes(x) <- NULL
} else {
a <- attributes(x)
attributes(x) <- a[names(a) %wo% attr]
}
x
}
add_class <- function(x, cl, pos = 1L) {
class(x) <- append0(class(x), cl, pos = pos)
x
}
remove_class <- function(x, cl = NULL) {
if (is.null(cl)) {
class(x) <- NULL
} else {
class(x) <- class(x) %wo% cl
}
x
}
check_interactive <- function() {
op <- getOption("mark.check_interactive", TRUE)
if (isTRUE(op)) {
return(interactive())
}
if (isFALSE(op)) {
return(TRUE)
}
if (isNA(op)) {
return(FALSE)
}
stop(cond_check_interactive())
}
cond_check_interactive <- function() {
new_condition(
"mark.check_interactive must be TRUE, FALSE, or NA",
"check_interactive"
)
}
try_formats <- function(date = FALSE) {
x <- c(
"%Y-%m-%d %H:%M:%OS",
"%Y/%m/%d %H:%M:%OS",
"%Y-%m-%d %H %M %S",
"%Y %m %d %H %M %S",
"%Y-%m-%d %H%M%S",
"%Y %m %d %H%M%S",
"%Y%m%d %H %M %S",
"%Y%m%d %H%M%S",
NULL
)
c(x, if (date) c("%Y-%m-%d", "%Y/%m/%d", "%Y%m%d"))
}
has_char <- function(x) {
if (!is.character(x)) {
return(rep.int(FALSE, length(x)))
}
!is.na(x) & nzchar(x, keepNA = TRUE)
}
dupe_check <- function(x, n = getOption("mark.dupe.n", 5)) {
n <- as.integer(n)
dupes <- which(duplicated(x))
n_dupes <- length(dupes)
dupes <- utils::head(dupes, n)
if (n_dupes) {
stop(cond_dupe_check(x, dupes, n_dupes, n))
}
invisible(NULL)
}
cond_dupe_check <- function(x, dupes, n_dupes, n) {
msg <- paste0(
"Duplicate values found in ", n_dupes, " location(s) :\n",
if (n_dupes > n) sprintf("(first %i)\n", n),
paste0(" > ", sprintf("[%s] %s", format(dupes), format(x[dupes])), "\n"),
if (n_dupes > n) "... and ", n_dupes - n, " more"
)
new_condition(msg, "dupe_check")
}
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.