R/utils.R

Defines functions slider_dense_rank compute_combined_ranks vec_simplify compute_size stop_hop_start_past_stop stop_slide_start_past_stop stop_not_all_size_one check_is_list is_unbounded collapse_and_trim

glubort <- function (..., .sep = "", .envir = parent.frame()) {
  abort(glue::glue(..., .sep = .sep, .envir = .envir))
}

collapse_and_trim <- function(x) {
  glue::glue_collapse(x, sep = ", ", width = 30L)
}

is_unbounded <- function(x) {
  identical(x, Inf)
}

check_is_list <- function(.l) {
  if (!is.list(.l)) {
    abort(paste0("`.l` must be a list, not ", vec_ptype_full(.l), "."))
  }

  invisible(.l)
}

stop_not_all_size_one <- function(iteration, size) {
  glubort("In iteration {iteration}, the result of `.f` had size {size}, not 1.")
}

# Thrown to here from C
stop_slide_start_past_stop <- function(starts, stops) {
  start_after_stop <- vec_compare(starts, stops) == 1L

  at <- which(start_after_stop)
  at <- collapse_and_trim(at)

  msg <- paste0(
    "In the ranges generated by `.before` and `.after`, ",
    "the start of the range is after the end of the range at location(s): {at}."
  )

  glubort(msg)
}

# Thrown to here from C
stop_hop_start_past_stop <- function(starts, stops) {
  start_after_stop <- vec_compare(starts, stops) == 1L

  at <- which(start_after_stop)
  at <- collapse_and_trim(at)

  msg <- paste0(
    "In the ranges generated by `.starts` and `.stops`, ",
    "a start is after a stop at location(s): {at}."
  )

  glubort(msg)
}

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) {
  names <- vec_names(x)
  x <- vec_set_names(x, NULL)

  out <- vec_unchop(x, ptype = ptype)

  vec_set_names(out, names)
}

compute_combined_ranks <- function(...) {
  args <- list2(...)
  combined <- vec_c(!!!args, .name_spec = zap())

  ranks <- slider_dense_rank(combined)

  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
}

# TODO: Replace with `vec_rank(x, ties = "dense")`
# https://github.com/r-lib/vctrs/issues/1251
#
# This impl is taken from `dplyr::dense_rank()`.
# Expected that there are no missing values in `x`.
slider_dense_rank <- function(x) {
  vec_match(x, vec_sort(vec_unique(x)))
}
DavisVaughan/slurrr documentation built on July 5, 2021, 12:06 a.m.