# Constructor -------------------------------------------------------------

#' Guide primitives: boxes
#'
#' This function constructs a boxes [guide primitive][guide-primitives].
#'
#' @inheritParams primitive_bracket
#' @param min_size A [`<grid::unit[1]>`][grid::unit] setting the minimal size
#'   of a box.
#' @param levels_box A list of `<element_rect>` objects to customise how
#'   boxes appear at every level.
#'
#' @return A `<PrimitiveBox>` primitive guide that can be used inside other
#'   guides.
#' @family primitives
#' @export
#'
#' @details
#' ## Styling options
#'
#' Below are the [theme][ggplot2::theme] options that determine the styling of
#' this guide, which may differ depending on whether the guide is used in
#' an axis or in a legend context.
#'
#' The possible `{position}` suffixes mentioned below are `x`, `x.top`,
#' `x.bottom`, `y`, `y.left`, `y.right`. The `theta` and `r` position suffixes
#' in \pkg{ggplot2} are *not* obeyed in \pkg{legendry}.
#'
#' | **Theme setting** | **Context** | **Type** | **Description** |
#' | ----------------- | ----------- | -------- | --------------- |
#' | `legendry.box` | Both | [`element_rect()`] | The boxes themselves |
#' | `axis.text.{position}`\* | Axis | [`element_text()`] | The text in the boxes. |
#' | `legend.text` | Legend | [`element_text()`] | The text in the boxes. |
#'
#' Styling options *per level* can be set in the `levels_box` and `levels_text`
#' arguments. These override theme settings.
#'
#' Styling options *per range* can be set in the [range key][key_range].
#' The `rect` and `text` prefixed properties are prioritised for the boxes and
#' text respectively. These override theme settings and 'per level' settings.
#'
#' The context-agnostic alternative to using `theme()` is to use
#' [`theme_guide()`]:
#'
#' ```r
#' primitive_box(theme = theme_guide(
#'   box = element_rect(),
#'   text = element_text()
#' ))
#' ```
#'
#' @examples
#' # A standard plot
#' p <- ggplot(mpg, aes(interaction(drv, year), displ)) +
#'  geom_point()
#'
#' key <- key_range_manual(c(2, 4), c(5, 6), c("A", "B"))
#'
#' # Adding as secondary guides
#' p + guides(
#'   x.sec = primitive_box(),
#'   y.sec = primitive_box(key = key)
#' )
primitive_box <- function(
  key = "range_auto",
  angle = waiver(),
  oob = "squish",
  drop_zero = TRUE,
  pad_discrete = 0.4,
  min_size = NULL,
  levels_box = NULL,
  levels_text = NULL,
  theme = NULL,
  position = waiver()
) {

  key <- resolve_key(key)
  oob <- arg_match0(oob, c("squish", "censor", "none"))
  check_bool(drop_zero)
  check_number_decimal(pad_discrete, allow_infinite = FALSE)
  check_list_of(
    levels_box, element_classes("rect", "blank"),
    allow_null = TRUE
  )
  check_list_of(
    levels_text, element_classes("text", "blank"),
    allow_null = TRUE
  )

  new_guide(
    key = key,
    oob = oob,
    angle = angle,
    drop_zero = drop_zero,
    pad_discrete = pad_discrete,
    min_size = min_size,
    levels_box = levels_box,
    levels_text = levels_text,
    theme = theme,
    position = position,
    available_aes = c("any", "x", "y", "r", "theta"),
    super = PrimitiveBox
  )
}

# Class -------------------------------------------------------------------

