R/conditions.R

In DavisVaughan/slurrr: Sliding Window Functions

check_index_incompatible_type <- function(i, i_arg = "i") {
  is_datelike <- inherits(i, c("Date", "POSIXt"))

  if (is_datelike) {
    return(invisible(i))
  }

  stop_index_incompatible_type(i, i_arg)
}

stop_index_incompatible_type <- function(i, i_arg = "i") {
  stop_index(
    i_class = class(i),
    i_arg = i_arg,
    class = "slider_error_index_incompatible_type"
  )
}

#' @export
cnd_header.slider_error_index_incompatible_type <- function(cnd, ...) {
  glue_data(cnd, "`{i_arg}` has an incorrect type.")
}

#' @export
cnd_body.slider_error_index_incompatible_type <- function(cnd, ...) {
  glue_data_bullets(
    cnd,
    x = "It must inherit from Date, POSIXct, or POSIXlt, not {paste0(i_class, collapse = '/')}."
  )
}

# ------------------------------------------------------------------------------

check_endpoints_must_be_ascending <- function(endpoints, endpoints_arg) {
  locations <- compute_non_ascending_locations(endpoints)

  if (identical(locations, integer())) {
    return(invisible(endpoints))
  }

  stop_endpoints_must_be_ascending(locations, endpoints_arg)
}

stop_endpoints_must_be_ascending <- function(locations, endpoints_arg) {
  stop_endpoints(
    locations = locations,
    endpoints_arg = endpoints_arg,
    class = "slider_error_endpoints_must_be_ascending"
  )
}

#' @export
cnd_header.slider_error_endpoints_must_be_ascending <- function(cnd, ...) {
  glue_data(cnd, "`{endpoints_arg}` must be in ascending order.")
}

#' @export
cnd_body.slider_error_endpoints_must_be_ascending <- function(cnd, ...) {
  glue_data_bullets(
    cnd,
    i = "It is not ascending at locations: {collapse_locations(locations)}."
  )
}

# ------------------------------------------------------------------------------

check_generated_endpoints_cannot_be_na <- function(endpoints, by_arg) {
  na_indicators <- vec_equal_na(endpoints)

  if (any(na_indicators)) {
    na_locations <- which(na_indicators)
    stop_generated_endpoints_cannot_be_na(na_locations, by_arg)
  }

  invisible(endpoints)
}

stop_generated_endpoints_cannot_be_na <- function(locations, by_arg) {
  stop_endpoints(
    locations = locations,
    by_arg = by_arg,
    class = "slider_error_generated_endpoints_cannot_be_na"
  )
}

#' @export
cnd_header.slider_error_generated_endpoints_cannot_be_na <- function(cnd, ...) {
  glue_data(cnd, "Endpoints generated by `{by_arg}` cannot be `NA`.")
}

#' @export
cnd_body.slider_error_generated_endpoints_cannot_be_na <- function(cnd, ...) {
  glue_data_bullets(
    cnd,
    i = "They are `NA` at locations: {collapse_locations(locations)}."
  )
}

# ------------------------------------------------------------------------------

check_generated_endpoints_must_be_ascending <- function(endpoints, by_arg) {
  locations <- compute_non_ascending_locations(endpoints)

  if (identical(locations, integer())) {
    return(invisible(endpoints))
  }

  stop_generated_endpoints_must_be_ascending(locations, by_arg)
}

stop_generated_endpoints_must_be_ascending <- function(locations, by_arg) {
  stop_endpoints(
    locations = locations,
    by_arg = by_arg,
    class = "slider_error_generated_endpoints_must_be_ascending"
  )
}

#' @export
cnd_header.slider_error_generated_endpoints_must_be_ascending <- function(cnd, ...) {
  glue_data(cnd, "Endpoints generated by `{by_arg}` must be in ascending order.")
}

#' @export
cnd_body.slider_error_generated_endpoints_must_be_ascending <- function(cnd, ...) {
  glue_data_bullets(
    cnd,
    i = "They are not ascending at locations: {collapse_locations(locations)}."
  )
}

# ------------------------------------------------------------------------------

check_generated_endpoints_incompatible_size <- function(endpoints, size, by_arg) {
  endpoints_size <- vec_size(endpoints)

  if (endpoints_size == size) {
    return(invisible(endpoints))
  }

  stop_generated_endpoints_incompatible_size(endpoints_size, size, by_arg)
}

stop_generated_endpoints_incompatible_size <- function(endpoints_size, size, by_arg) {
  stop_endpoints(
    endpoints_size = endpoints_size,
    size = size,
    by_arg = by_arg,
    class = "slider_error_generated_endpoints_incompatible_size"
  )
}

#' @export
cnd_header.slider_error_generated_endpoints_incompatible_size <- function(cnd, ...) {
  glue_data(cnd, "Endpoints generated by `{by_arg}` have an incorrect size.")
}

