R/scale-level.R

In distributional: Vectorised Probability Distributions

#' level luminance scales
#'
#' This set of scales defines new scales for prob geoms equivalent to the
#' ones already defined by ggplot2. This allows the shade of confidence intervals
#' to work with the legend output.
#' @return A ggproto object inheriting from `Scale`
#' @family scale_level_*
#' @name scale_level
#' @rdname scale_level
NULL

#' @rdname scale_level
#' @inheritParams ggplot2::scale_colour_gradient
#' @export
scale_level_continuous <- function(..., guide = "level") {
  level_scale("level", "identity", identity, guide = guide, ...)
}

ScaleLevel <- ggplot2::ggproto(NULL, ggplot2::ScaleContinuous)

#' @importFrom ggplot2 waiver discrete_scale
level_scale <- function(...) {
  ggplot2::ggproto(NULL, ggplot2::continuous_scale(...), range = level_range())
}

level_range <- function(){
  ggplot2::ggproto(NULL, RangeLevel)
}

RangeLevel <- ggplot2::ggproto(NULL, NULL,
                               range = NULL,
                               levels = NULL,
                               reset = function(self){
                                 self$range <- NULL
                                 self$levels <- NULL
                               },
                               train = function(self, x){
                                 self$range <- scales::train_continuous(x, self$range)
                                 self$levels <- unique(c(x[!is.na(x)],self$range))
                               }
)


#' Level shade bar guide
#'
#' The level guide shows the colour from the forecast intervals which is blended with the series colour.
#'
#' @inheritParams ggplot2::guide_colourbar
#' @param max_discrete The maximum number of levels to be shown using [ggplot2::guide_legend()].
#' If the number of levels exceeds this value, level shades are shown with [ggplot2::guide_colourbar()].
#' @param ... Further arguments passed onto either [ggplot2::guide_colourbar()] or [ggplot2::guide_legend()]
#'
#' @export
guide_level <- function(title = waiver(), max_discrete = 5, ...) {
  structure(list(title = title,
                 max_discrete = max_discrete,
                 available_aes = "level",
                 args = list(...)),
            class=c("guide", "level_guide"))
}

#' Helper methods for guides
#'
#' @export
#' @rdname guide-helpers
#' @importFrom ggplot2 guide_colourbar guide_legend guide_train
#' @keywords internal
guide_train.level_guide <- function(guide, scale, aesthetic) {
  args <- append(guide[!(names(guide)%in%c("max_discrete", "args"))], guide$args)
  levels <- scale$range$levels
  if (length(levels) == 0 || all(is.na(levels)))
    return()
  if(length(levels)<=guide$max_discrete){
    guide <- do.call("guide_legend", args)
    class(guide) <- c("guide", "guide_level")
    breaks <- levels

    cols <- darken_fill(rep.int("white", length(breaks)), breaks)
    key <- as.data.frame(
      set_names(list(cols), aesthetic %||% scale$aesthetics[1]),
      stringsAsFactors = FALSE
    )
    key$.label <- scale$get_labels(breaks)
    if (!scale$is_discrete()) {
      limits <- scale$get_limits()
      noob <- !is.na(breaks) & limits[1] <= breaks & breaks <=
        limits[2]
      key <- key[noob, , drop = FALSE]
    }
    if (guide$reverse)
      key <- key[nrow(key):1, ]
    guide$key <- key
    guide$hash <- with(guide, digest::digest(list(title, key$.label,
                                                  direction, name)))
  }
  else{
    guide <- do.call("guide_colourbar", args)
    breaks <- scale$get_breaks()
    ticks <- as.data.frame(stats::setNames(list(scale$map(breaks)),
                                           aesthetic %||% scale$aesthetics[1]))
    ticks$.value <- breaks
    ticks$.label <- scale$get_labels(breaks)
    guide$key <- ticks
    .limits <- scale$get_limits()
    .bar <- seq(.limits[1], .limits[2], length = guide$nbin)
    if (length(.bar) == 0) {
      .bar = unique(.limits)
    }
    guide$bar <- data.frame(colour = scale$map(.bar), value = .bar,
                            stringsAsFactors = FALSE)
    if (guide$reverse) {
      guide$key <- guide$key[nrow(guide$key):1, ]
      guide$bar <- guide$bar[nrow(guide$bar):1, ]
    }
    guide$hash <- with(guide, digest::digest(list(title, key$.label,
                                                  bar, name)))
  }
  if(guide$title == "vctrs::vec_data(hilo)$level") guide$title <- "level"
  guide
}

#' @export
#' @importFrom ggplot2 guide_geom
#' @rdname guide-helpers
guide_geom.guide_level <- function (guide, layers, default_mapping)
{
  class(guide) <- c("guide", "legend")
  guide <- guide_geom(guide, layers, default_mapping)
  guide$geoms <- lapply(guide$geoms, function(x){
    x$draw_key <- ggplot2::ggproto(NULL, NULL,
                                   draw_key = function(data, params, size){
                                     lwd <- min(data$size, min(size) / 4)
                                     fillcol <- data$level #blendHex(data$col, data$level, 0.7)
                                     grid::rectGrob(
                                       width = grid::unit(1, "npc") - grid::unit(lwd, "mm"),
                                       height = grid::unit(1, "npc") - grid::unit(lwd, "mm"),
                                       gp = grid::gpar(
                                         col = fillcol,
                                         fill = scales::alpha(fillcol, data$alpha),
                                         lty = data$linetype,
                                         lwd = lwd * ggplot2::.pt,
                                         linejoin = "mitre"
                                       )
                                     )
                                   })$draw_key
    x
  })
  guide
}