#' @export
#' @rdname legendry_extensions
#' @format NULL
#' @usage NULL
PrimitiveBox <- ggproto(
  "PrimitiveBox", Guide,

  hashables = exprs(key, decor),

  params = new_params(
    key = NULL, oob = "squish", drop_zero = TRUE,
    pad_discrete = 0.4, angle = waiver(), min_size = NULL,
    levels_text = NULL, levels_box = NULL
  ),

  elements = list(
    position = list(text = "axis.text",   box = I("legendry.box")),
    legend   = list(text = "legend.text", box = I("legendry.box"))
  ),

  extract_key = range_extract_key,

  extract_params = extract_range_params,

  extract_decor = function(scale, aesthetic, key, ...) {
    key <- vec_slice(key, key$.draw)
    decor <- key[setdiff(names(key), c("start", "end"))]
    decor$group <- seq_len(nrow(key))
    decor <- vec_rep_each(decor, 2)
    decor[[aesthetic]] <- vec_interleave(key$start, key$end)
    decor
  },

  transform = function(self, params, coord, panel_params) {
    params$key <-
      transform_key(params$key, params$position, coord, panel_params)
    params$bbox <- panel_params$bbox %||% list(x = c(0.0, 1.0), y = c(0.0, 1.0))
    if (!is_empty(params$decor)) {
      other <-
        switch(params$position, bottom = , left = , theta.sec = -Inf, Inf)
      params$decor <- replace_null(params$decor, x = other, y = other)
      params$decor <- coord_munch(coord, params$decor, panel_params)
      if (params$position == "theta.sec") {
        params$decor$theta <- params$decor$theta + pi
      }
    }
    params
  },

  setup_params = setup_range_params,

  setup_elements = primitive_setup_elements,

  build_box = function(key, decor, elements, params) {

    levels   <- unique(c(key$.level, decor$.level))
    nlevels  <- length(levels)
    position <- params$position

    # Recycle custom elements per level to appropriate length
    box_levels  <- rep0(params$levels_box,  length.out = nlevels)
    text_levels <- rep0(params$levels_text, length.out = nlevels)

    # Justify labels along their ranges
    key <- justify_ranges(key, levels, elements$text, text_levels)

    if (is_theta(position)) {
      add <- if (position == "theta.sec") pi else 0.0
      key <- polar_xy(key, key$r, key$theta + add, params$bbox)
    }

    grobs  <- vector("list", nlevels)
    offset <- elements$offset
    angle  <- params$angle %|W|% NULL
    min_size <- cm(params$min_size %||% 0.2)
    sizes <- numeric(nlevels)
    text  <- angle_labels(elements$text, angle, position)

    measure <- switch(
      position,
      left = , right = width_cm,
      top = , bottom = height_cm,
      get_size_attr
    )

    for (i in seq_len(nlevels)) {

      # Render text
      labels <- draw_labels(
        vec_slice(key, key$.level == levels[[i]]),
        combine_elements(text_levels[[i]], text),
        angle = angle, offset = offset, position = position
      )
      sizes[i] <- max(measure(labels), min_size)

      # Render box
      box <- draw_box(
        vec_slice(decor, decor$.level == levels[[i]]),
        combine_elements(box_levels[[i]], elements$box),
        size = sizes[i], offset = offset, position = position
      )

      offset <- offset + sizes[i]
      grobs[[i]] <- grobTree(box, labels)
    }

    if (position %in% c("top", "left")) {
      grobs <- rev(grobs)
      sizes <- rev(sizes)
    }

    attr(grobs, "size") <- sizes
    grobs
  },

  draw = function(self, theme, position = NULL, direction = NULL,
                  params = self$params) {
    params <- replace_null(params, position = position, direction = direction)
    params <- self$setup_params(params)

    elems <- self$setup_elements(params, self$elements, theme)
    box <- self$build_box(params$key, params$decor, elems, params)

    if (length(box) < 1L) {
      return(zeroGrob())
    }

    primitive_grob(
      grob = box,
      size = unit(get_size_attr(box), "cm"),
      position = params$position,
      name = "box"
    )

  }
)

# Helpers -----------------------------------------------------------------

draw_box <- function(decor, element, size, offset, position) {
  if (nrow(decor) < 2L || is_blank(element)) {
    return(zeroGrob())
  }
  aes <- switch(position, top = , bottom = "x", left = , right = "y", "theta")
  rle <- new_rle(decor$group)
  props <- element_key_properties(vec_slice(decor, rle$start), "rect")

  if (is_theta(position)) {
    rev <- vec_slice(decor, rev(vec_seq_along(decor)))
    x <- unit(c(decor$x, rev$x), "npc")
    y <- unit(c(decor$y, rev$y), "npc")
    theta  <- c(decor$theta, rev$theta)
    offset <- rep(c(0.0, size) + offset, each = nrow(decor))
    x <- x + unit(sin(theta) * offset, "cm")
    y <- y + unit(cos(theta) * offset, "cm")
    id <- c(decor$group, rev$group)
    element <- destructure_element(element)
    gp <- gg_par(
      col  = props$colour    %||% element$colour,
      fill = props$fill      %||% element$fill,
      lwd  = props$linewidth %||% element$linewidth,
      lty  = props$linetype  %||% element$linetype,
      linejoin = element$linejoin
    )
    grob <- polygonGrob(x = x, y = y, id = id, gp = gp)
    return(grob)
  }

  start <- decor[[aes]][rle$start]
  end   <- decor[[aes]][rle$end]
  min <- pmin(start, end)
  max <- pmax(start, end)
  args <- list(
    x = min, width = max - min,
    hjust = 0.0, vjust = 0.5,
    y = 0.5, height = 1.0
  )
  if (position %in% c("left", "right")) {
    args <- flip_names(args)
  }
  inject(element_grob(element, !!!args, !!!props))
}
