R/scale_diverging.R

In colorspace: A Toolbox for Manipulating and Assessing Colors and Palettes

#' HCL-Based Discrete Diverging Color Scales for ggplot2
#'
#' Discrete ggplot2 color scales using the color palettes generated by \code{\link{diverging_hcl}}. 
#'
#' 
#' If both a valid palette name and palette parameters are provided then the provided palette parameters overwrite the parameters in the
#' named palette. This enables easy customization of named palettes.
#' 
#' @param c1 Chroma value at the scale endpoints.
#' @param cmax Maximum chroma value.
#' @param l1 Luminance value at the scale endpoints.
#' @param l2 Luminance value at the scale midpoint.
#' @param h1 Hue value at the first endpoint.
#' @param h2 Hue value at the second endpoint.
#' @param p1 Control parameter determining how chroma should vary (1 = linear, 2 = quadratic, etc.).
#' @param p2 Control parameter determining how luminance should vary (1 = linear, 2 = quadratic, etc.).
#' @param alpha Numeric vector of values in the range \code{[0, 1]} for alpha transparency channel (0 means transparent and 1 means opaque).
#' @param rev If \code{TRUE}, reverses the order of the colors in the color scale.
#' @param palette The name of the palette to be used. Run \code{hcl_palettes(type = "diverging")} for available options.
#' @param nmax Maximum number of different colors the palette should contain. If not provided, is calculated automatically
#'  from the data.
#' @param order Numeric vector listing the order in which the colors should be used. Default is \code{1:nmax}.
#' @param aesthetics The ggplot2 aesthetics to which this scale should be applied.
#' @param ... common discrete scale parameters: \code{name}, \code{breaks}, \code{labels}, \code{na.value}, \code{limits} and \code{guide}. See
#'  \code{\link[ggplot2]{discrete_scale}} for more details.
#' @examples
#' library("ggplot2")
#' 
#' # default colors with slightly darkened midpoint
#' ggplot(iris, aes(Sepal.Length, Sepal.Width, color = Species)) +
#'   geom_point() + theme_minimal() + 
#'   scale_color_discrete_diverging(l2=75)
#' 
#' # color scale "Green-Orange"
#' ggplot(iris, aes(Sepal.Length, fill = Species)) +
#'   geom_density(alpha = 0.7) + theme_classic() +
#'     scale_fill_discrete_diverging(palette = "Green-Orange", rev = TRUE)
#'     
#' # use `nmax` and `order` to skip some colors
#' ggplot(iris, aes(Sepal.Length, fill = Species)) +
#'   geom_density(alpha = 0.7) + theme_classic() +
#'     scale_fill_discrete_diverging(palette = "Green-Orange", nmax = 5, order = c(1, 4, 5))
#' @importFrom stats na.omit
#' @export
scale_colour_discrete_diverging <- function(palette = NULL, c1 = NULL, cmax = NULL, l1 = NULL, l2 = NULL,
                                             h1 = NULL, h2 = NULL, p1 = NULL, p2 = NULL, alpha = 1, rev = FALSE,
                                             nmax = NULL, order = NULL, aesthetics = "colour", ...)
{
  # arguments we want to hand off to function diverging_hcl only if explicitly provided
  hcl_args <- c("palette", "c1", "cmax", "l1", "l2", "h1", "h2", "p1", "p2")
  
  # match hcl_args to args provided
  args <- as.list(match.call())
  args[[1]] <- NULL # remove the function call
  args <- args[na.omit(match(hcl_args, names(args)))] # remove other args
  for(n in names(args)) args[[n]] <- get(n) # force evaluation of args
  
  pal <- function(n) {
    if (is.null(nmax)) nmax <- n
    if (is.null(order)) order <- 1:n
    
    if (n > nmax) {
      warning("Insufficient values in scale_colour_discrete_diverging. ", n, " needed but only ",
              nmax, " provided.", call. = FALSE)
    }
    # set the remaining arguments and call qualitative_hcl
    args <- c(args, list(n = nmax, alpha = alpha, rev = rev))
    do.call(diverging_hcl, args, envir = parent.frame())[order]
  }
  ggplot2::discrete_scale(aesthetics, "manual", pal, ...)
}

