R/helpers.R

In ElianHugh/emitters: NodeJS-inspired events and io streams.

`%nin%` <- Negate(`%in%`)

is_truthy <- function(x) {
    return(
        any(!is.null(x)) &&
            any(!is.na(x)) &&
            any(!inherits(x, "try-error")) &&
            length(x) > 0 &&
            any(nzchar(x))
    )
}

is_falsey <- Negate(is_truthy)

prepend <- function(x, values) {
    return(append(x, values, 0))
}

wait_for_change <- function(value, start_value = "", env = parent.frame(1), timeout = 30L) {
    start_time <- Sys.time()
    while (identical(get(value, envir = env), start_value)) {
        if (difftime(Sys.time(), start_time, "secs") > timeout) {
            stop("Change did not occur within time limit")
        }
        later::run_now(
            0L,
            all = TRUE,
            loop = later::global_loop()
        )
    }
}

guesstimate_size <- function(source_object) {
    if (is.data.frame(source_object)) {
        nrow(source_object)
    } else if (is.list(source_object)) {
        ifelse(length(source_object) > 0, length(source_object), 20)
    } else {
        20 # sane default
    }
}

set_highwater <- function(highwater_mark, queue_strategy) {
     if (!is.null(highwater_mark)) {
         pretty_stopifnot(
             "highwater_mark must be a numeric vector",
             sprintf("highwater_mark is of class '%s'", class(highwater_mark)),
             is.numeric(highwater_mark)
         )
         highwater_mark
     } else if (identical(queue_strategy, length)) {
         1 # what is a sensible object length?
         # todo, change to an option
     } else {
         16 * 1024 # todo, change to an option
     }
}


store_errors <- function() {
     assign(
        "last_error",
         rlang::trace_back(
            top = rlang::caller_env(10),
            bottom = 2
        ),
        envir = asNamespace("emitters")
     )
}

splice_element <- function(array, element) {
    Filter(
        function(x) !identical(x, element),
        array
    )
}

set_function <- function(fn, envir = rlang::caller_env()) {
    fn <- fn
    environment(fn) <- envir
    fn
}