R/scale_divergingx.R

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

#' HCL-Based Discrete Flexible Diverging Scales for ggplot2
#'
#' Discrete ggplot2 color scales using the color palettes generated by \code{\link{divergingx_hcl}}.
#' 
#' Available CARTO palettes: ArmyRose, Earth, Fall, Geyser, TealRose, Temps, Tropic.
#'
#' Available ColorBrewer.org palettes: Spectral, PuOr, RdYlGn, RdYlBu, RdGy,
#' BrBG, PiYG, PRGn, RdBu.
#' 
#' 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 alpha Numeric vector of values in the range \code{[0, 1]} for alpha transparency channel (0 means transparent and 1 means opaque).
#' @param palette The name of the palette to be used.
#' @param rev If \code{TRUE}, reverses the order of the colors in the color scale.
#' @param h1,h2,h3,c1,c2,c3,l1,l2,l3,p1,p2,p3,p4,cmax1,cmax2 Parameters to customize the scale. See \code{\link{divergingx_hcl}} for details.
#' @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 color scale
#' ggplot(iris, aes(Sepal.Length, Sepal.Width, color = Species)) +
#'   geom_point() + theme_minimal() + 
#'   scale_color_discrete_divergingx()
#' 
#' # color scale "Tropic"
#' ggplot(iris, aes(Sepal.Length, fill = Species)) +
#'   geom_density(alpha = 0.7) + theme_classic() +
#'     scale_fill_discrete_divergingx(palette = "Tropic", 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_divergingx(palette = "Tropic", nmax = 5, order = c(1, 4, 5))
#' @importFrom stats na.omit
#' @export
scale_colour_discrete_divergingx <- function(palette = "Geyser", c1 = NULL, c2 = NULL, c3 = NULL,
                                           l1 = NULL, l2 = NULL, l3 = NULL, h1 = NULL, h2 = NULL,
                                           h3 = NULL, p1 = NULL, p2 = NULL, p3 = NULL, p4 = NULL,
                                           cmax1 = NULL, cmax2 = NULL, alpha = 1, rev = FALSE, nmax = NULL, order = NULL,
                                           aesthetics = "colour", ...)
{
  # arguments we want to hand off to function divergingx_hcl only if explicitly provided
  hcl_args <- c("c1", "c2", "c3", "l1", "l2", "l3", "h1", "h2", "h3", "p1", "p2",
                "p3", "p4", "cmax1", "cmax2")
  
  # 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(palette = palette, n = nmax, alpha = alpha, rev = rev))
    do.call(divergingx_hcl, args, envir = parent.frame())[order]
  }
  ggplot2::discrete_scale(aesthetics, "manual", pal, ...)
}

#' @rdname scale_colour_discrete_divergingx
#' @export
scale_color_discrete_divergingx <- scale_colour_discrete_divergingx

#' @rdname scale_colour_discrete_divergingx
#' @export
scale_fill_discrete_divergingx <- 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_divergingx, args, envir = parent.frame())
}

  
  
#' HCL-Based Continuous Flexible Diverging Scales for ggplot2
#'
#' Continuous ggplot2 color scales using the color palettes generated by \code{\link{divergingx_hcl}}.
#'
#' Available CARTO palettes: ArmyRose, Earth, Fall, Geyser, TealRose, Temps, Tropic.
#'
#' Available ColorBrewer.org palettes: Spectral, PuOr, RdYlGn, RdYlBu, RdGy,
#' BrBG, PiYG, PRGn, RdBu.
#' 
#' 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_divergingx
#' @param h1,h2,h3,c1,c2,c3,l1,l2,l3,p1,p2,p3,p4,cmax1,cmax2 Parameters to customize the scale. See \code{\link{divergingx_hcl}} for details.
#' @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.
#'   For diverging scales, 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
#' library("ggplot2")
#' 
#' # volcano plot (difference from mean height)
#' nx = 87
#' ny = 61
#' df <- data.frame(diff = c(volcano) - mean(volcano), x = rep(1:nx, ny), y = rep(1:ny, each = nx))
#' ggplot(df, aes(x, y, fill=diff)) + 
#'   geom_raster() + scale_fill_continuous_divergingx(palette = "Fall", rev = TRUE) +
#'   coord_fixed(expand = FALSE)
#'
#'
#' # adapted from stackoverflow: https://stackoverflow.com/a/20127706/4975218
#'
#' # 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 diverging scale "Geyser"
#' gg + scale_fill_continuous_divergingx(palette = "Geyser")
#'
#' # plot with diverging scale "ArmyRose"
#' gg + scale_fill_continuous_divergingx(palette = "ArmyRose")
#' @importFrom stats na.omit
#' @export
scale_colour_continuous_divergingx <- function(palette = "Geyser", c1 = NULL, c2 = NULL, c3 = NULL,
                                             l1 = NULL, l2 = NULL, l3 = NULL, h1 = NULL, h2 = NULL,
                                             h3 = NULL, p1 = NULL, p2 = NULL, p3 = NULL, p4 = NULL,
                                             cmax1 = NULL, cmax2 = 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 divergingx_hcl only if explicitly provided
  hcl_args <- c("c1", "c2", "c3", "l1", "l2", "l3", "h1", "h2", "h3", "p1", "p2",
                "p3", "p4", "cmax1", "cmax2")
  
  # 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(palette = palette, n = n_interp, alpha = alpha, rev = rev))
  colors <- do.call(divergingx_hcl, args, envir = parent.frame())
  
  # diverging scale
  rescaler = mid_rescaler(mid)
  ggplot2::continuous_scale(aesthetics, "continuous_divergingx",
                            scales::gradient_n_pal(colors, values = NULL),
                            na.value = na.value, guide = guide,
                            rescaler = rescaler, ...)
}