#' @rdname scale_colour_discrete_diverging
#' @export
scale_color_discrete_diverging <- scale_colour_discrete_diverging

#' @rdname scale_colour_discrete_diverging
#' @export
scale_fill_discrete_diverging <- function(..., aesthetics = "fill")
{
  args <- as.list(match.call())
  args[[1]] <- NULL # remove the function call
  if (is.null(args[["aesthetics"]])) args$aesthetics <- "fill"
  do.call(scale_colour_discrete_diverging, args, envir = parent.frame())
}

#' HCL-Based Continuous Diverging Color Scales for ggplot2
#'
#' Continuous ggplot2 color scales using the color palettes generated by \code{\link{diverging_hcl}}. 
#'
#' 
#' If both a valid palette name and palette parameters are provided then the provided palette parameters overwrite the parameters in the
#' named palette. This enables easy customization of named palettes.
#' 
#' @inheritParams scale_colour_discrete_diverging
#' @param mid Data value that should be mapped to the mid-point of the diverging color scale.
#' @param na.value Color to be used for missing data points.
#' @param guide Type of legend. Use \code{"colourbar"} for continuous color bar. 
#' @param n_interp Number of discrete colors that should be used to interpolate the continuous color scale.
#'   It is important to use an odd number to capture the color at the midpoint.
#' @param ... common continuous scale parameters: `name`, `breaks`, `labels`, and `limits`. See
#'  \code{\link[ggplot2]{continuous_scale}} for more details.
#' @examples
#' # adapted from stackoverflow: https://stackoverflow.com/a/20127706/4975218
#' 
#' library("ggplot2")
#'
#' # generate dataset and base plot
#' set.seed(100)
#' df <- data.frame(country = LETTERS, V = runif(26, -40, 40))
#' df$country = factor(LETTERS, LETTERS[order(df$V)]) # reorder factors
#' gg <- ggplot(df, aes(x = country, y = V, fill = V)) +
#'   geom_bar(stat = "identity") +
#'   labs(y = "Under/over valuation in %", x = "Country") +
#'   coord_flip() + theme_minimal()
#'   
#' # plot with default diverging scale
#' gg + scale_fill_continuous_diverging()
#'
#' # plot with alternative scale
#' gg + scale_fill_continuous_diverging(palette = "Purple-Green")
#' 
#' # plot with modified alternative scale
#' gg + scale_fill_continuous_diverging(palette = "Blue-Red 3", l1 = 30, l2 = 100, p1 = .9, p2 = 1.2)
#' @importFrom stats na.omit
#' @export
scale_colour_continuous_diverging <- function(palette = NULL, c1 = NULL, cmax = NULL, l1 = NULL, l2 = NULL,
                                               h1 = NULL, h2 = NULL, p1 = NULL, p2 = NULL, alpha = 1, rev = FALSE,
                                               mid = 0, na.value = "grey50", guide = "colourbar",
                                               n_interp = 11, aesthetics = "colour", ...)
{
  # arguments we want to hand off to function diverging_hcl only if explicitly provided
  hcl_args <- c("palette", "c1", "cmax", "l1", "l2", "h1", "h2", "p1", "p2")
  
  # match hcl_args to args provided
  args <- as.list(match.call())
  args[[1]] <- NULL # remove the function call
  args <- args[na.omit(match(hcl_args, names(args)))] # remove other args
  
  # set the remaining arguments and call qualitative_hcl
  args <- c(args, list(n = n_interp, alpha = alpha, rev = rev))
  colors <- do.call(diverging_hcl, args, envir = parent.frame())

  ggplot2::continuous_scale(aesthetics, "continuous_diverging",
                            scales::gradient_n_pal(colors, values = NULL),
                            na.value = na.value, guide = guide,
                            rescaler = mid_rescaler(mid), ...)
}

#' @rdname scale_colour_continuous_diverging
#' @export
scale_color_continuous_diverging <- scale_colour_continuous_diverging