#' @export
cnd_body.slider_error_generated_endpoints_incompatible_size <- function(cnd, ...) {
  glue_data_bullets(
    cnd,
    i = "They must have size {size}, not {endpoints_size}."
  )
}

# ------------------------------------------------------------------------------

check_endpoints_cannot_be_na <- function(endpoints, endpoints_arg) {
  na_indicators <- vec_equal_na(endpoints)

  if (any(na_indicators)) {
    na_locations <- which(na_indicators)
    stop_endpoints_cannot_be_na(na_locations, endpoints_arg)
  }

  invisible(endpoints)
}

stop_endpoints_cannot_be_na <- function(locations, endpoints_arg) {
  stop_endpoints(
    locations = locations,
    endpoints_arg = endpoints_arg,
    class = "slider_error_endpoints_cannot_be_na"
  )
}

#' @export
cnd_header.slider_error_endpoints_cannot_be_na <- function(cnd, ...) {
  glue_data(cnd, "`{endpoints_arg}` cannot be `NA`.")
}

#' @export
cnd_body.slider_error_endpoints_cannot_be_na <- function(cnd, ...) {
  glue_data_bullets(
    cnd,
    i = "It is `NA` at locations: {collapse_locations(locations)}."
  )
}

# ------------------------------------------------------------------------------

check_index_must_be_ascending <- function(i, i_arg = "i") {
  locations <- compute_non_ascending_locations(i)

  if (identical(locations, integer())) {
    return(invisible(i))
  }

  stop_index_must_be_ascending(locations, i_arg)
}

stop_index_must_be_ascending <- function(locations, i_arg = "i") {
  stop_index(
    locations = locations,
    i_arg = i_arg,
    class = "slider_error_index_must_be_ascending"
  )
}

#' @export
cnd_header.slider_error_index_must_be_ascending <- function(cnd, ...) {
  glue_data(cnd, "`{i_arg}` must be in ascending order.")
}

#' @export
cnd_body.slider_error_index_must_be_ascending <- function(cnd, ...) {
  glue_data_bullets(
    cnd,
    i = "It is not ascending at locations: {collapse_locations(locations)}."
  )
}

# ------------------------------------------------------------------------------

check_index_cannot_be_na <- function(i, i_arg = "i") {
  na_indicators <- vec_equal_na(i)

  if (any(na_indicators)) {
    na_locations <- which(na_indicators)
    stop_index_cannot_be_na(na_locations, i_arg)
  }

  invisible(i)
}

stop_index_cannot_be_na <- function(locations, i_arg = "i") {
  stop_index(
    locations = locations,
    i_arg = i_arg,
    class = "slider_error_index_cannot_be_na"
  )
}

#' @export
cnd_header.slider_error_index_cannot_be_na <- function(cnd, ...) {
  glue_data(cnd, "`{i_arg}` cannot be `NA`.")
}

#' @export
cnd_body.slider_error_index_cannot_be_na <- function(cnd, ...) {
  glue_data_bullets(
    cnd,
    i = "It is `NA` at locations: {collapse_locations(locations)}."
  )
}

# ------------------------------------------------------------------------------

stop_index_incompatible_size <- function(i_size, size, i_arg = "i") {
  stop_index(
    i_size = i_size,
    size = size,
    i_arg = i_arg,
    class = "slider_error_index_incompatible_size"
  )
}

#' @export
cnd_header.slider_error_index_incompatible_size <- function(cnd, ...) {
  glue_data(cnd, "`{i_arg}` has an incorrect size.")
}

#' @export
cnd_body.slider_error_index_incompatible_size <- function(cnd, ...) {
  glue_data_bullets(cnd, x = "It must have size {size}, not {i_size}.")
}

# ------------------------------------------------------------------------------

stop_endpoints <- function(message = NULL, class = character(), ...) {
  stop_slider(message, class = c(class, "slider_error_endpoints"), ...)
}

# ------------------------------------------------------------------------------

stop_index <- function(message = NULL, class = character(), ...) {
  stop_slider(message, class = c(class, "slider_error_index"), ...)
}

# ------------------------------------------------------------------------------

stop_slider <- function(message = NULL, class = character(), ...) {
  abort(message, class = c(class, "slider_error"), ...)
}

# ------------------------------------------------------------------------------

collapse_locations <- function(locations) {
  glue_collapse(locations, sep = ", ", width = 30L)
}

glue_data_bullets <- function (.data, ..., .env = caller_env()) {
  glue_data_env <- function(...) glue_data(.data, ..., .envir = .env)
  format_error_bullets(map_chr(chr(...), glue_data_env))
}

map_chr <- function(x, f) {
  vapply(x, f, character(1))
}

is_sorted <- function(x) {
  !is.unsorted(x)
}

compute_non_ascending_locations <- function(x) {
  order <- vec_order(x, direction = "asc")

  if (is_sorted(order)) {
    return(integer())
  }

  problems <- which(diff(order) < 0L)
  locations <- order[problems]

  locations
}