
is_blank <- function(x) is.null(x) || is_theme_element(x, "blank")

is_asis <- function(x) inherits(x, "AsIs")

.in2cm <- 2.54

match_self <- function(x) {
  match(x, sort(unique(x)))
}

eval_aes <- function(
  data, mapping,
  required = character(),
  optional = character(),
  call     = caller_env(),
  arg_mapping = caller_arg(mapping),
  arg_data    = caller_arg(data)
) {
  valid <- c(optional, required)
  call <- call %||% current_call()
  if (!is_mapping(mapping)) {
    cli::cli_abort(
      "{.arg {arg_mapping}} must be created by {.fn aes}.",
      call = call
    )
  }
  data <- fortify(data)

  values <- lapply(mapping, eval_tidy, data = data)
  sizes  <- list_sizes(values)
  values <- values[sizes > 0.0]

  if (!is.null(valid)) {
    extra_nms <- setdiff(names(values), valid)
    if (length(extra_nms) > 0L) {
      cli::cli_warn(
        "Ignoring unknown aesthetics: {.field {extra_nms}}.",
        call = call
      )
    }
    values <- values[intersect(names(values), valid)]
    sizes  <- list_sizes(values)
  }

  if (length(sizes) == 0L) {
    cli::cli_warn(
      "No valid data found with {.arg {arg_mapping}} in {.arg {arg_data}}.",
      call = call
    )
    return(data_frame0())
  }
  df <- data_frame0(
    !!!values, .size = max(sizes),
    .error_call = call
  )

  check_columns(df, required, arg = "key", call = call)

  df
}

`%|NA|%` <- function(x, y) {
  if (length(x) == 0L) {
    return(y)
  }
  if (length(y) == 1L) {
    x[is.na(x)] <- y
  } else {
    x[is.na(x)] <- y[is.na(x)]
  }
  x
}

get_attr <- function(x, which, default = NULL) {
  attr(x, which = which, exact = TRUE) %||% default
}

get_size_attr <- function(x, default = 0.0) {
  get_attr(x, "size", default = default)
}

get_width_attr <- function(x, default = 0.0) {
  get_attr(x, "width", default = default)
}

get_height_attr <- function(x, default = 0.0) {
  get_attr(x, "height", default = default)
}

pad <- function(x, length, fill = NA, where = "end") {
  padding <- rep(fill, length - length(x))
  switch(where, start = c(padding, x), c(x, padding))
}

rep0 <- function(x, ...) {
  if (is.null(x)) {
    return(NULL)
  }
  rep(x, ...)
}

recode <- function(x, old, new) {
  i <- match(x, old)
  skip <- is.na(i)
  x[!skip] <- new[i][!skip]
  x
}

rename <- function(df, old, new) {
  if (is.function(new)) {
    new <- new(old)
  }
  names(df) <- recode(names(df), old, new)
  df
}

.flip_names <-
  c(x = "y", y = "x", width = "height", height = "width", hjust = "vjust",
    vjust = "hjust", margin_x = "margin_y", margin_y = "margin_x",
    x1 = "y1", x2 = "y2", y1 = "x1", y2 = "x2")

flip_names <- function(x) {
  rename(x, .flip_names, names(.flip_names))
}

is_discrete <- function(x) {
  is.factor(x) || is.character(x) || is.logical(x) || is_mapped_discrete(x)
}

is_oob <- function(x, limits) {
  limits <- sort(limits)
  x < limits[1L] | x > limits[2L]
}

in_range <- function(x, range) {
  range <- sort(range)
  x >= range[1L] & x <= range[2L]
}

in_ranges <- function(x, start, end) {
  lower <- pmin(start, end)
  upper <- pmax(start, end)
  smaller <- outer(lower, x, FUN = "<")
  larger  <- outer(upper, x, FUN = ">")
  colSums(larger & smaller) > 0L
}

polar_xy <- function(data, r, theta, bbox) {
  data$x <- rescale(r * sin(theta) + 0.5, from = bbox$x)
  data$y <- rescale(r * cos(theta) + 0.5, from = bbox$y)
  data
}

scale_transform <- function(x, scale, map = FALSE, arg = caller_arg(x)) {
  if (is_discrete(x) && !scale$is_discrete()) {
    cli::cli_abort(
      "The key {.field {arg}} must be {.emph continuous}, not discrete."
    )
  }
  if (is_asis(x)) {
    return(x)
  }
  transform <- scale$get_transformation()
  if (is.null(transform)) {
    if (map) {
      x <- (scale$scale$map %||% scale$map)(x)
    }
    return(x)
  }
  x <- transform$transform(x)
  if (map) {
    x <- scale$map(x)
  }
  x
}

cm <- function(x) {
  if (!is.unit(x)) {
    return(x)
  }
  convertUnit(x, "cm", valueOnly = TRUE)
}