#' @rdname scale_colour_continuous_diverging
#' @export
scale_fill_continuous_diverging <- function(..., aesthetics = "fill")
{
  args <- as.list(match.call())
  args[[1]] <- NULL # remove the function call
  if (is.null(args[["aesthetics"]])) args$aesthetics <- "fill"
  do.call(scale_colour_continuous_diverging, args, envir = parent.frame())
}

#' HCL-Based Binned Diverging Color Scales for ggplot2
#'
#' Binned ggplot2 color scales using the color palettes generated by \code{\link{diverging_hcl}}. 
#'
#' 
#' If both a valid palette name and palette parameters are provided then the provided palette parameters overwrite the parameters in the
#' named palette. This enables easy customization of named palettes.
#' 
#' @inheritParams scale_colour_discrete_diverging
#' @param mid Data value that should be mapped to the mid-point of the diverging color scale.
#' @param na.value Color to be used for missing data points.
#' @param guide Type of legend. Use \code{"coloursteps"} for color bar with discrete steps. 
#' @param n_interp Number of discrete colors that should be used to interpolate the binned color scale.
#'   It is important to use an odd number to capture the color at the midpoint.
#' @param ... common continuous scale parameters: `name`, `breaks`, `labels`, and `limits`. See
#'  \code{\link[ggplot2]{binned_scale}} for more details.
#' @examples
#' # adapted from stackoverflow: https://stackoverflow.com/a/20127706/4975218
#' 
#' library("ggplot2")
#'
#' # generate dataset and base plot
#' set.seed(100)
#' df <- data.frame(country = LETTERS, V = runif(26, -40, 40))
#' df$country = factor(LETTERS, LETTERS[order(df$V)]) # reorder factors
#' gg <- ggplot(df, aes(x = country, y = V, fill = V)) +
#'   geom_bar(stat = "identity") +
#'   labs(y = "Under/over valuation in %", x = "Country") +
#'   coord_flip() + theme_minimal()
#'   
#' # plot with default diverging scale
#' gg + scale_fill_binned_diverging(n.breaks = 6)
#' 
#' # plot with alternative scale
#' gg + scale_fill_binned_diverging(palette = "Purple-Green", n.breaks = 6)
#' @importFrom stats na.omit
#' @export
scale_colour_binned_diverging <- function(palette = NULL, c1 = NULL, cmax = NULL, l1 = NULL, l2 = NULL,
                                              h1 = NULL, h2 = NULL, p1 = NULL, p2 = NULL, alpha = 1, rev = FALSE,
                                              mid = 0, na.value = "grey50", guide = "coloursteps",
                                              n_interp = 11, aesthetics = "colour", ...)
{
  # arguments we want to hand off to function diverging_hcl only if explicitly provided
  hcl_args <- c("palette", "c1", "cmax", "l1", "l2", "h1", "h2", "p1", "p2")
  
  # match hcl_args to args provided
  args <- as.list(match.call())
  args[[1]] <- NULL # remove the function call
  args <- args[na.omit(match(hcl_args, names(args)))] # remove other args
  
  # set the remaining arguments and call qualitative_hcl
  args <- c(args, list(n = n_interp, alpha = alpha, rev = rev))
  colors <- do.call(diverging_hcl, args, envir = parent.frame())
  
  ggplot2::binned_scale(
    aesthetics,
    "binned_diverging",
    scales::gradient_n_pal(colors, values = NULL),
    na.value = na.value, guide = guide,
    rescaler = mid_rescaler(mid),
    ...
  )
}

#' @rdname scale_colour_binned_diverging
#' @export
scale_color_binned_diverging <- scale_colour_binned_diverging

#' @rdname scale_colour_binned_diverging
#' @export
scale_fill_binned_diverging <- function(..., aesthetics = "fill")
{
  args <- as.list(match.call())
  args[[1]] <- NULL # remove the function call
  if (is.null(args[["aesthetics"]])) args$aesthetics <- "fill"
  do.call(scale_colour_binned_diverging, args, envir = parent.frame())
}