is_unbounded <- function(x) {
identical(x, Inf)
}
slider_check_list <- function(x,
arg = caller_arg(x),
call = caller_env()) {
out <- slider_compat_list(x)
vec_check_list(out, arg = arg, call = call)
out
}
slider_compat_list <- function(x) {
if (is.data.frame(x)) {
# For compatibility, `pslide()`, `phop()`, and friends allow data frames
slider_new_list(x)
} else {
x
}
}
slider_new_list <- function(x) {
if (!is_list(x)) {
abort("`x` must be a VECSXP.", .internal = TRUE)
}
names <- names(x)
if (is.null(names)) {
attributes(x) <- NULL
} else {
attributes(x) <- list(names = names)
}
x
}
# Thrown to here from C
stop_not_all_size_one <- function(iteration, size) {
message <- c(
"i" = cli::format_inline("In index: {iteration}"),
"!" = cli::format_inline("The result of `.f` must have size 1, not {size}.")
)
# TODO: Use correct `call` passed through C
abort(message, call = NULL)
}
# Thrown to here from C
stop_slide_start_past_stop <- function(starts, stops) {
start_after_stop <- vec_compare(starts, stops) == 1L
locations <- which(start_after_stop)
message <- c(
"i" = cli::format_inline("In locations: {locations}"),
"i" = "In the ranges generated by `.before` and `.after`:",
"!" = "The start of the range can't be after the end of the range."
)
# TODO: Use correct `call` passed through C
abort(message, call = NULL)
}
# Thrown to here from C
stop_hop_start_past_stop <- function(starts, stops) {
start_after_stop <- vec_compare(starts, stops) == 1L
locations <- which(start_after_stop)
message <- c(
"i" = cli::format_inline("In locations: {locations}"),
"i" = "In the ranges generated by `.starts` and `.stops`:",
"!" = "The start of the range can't be after the end of the range."
)
# TODO: Use correct `call` passed through C
abort(message, call = NULL)
}
compute_size <- function(x, type) {
SLIDE <- -1L
PSLIDE_EMPTY <- 0L
if (type == SLIDE) {
vec_size(x)
} else if (type == PSLIDE_EMPTY) {
0L
} else {
vec_size(x[[1L]])
}
}
# Unconditionally use only the names from `.x` on the output when simplifying.
# Ensures that the following are aligned:
#
# slide_vec(c(x = 1), ~c(y = 2))
# purrr::map_dbl(c(x = 1), ~c(y = 2))
#
# slide_vec(1, ~c(y = 2))
# purrr::map_dbl(1, ~c(y = 2))
vec_simplify <- function(x,
ptype,
error_arg = caller_arg(x),
error_call = caller_env()) {
names <- vec_names(x)
unnamed <- vec_set_names(x, NULL)
out <- list_unchop(
x = unnamed,
ptype = ptype,
error_arg = error_arg,
error_call = error_call
)
vec_set_names(out, names)
}
compute_combined_ranks <- function(...) {
args <- list2(...)
# TODO: Ideally we'd set `name_spec = zap()` to drop names from both `args`
# and its elements for performance, but that doesn't work for non-vctrs types.
# https://github.com/r-lib/vctrs/issues/1106
combined <- list_unchop(unname(args))
# Expected that there are no missing values in `combined`.
# Incomplete rows do get ranked, with missing values coming last.
ranks <- vec_rank(combined, ties = "dense")
n_args <- length(args)
sizes <- list_sizes(args)
indices <- vector("list", n_args)
current_start <- 1L
for(i in seq_len(n_args)) {
next_start <- current_start + sizes[[i]]
current_stop <- next_start - 1L
indices[[i]] <- seq2(current_start, current_stop)
current_start <- next_start
}
out <- vec_chop(ranks, indices)
names(out) <- names(args)
out
}
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.