R/conditions.R

In DavisVaughan/slurrr: Sliding Window Functions

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

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

  stop_index_incompatible_type(i, i_arg = i_arg, call = call)
}

stop_index_incompatible_type <- function(i, i_arg = "i", call = caller_env()) {
  message <- cli::format_inline(
    "{.arg {i_arg}} must be a {.cls Date}, {.cls POSIXct}, or {.cls POSIXlt}, ",
    "not {.obj_type_friendly {i}}."
  )

  stop_index(
    message = message,
    call = call,
    class = "slider_error_index_incompatible_type"
  )
}

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

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

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

  stop_endpoints_must_be_ascending(
    locations = locations,
    endpoints_arg = endpoints_arg,
    call = call
  )
}

stop_endpoints_must_be_ascending <- function(
  locations,
  endpoints_arg,
  call = caller_env()
) {
  message <- c(
    "i" = cli::format_inline("In locations: {locations}"),
    "!" = cli::format_inline(
      "{.arg {endpoints_arg}} must be in ascending order."
    )
  )

  stop_endpoints(
    message = message,
    call = call,
    class = "slider_error_endpoints_must_be_ascending"
  )
}

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

check_generated_endpoints_cannot_be_na <- function(
  endpoints,
  by_arg,
  call = caller_env()
) {
  if (!vec_any_missing(endpoints)) {
    return(invisible(endpoints))
  }

  indicators <- vec_detect_missing(endpoints)
  locations <- which(indicators)

  stop_generated_endpoints_cannot_be_na(
    locations = locations,
    by_arg = by_arg,
    call = call
  )
}

stop_generated_endpoints_cannot_be_na <- function(
  locations,
  by_arg,
  call = caller_env()
) {
  message <- c(
    "i" = cli::format_inline("In locations: {locations}"),
    "!" = cli::format_inline(
      "Endpoints generated by {.arg {by_arg}} can't be {.code NA}."
    )
  )

  stop_endpoints(
    message = message,
    call = call,
    class = "slider_error_generated_endpoints_cannot_be_na"
  )
}

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

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

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

  stop_generated_endpoints_must_be_ascending(
    locations = locations,
    by_arg = by_arg,
    call = call
  )
}

stop_generated_endpoints_must_be_ascending <- function(
  locations,
  by_arg,
  call = caller_env()
) {
  message <- c(
    "i" = cli::format_inline("In locations: {locations}"),
    "!" = cli::format_inline(
      "Endpoints generated by {.arg {by_arg}} must be in ascending order."
    )
  )

  stop_endpoints(
    message = message,
    call = call,
    class = "slider_error_generated_endpoints_must_be_ascending"
  )
}

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

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

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

  stop_generated_endpoints_incompatible_size(
    endpoints_size = endpoints_size,
    size = size,
    by_arg = by_arg,
    call = call
  )
}

stop_generated_endpoints_incompatible_size <- function(
  endpoints_size,
  size,
  by_arg,
  call = caller_env()
) {
  message <- cli::format_inline(
    "Endpoints generated by {.arg {by_arg}} must have size {size}, not {endpoints_size}."
  )

  stop_endpoints(
    message = message,
    call = call,
    class = "slider_error_generated_endpoints_incompatible_size"
  )
}

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

check_endpoints_cannot_be_na <- function(
  endpoints,
  endpoints_arg,
  call = caller_env()
) {
  if (!vec_any_missing(endpoints)) {
    return(invisible(endpoints))
  }

  indicators <- vec_detect_missing(endpoints)
  locations <- which(indicators)

  stop_endpoints_cannot_be_na(
    locations = locations,
    endpoints_arg = endpoints_arg,
    call = call
  )
}

stop_endpoints_cannot_be_na <- function(
  locations,
  endpoints_arg,
  call = caller_env()
) {
  message <- c(
    "i" = cli::format_inline("In locations: {locations}"),
    "!" = cli::format_inline("{.arg {endpoints_arg}} can't be {.code NA}.")
  )

  stop_endpoints(
    message = message,
    call = call,
    class = "slider_error_endpoints_cannot_be_na"
  )
}

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

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

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

  stop_index_must_be_ascending(locations, i_arg = i_arg, call = call)
}

stop_index_must_be_ascending <- function(
  locations,
  i_arg = "i",
  call = caller_env()
) {
  message <- c(
    "i" = cli::format_inline("In locations: {locations}"),
    "!" = cli::format_inline("{.arg {i_arg}} must be in ascending order.")
  )

  stop_index(
    message = message,
    call = call,
    class = "slider_error_index_must_be_ascending"
  )
}

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

check_index_cannot_be_na <- function(i, i_arg = "i", call = caller_env()) {
  if (!vec_any_missing(i)) {
    return(invisible(i))
  }

  na_indicators <- vec_detect_missing(i)
  na_locations <- which(na_indicators)

  stop_index_cannot_be_na(na_locations, i_arg = i_arg, call = call)
}

stop_index_cannot_be_na <- function(
  locations,
  i_arg = "i",
  call = caller_env()
) {
  message <- c(
    "i" = cli::format_inline("In locations: {locations}"),
    "!" = cli::format_inline("{.arg {i_arg}} can't be {.code NA}.")
  )

  stop_index(
    message = message,
    call = call,
    class = "slider_error_index_cannot_be_na"
  )
}

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

stop_index_incompatible_size <- function(
  i_size,
  size,
  i_arg = "i",
  call = caller_env()
) {
  message <- cli::format_inline(
    "{.arg {i_arg}} must have size {size}, not {i_size}."
  )

  stop_index(
    message = message,
    call = call,
    class = "slider_error_index_incompatible_size"
  )
}

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

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

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

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

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

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

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

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 <- vec_sort(locations)

  locations
}