log10_floor <- function(x) 10^floor(log10(x))
unique_f <- function(x, eps = 1L) {
x <- vctrs::vec_cast(x, double())
prod <- outer(x, x, primitiveR::are_equal_f, eps = eps)
inds <- which(
magrittr::equals(
purrr::map_int(
vctrs::vec_seq_along(x),
~ sum(prod[1:.x, .x])
),
1L
)
)
vctrs::vec_slice(x, inds)
}
outer_unique_which <- function(x, y, eps = 1L) {
x <- vctrs::vec_cast(x, double())
y <- vctrs::vec_cast(y, double())
prod <- !outer(x, y, primitiveR::are_equal_f, eps = eps)
list(
x = which(apply(prod, 1, all)),
y = which(apply(prod, 2, all))
)
}
outer_unique <- function(x, y, eps = 1L) {
ids <- outer_unique_which(x, y, eps)
list(
x = vctrs::vec_slice(x, ids$x),
y = vctrs::vec_slice(y, ids$y)
)
}
round_interval <- function(rng, by) {
rng <- vctrs::vec_cast(rng, double())
by <- vctrs::vec_assert(
vctrs::vec_cast(by, double),
size = 1L
)
by * vctrs::vec_c(floor(rng[1] / by), ceiling(rng[2] / by))
}
locate_inrange <- function(x, range) {
test <-
if (range[1] < range[2]) {
function(x, l, r) {
x >= l & x <= r
}
} else {
function(x, l, r) {
x <= l & x >= r
}
}
tibble::tibble(
l = range,
r = dplyr::lead(range)
) %>%
dplyr::mutate(
id_l = 1L:(dplyr::n()),
id_r = .data$id_l + 1L
) %>%
dplyr::slice(-dplyr::n()) -> data
purrr::map(
x,
~ dplyr::filter(data, test(.x, l, r)) %>%
dplyr::select(.data$id_l, .data$id_r) %>%
dplyr::slice(1L) %>%
purrr::flatten_int() %>%
unname()
)
}
df_grid <- function(rows, cols, margin = FALSE) {
vars <- purrr::map(
vctrs::vec_c(
purrr::map(rows, unique),
purrr::map(cols, unique)
),
forcats::as_factor
)
if (margin) {
vars <- purrr::map(vars, vctrs::vec_c, forcats::as_factor("(all)"))
}
tidyr::expand_grid(!!!vars)
}
get_id <- function(variables) {
# `variables` is a `data.frame`
lengths <- purrr::map_int(variables, vctrs::vec_size)
vars <- dplyr::select(variables, which(lengths != 0L))
vars_len <- vctrs::vec_size(vars)
if (isTRUE(vars_len == 0L)) {
n <- vctrs::vec_size(variables)
return(structure(seq_len(n), n = n))
}
if (isTRUE(vars_len == 1L)) {
return(get_id_var(vars[[1]]))
}
ids <- rev(purrr::map(variables, get_id_var))
p <- vctrs::vec_size(ids)
ndistinct <- purrr::map_int(ids, attr, "n")
n <- prod(ndistinct)
combs <- vctrs::vec_c(1, cumprod(vctrs::vec_slice(ndistinct, -p)))
mat <- rlang::exec(cbind, !!!ids)
res <- as.vector((mat - 1L) %*% combs + 1L)
attr(res, "n") <- n
get_id_var(res)
}
get_id_var <- function(x) {
if (isTRUE(vctrs::vec_size(x) == 0)) {
return(structure(integer(), n = 0L))
}
levels <- sort(unique(x), na.last = TRUE)
id <- match(x, levels)
n <- max(id)
structure(id, n = n)
}
adjust_angle <- function(x, by = 180) {
for (i in seq_len(length(x$children))) {
x$children[[i]]$rot <- x$children[[i]]$rot + by
}
x
}
split_ex <- function(.data, col, name = NULL, keep = FALSE) {
content <- dplyr::pull(.data, {{ col }})
content <- vctrs::vec_recycle_common(!!!content)
size <- vctrs::vec_size_common(!!!content)
transposed <- purrr::map(seq_len(size), ~ purrr::map(content, .x))
result <- purrr::map(transposed, ~ vctrs::vec_c(!!!.x))
if (rlang::is_null(name) || rlang::is_empty(name)) {
names <- paste0("Split_", seq_len(size))
} else {
names <- paste0(name, "_", seq_len(size))
}
result <- dplyr::bind_cols(rlang::set_names(result, names))
if (!keep) {
.data <- dplyr::select(.data, -{{ col }})
}
dplyr::bind_cols(.data, result)
}
#' @export
empty_labels <- function() {
empty_seq
}
empty_seq <- function(x) {
vctrs::vec_repeat(" ", vctrs::vec_size(x))
}
#' Linearly interpolate [grid::unit]
#'
#' Performs a linear interpolation in the unit space.
#' @param x0 \[`double(n)`\] Interpolation points.
#' @param x \[`double(2)`\] Two boundary points for interpoaltion,
#' such that `x[1] <= x0 <= x[2]`.
#' @param y \[`grid::unit(2)`\] Values at boundary points.
#' @return \[`grid::unit(n)`\] Interpolated unit values.
#' @export
lin_unit <- function(x0, x, y) {
x0 <- vctrs::vec_cast(x0, double())
x <- vctrs::vec_assert(
vctrs::vec_cast(x, double()),
size = 2L
)
assertthat::assert_that(isTRUE(length(y) == 2L))
dx <- x[2] - x[1]
dy <- y[2] - y[1]
purrr::map(x0, ~ y[1] + dy / dx * (.x - x[1])) -> result
if (grid::is.unit(y)) {
rlang::exec(grid::unit.c, !!!result)
} else {
vctrs::vec_cast(result, vctrs::vec_ptype_common(!!!result))
}
}
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.