Custom discrete color scale in ggplot does not respect order

user_9197726 0
Viewed 611

Context

I'm trying to create a custom color scale to be called using something like scale_fill_perso in ggplot. I followed the steps described in this nice blog post. My discrete scale has 7 levels.

I managed to set the scale correctly (see below). When using a graph with 7 levels, I have the expected colors. However, when I don't use as many colors, I would like R to respect the order of my palette and not interpolate between values (see example). For instance, if I have 3 colors, I would like R to use the first three values of my color vector.

I think this comes from my_pal that itself uses grDevices::colorRampPalette which, when using a number of classes smaller than the size of the color vector, cuts the color vector using extremes rather than order.

So my question is: Is there some way to capture the number of classes and, if number classes < length(color vector) do not use colorRampPalette interpolation ?

Current implementation

Steps follow the aforementioned blog post.

First, create a color vector and a way to call it:

mycolors <- c(
`red` = "#E2447A",
`green` = "#BCE550",
`blue` = "#708DD3", 
`grey` = "#666666",
`orange` = "#FFBAA8",
`violet` = "#D1A3FF",
`lightgrey` = "#B2B2B2"
)

my_cols <- function(...) {

  cols <- c(...)

  if (is.null(cols))
    return (mycolors)

  mycolors[cols]
}

call_palettes <- function(palette = "main"){
  if (palette == "main"){ return(my_cols()) }
}

There's only one palette for the moment but this might change. Then create the palette function that interpolates values (for what I understood):

my_pal <- function(palette = "main", reverse = FALSE, ...) {

  args <- list(...)
  #return(args)

  pal <- call_palettes(palette, ...)

  if (reverse) pal <- rev(pal)

  grDevices::colorRampPalette(pal, ...)
}

Then create scale_fill_perso function to use that palette. 

scale_fill_perso <- function(palette = "main", discrete = TRUE, reverse = FALSE, ...) {
  pal <- my_pal(palette = palette, reverse = reverse)

  if (discrete) {
    ggplot2::discrete_scale("fill", paste0("my_pal_", palette), palette = pal, ...)
  } else {
    ggplot2::scale_fill_gradientn(colours = pal(256), ...)
  }
}

Output

Using 7 classes, no problem:

iris$random <- sample(1:7, nrow(iris), replace = TRUE)

ggplot2::ggplot(iris) +
  ggplot2::geom_histogram(ggplot2::aes(x = Sepal.Width, y = ..density..,
                                       fill = factor(random))) +
  scale_fill_perso(palette = "main")

enter image description here

However, when using a number of colors smaller, I would like to use the first three colors of my vector (red-green-blue), which is not the case for the moment

ggplot2::ggplot(iris) +
  ggplot2::geom_histogram(ggplot2::aes(x = Sepal.Width, y = ..density..,
                                       fill = factor(Species))) +
  scale_fill_perso(palette = "main")

enter image description here

I identified that comes from the fact that my_pal is not taking order of the vector as informative. For instance, for 2 colors, it takes the two extremes of the vector:

my_pal()(2)
# "#E2447A" "#B2B2B2"
mycolors 
#      red     green      blue      grey    orange    violet lightgrey 
# "#E2447A" "#BCE550" "#708DD3" "#666666" "#FFBAA8" "#D1A3FF" "#B2B2B2"

and for three, it adds the middle value: 

my_pal()(3)
# "#E2447A" "#666666" "#B2B2B2"
mycolors 
#      red     green      blue      grey    orange    violet lightgrey 
# "#E2447A" "#BCE550" "#708DD3" "#666666" "#FFBAA8" "#D1A3FF" "#B2B2B2"

How can I ensure to follow vector order when number classes < number colors ?

ggplot2 r graphics
2 Answers

After digging a little bit, I found a solution by modifying slightly the colorRamp and colorRampPalette functions.

The idea is to capture the number of classes within colorRampPalette and use it as an argument to slice color vector in colorRamp function:

