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
}
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.