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
}