#' @rdname scale_colour_continuous_divergingx
#' @export
scale_color_continuous_divergingx <- scale_colour_continuous_divergingx

#' @rdname scale_colour_continuous_divergingx
#' @export
scale_fill_continuous_divergingx <- 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_divergingx, args, envir = parent.frame())
}

#' HCL-Based Binned Flexible Diverging Scales for ggplot2
#'
#' Binned ggplot2 color scales using the color palettes generated by \code{\link{divergingx_hcl}}.
#'
#' Available CARTO palettes: ArmyRose, Earth, Fall, Geyser, TealRose, Temps, Tropic.
#'
#' Available ColorBrewer.org palettes: Spectral, PuOr, RdYlGn, RdYlBu, RdGy,
#' BrBG, PiYG, PRGn, RdBu.
#' 
#' 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_divergingx
#' @param h1,h2,h3,c1,c2,c3,l1,l2,l3,p1,p2,p3,p4,cmax1,cmax2 Parameters to customize the scale. See \code{\link{divergingx_hcl}} for details.
#' @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.
#'   For diverging scales, it is important to use an odd number to capture the color at the midpoint.
#' @param ... common binned scale parameters: `name`, `breaks`, `labels`, and `limits`. See
#'  \code{\link[ggplot2]{binned_scale}} for more details.
#' @examples
#' library("ggplot2")
#'
#' # volcano plot (difference from mean height)
#' nx = 87
#' ny = 61
#' df <- data.frame(diff = c(volcano) - mean(volcano), x = rep(1:nx, ny), y = rep(1:ny, each = nx))
#' ggplot(df, aes(x, y, fill=diff)) + 
#'   geom_raster() + scale_fill_binned_divergingx(palette = "Fall", rev = TRUE) +
#'   coord_fixed(expand = FALSE)
#'
#'
#' # adapted from stackoverflow: https://stackoverflow.com/a/20127706/4975218
#'
#' # 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 diverging scale "Geyser"
#' gg + scale_fill_binned_divergingx(palette = "Geyser",  n.breaks = 6)
#' @importFrom stats na.omit
#' @export
scale_colour_binned_divergingx <- function(palette = "Geyser", c1 = NULL, c2 = NULL, c3 = NULL,
                                           l1 = NULL, l2 = NULL, l3 = NULL, h1 = NULL, h2 = NULL,
                                           h3 = NULL, p1 = NULL, p2 = NULL, p3 = NULL, p4 = NULL,
                                           cmax1 = NULL, cmax2 = 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 divergingx_hcl only if explicitly provided
  hcl_args <- c("c1", "c2", "c3", "l1", "l2", "l3", "h1", "h2", "h3", "p1", "p2",
                "p3", "p4", "cmax1", "cmax2")
  
  # 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(palette = palette, n = n_interp, alpha = alpha, rev = rev))
  colors <- do.call(divergingx_hcl, args, envir = parent.frame())
  
  # diverging scale
  rescaler = mid_rescaler(mid)
  ggplot2::binned_scale(
    aesthetics, "binned_divergingx",
    scales::gradient_n_pal(colors, values = NULL),
    na.value = na.value, guide = guide,
    rescaler = rescaler, ...
  )
}

#' @rdname scale_colour_binned_divergingx
#' @export
scale_color_binned_divergingx <- scale_colour_binned_divergingx

#' @rdname scale_colour_binned_divergingx
#' @export
scale_fill_binned_divergingx <- 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_divergingx, args, envir = parent.frame())
}