colorRamp_d <- function (colors, n,
                         bias = 1,
                         space = c("rgb", "Lab"),
                         interpolate = c("linear",
                                         "spline"),
                         alpha = FALSE){

  # PRELIMINARY STEPS ----------------
  if (bias <= 0)
    stop("'bias' must be positive")
  if (!missing(space) && alpha)
    stop("'alpha' must be false if 'space' is specified")
  colors <- t(col2rgb(colors, alpha = alpha)/255)
  space <- match.arg(space)
  interpolate <- match.arg(interpolate)

  # CUT THE COLOR VECTOR ----------------------

  if (space == "Lab")
    colors <- convertColor(colors, from = "sRGB", to = "Lab")
  interpolate <- switch(interpolate, linear = stats::approxfun,
                        spline = stats::splinefun)

  # RESPECT ORDER IF NCLASSES<NCOLORS
  if (n<nrow(colors)) colors <- colors[1:n,]

  if ((nc <- nrow(colors)) == 1L) {
    colors <- colors[c(1L, 1L), ]
    nc <- 2L
  }
  x <- seq.int(0, 1, length.out = nc)^bias
  palette <- c(interpolate(x, colors[, 1L]), interpolate(x,
                                                         colors[, 2L]), interpolate(x, colors[, 3L]), if (alpha) interpolate(x,
                                                                                                                             colors[, 4L]))
  roundcolor <- function(rgb) pmax(pmin(rgb, 1), 0)
  if (space == "Lab")
    function(x) roundcolor(convertColor(cbind(palette[[1L]](x),
                                              palette[[2L]](x), palette[[3L]](x), if (alpha)
                                                palette[[4L]](x)), from = "Lab", to = "sRGB")) *
    255
  else function(x) roundcolor(cbind(palette[[1L]](x), palette[[2L]](x),
                                    palette[[3L]](x), if (alpha)
                                      palette[[4L]](x))) * 255
}


colorRampPalette_d <- function (colors, ...){
  # n: number of classes
  function(n) {
    ramp <- colorRamp_d(colors, n, ...)
    x <- ramp(seq.int(0, 1, length.out = n))
    if (ncol(x) == 4L)
      rgb(x[, 1L], x[, 2L], x[, 3L], x[, 4L], maxColorValue = 255)
    else rgb(x[, 1L], x[, 2L], x[, 3L], maxColorValue = 255)
  }
}

The only difference with grDevices::colorRamp function is the argument n (number of classes) and the slicing introduced by this line :

if (n<nrow(colors)) colors <- colors[1:n,]

Finally, instead of calling Grdevices::colorRampPalette, I call my custom colorRampPalette_d:

my_pal <- function(palette = "main", reverse = FALSE, ...) {

  args <- list(...)
  #return(args)

  pal <- call_palettes(palette, ...)

  if (reverse) pal <- rev(pal)

  colorRampPalette_d(pal, ...)
}

Which yields:

ggplot2::ggplot(iris) +
  ggplot2::geom_histogram(ggplot2::aes(x = Sepal.Width, y = ..density..,
                                       fill = factor(Species))) +
  scale_fill_perso(palette = "main")

enter image description here

user_91977260

linog's answer to the question solved my problem. I can't comment on the answer but for anyone else using it, note that you have to modify two functions, colorRamp and colorRampPalette, in the latter the call to colorRamp is moved within the subfunction from just before it, becoming ramp <- colorRamp_d(colors, n, ...).

Another approach to a custom color scale can be found here, https://www.garrickadenbuie.com/blog/custom-discrete-color-scales-for-ggplot2/, but this takes an alternative approach and doesn't use the colorRamp functionality so can only be used for discrete scales with a maximum number of colors. It does allow for default colors so may suit analysis where just getting a quick set of charts with a limited color range out. It also shows how to cater for both British and American spelling of colour.

user_169074480
Related