new_rle <- function(x) {
  rle <- vec_unrep(x)
  rle$end   <- cumsum(rle$times)
  rle$start <- rle$end - rle$times + 1L
  rle
}

suffix_position <- function(value, position) {

  aesthetic <- switch(position, left = , right = "y", "x")
  position  <- switch(position, theta = "bottom", theta.sec = "top", position)
  suffix <- paste0(".", aesthetic, ".", position)

  char <- map_lgl(value, is.character) & !map_lgl(value, is_asis)
  value[char] <- lapply(value[char], paste0, suffix)
  value
}

is_theta <- function(x) {
  if (is_missing(x) || !is.character(x)) {
    return(FALSE)
  }
  x %in% c("theta", "theta.sec")
}

# Based on example in ?vctrs::vec_chop
# It's faster than stats::ave
vec_ave <- function(x, group, fun, ...) {
  index   <- vec_group_loc(group)$loc
  chopped <- lapply(vec_chop(x, indices = index), fun, ...)
  list_unchop(chopped, indices = index)
}

by_group <- function(x, group, fun, ..., value = x[1L]) {
  index <- vec_group_loc(group)$loc
  vapply(vec_chop(x, indices = index), FUN = fun, FUN.VALUE = value, ...)
}

set_list_element <- function(x, i, value) {
  lapply(x, `[<-`, i = i, value = list(value))
}

guide_rescale <- function(
  value, from = range(value), oob = oob_squish_infinite
) {
  from <- from %||% c(0.0, 1.0)
  rescale(oob(value, from), to = c(0.0, 1.0), from)
}

map_lgl <- function(x, fun, ...) {
  vapply(x, FUN = fun, FUN.VALUE = logical(1L), ...)
}

map_dbl <- function(x, fun, ...) {
  vapply(x, FUN = fun, FUN.VALUE = numeric(1L), ...)
}

map_chr <- function(x, fun, ...) {
  vapply(x, FUN = fun, FUN.VALUE = character(1L), ...)
}

label_as_vector <- function(x) {
  if (obj_is_list(x)) {
    x[lengths(x) == 0L] <- ""
    x <- lapply(x, `[`, 1L)
  }
  if (is.expression(x)) {
    x <- as.list(x)
  }
  x
}

filter_finite <- function(x) {
  x[is.finite(x)]
}

match_list <- function(x, list) {
  findInterval(
    match(x, unlist(list, FALSE, FALSE)),
    cumsum(lengths(list)), left.open = TRUE
  ) + 1L
}

apply_theme_defaults <- function(theme, defaults = NULL) {
  if (is.null(defaults)) {
    return(theme)
  }
  theme    <- replace_null(theme, !!!defaults)
  relative <- names(defaults)[map_lgl(defaults, is_rel)]
  relative <- intersect(relative, names(theme))
  for (i in relative) {
    theme[[i]] <- theme[[i]] * unclass(defaults[[i]])
  }
  theme
}

insert_before <- function(x, i, value) {
  new <- vec_init(x, length(x) + length(i))
  i <- i + seq_along(i) - 1L
  new[i] <- value
  new[-i] <- x
  new
}

insert_after <- function(x, i, value) {
  new <- vec_init(x, length(x) + length(i))
  i <- i + seq_along(i)
  new[i] <- value
  new[-i] <- x
  new
}

extra_args <- function(..., .valid_args = c(.element_params, "theta"), call = caller_env()) {
  args <- list2(...)
  if (length(args) == 0L) {
    return(NULL)
  }
  args <- rename_aes(args, call = call)
  extra <- setdiff(names(args), .valid_args)
  if (length(extra) > 0L) {
    cli::cli_warn("Ignoring unknown parameters: {.and {extra}}.", call = call)
  }
  args <- args[lengths(args) > 0L]
  i <- names(args) != "theta"
  names(args)[i] <- paste0(".", names(args)[i])
  args
}

descale <- function(x, to = c(0.0, 1.0), from = c(0.0, 1.0)) {
  if (!is.numeric(x) || !is_asis(x)) {
    return(x)
  }
  rescale(as.numeric(x), to = to, from = from)
}

after <- function(x, i) {
  n <- length(x)
  if (i >= n) {
    return(vec_slice(x, 0L))
  }
  vec_slice(x, (i + 1L):n)
}

before <- function(x, i) {
  n <- length(x)
  if (i >= n) {
    return(x)
  }
  if (i <= 1L) {
    return(vec_slice(x, 0L))
  }
  vec_slice(x, 1L:(i - 1L))
}

idx_after  <- function(n, i) after(seq(n), i)
idx_before <- function(n, i) before(seq(n), i)

as_mapped_discrete <- function(x) {
  x <- as.numeric(x)
  class(x) <- c("mapped_discrete", class(x))
  x
}
