R/utils.R

In slider: Sliding Window Functions

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
}