[Rd] Brewer colours

[Peter Kleiweg]

Anyone who is interested in using optimal colour palettes should
look at the work of Cindy Brewer: www.colorbrewer.org

I have written code to use her colour schemes in R. It is
included below. Perhaps someone may find this interesting enough
to work into a package.

Included also is a function showpalette, which was posted here a
while back. I don't remember who wrote it.

I have copied all the palettes from colorbrewer with the maximum
number of colours (which varies per palette). I have written a
function that translates these colours directly to rgb, or
through interpolation if you need a larger (or smaller) palette.
If you need a smaller palette, you may have to go to
www.colorbrewer.org for optimal results.

There are three types of palettes:
- Sequential, from minimal (light) to maximal (dark).
  There is no white in the original palettes. I added white.
- Diverging, from one extreme (dark) through light to another
  extreme (dark, another colour).
- Qualitative, no particular order.

To view a palette with the original colours:

   > showpalette(brewer2rgb(brewerSequential.YlGnBl))

To view the same palette, interpolated to another number of
colours:

   > showpalette(brewer2rgb(brewerSequential.YlGnBl, 19))

Notes:

  1. Interpolating Qualitative palettes does not work. You can't
     get more colours. If you need less, go to www.colorbrewer.org

  2. The palettes are tested to consist of colours that are
     optimally distinguishable to the human eye. Not all
     palettes may be useful in all circumstances or media. See
     www.colorbrewer.org for specs per palette and per number of
     colours. Interpolating to more colours will loose the
     distinction.

The code:

# www.colorbrewer.org

brewerSequential.PuBu <- array(data = c(
255,255,255,
255,247,251,
236,231,242,
208,209,230,
166,189,219,
116,169,207,
54,144,192,
5,112,176,
4,90,141,
2,56,88),
dim = c(3, 10))

brewerSequential.YlGnBl <- array(data = c(
255,255,255,
255,255,217,
237,248,177,
199,233,180,
127,205,187,
65,182,196,
29,145,192,
34,94,168,
37,52,148,
8,29,88),
dim = c(3, 10))

brewerSequential.GnBu <- array(data = c(
255,255,255,
247,252,240,
224,243,219,
204,235,197,
168,221,181,
123,204,196,
78,179,211,
43,140,190,
8,104,172,
8,64,129),
dim = c(3, 10))

brewerSequential.YlGn <- array(data = c(
255,255,255,
255,255,229,
247,252,185,
217,240,163,
173,221,142,
120,198,121,
65,171,93,
35,132,67,
0,104,55,
0,69,41),
dim = c(3, 10))

brewerSequential.BuGn <- array(data = c(
255,255,255,
247,252,253,
229,245,249,
204,236,230,
153,216,201,
102,194,164,
65,174,118,
35,139,69,
0,109,44,
0,68,27),
dim = c(3, 10))

brewerSequential.OrRd <- array(data = c(
255,255,255,
255,247,236,
254,232,200,
253,212,158,
253,187,132,
252,141,89,
239,101,72,
215,48,31,
179,0,0,
127,0,0),
dim = c(3, 10))

brewerSequential.PuBuGn <- array(data = c(
255,255,255,
255,247,251,
236,226,240,
208,209,230,
166,189,219,
103,169,207,
54,144,192,
2,129,138,
1,108,89,
1,70,54),
dim = c(3, 10))

brewerSequential.BuPu <- array(data = c(
255,255,255,
247,252,253,
224,236,244,
191,211,230,
158,188,218,
140,150,198,
140,107,177,
136,65,157,
129,15,124,
77,0,75),
dim = c(3, 10))

brewerSequential.RdPu <- array(data = c(
255,255,255,
255,247,243,
253,224,221,
252,197,192,
250,159,181,
247,104,161,
221,52,151,
174,1,126,
122,1,119,
73,0,106),
dim = c(3, 10))

brewerSequential.PuRd <- array(data = c(
255,255,255,
247,244,249,
231,225,239,
212,185,218,
201,148,199,
223,101,176,
231,41,138,
206,18,86,
152,0,67,
103,0,31),
dim = c(3, 10))

brewerSequential.YlOrRd <- array(data = c(
255,255,255,
255,255,204,
255,237,160,
254,217,118,
254,178,76,
253,141,60,
252,78,42,
227,26,28,
189,0,38,
128,0,38),
dim = c(3, 10))

brewerSequential.YlOrBr <- array(data = c(
255,255,255,
255,255,229,
255,247,188,
254,227,145,
254,196,79,
254,153,41,
236,112,20,
204,76,2,
153,52,4,
102,37,6),
dim = c(3, 10))

brewerSequential.Purples <- array(data = c(
255,255,255,
252,251,253,
239,237,245,
218,218,235,
188,189,220,
158,154,200,
128,125,186,
106,81,163,
84,39,143,
63,0,125),
dim = c(3, 10))

brewerSequential.Blues <- array(data = c(
255,255,255,
247,251,255,
222,235,247,
198,219,239,
158,202,225,
107,174,214,
66,146,198,
33,113,181,
8,81,156,
8,48,107),
dim = c(3, 10))

brewerSequential.Greens <- array(data = c(
255,255,255,
247,252,245,
229,245,224,
199,233,192,
161,217,155,
116,196,118,
65,171,93,
35,139,69,
0,109,44,
0,68,27),
dim = c(3, 10))

brewerSequential.Oranges <- array(data = c(
255,255,255,
255,245,235,
254,230,206,
253,208,162,
253,174,107,
253,141,60,
241,105,19,
217,72,1,
166,54,3,
127,39,4),
dim = c(3, 10))

brewerSequential.Reds <- array(data = c(
255,255,255,
255,245,240,
254,224,210,
252,187,161,
252,146,114,
251,106,74,
239,59,44,
203,24,29,
165,15,21,
103,0,13),
dim = c(3, 10))

brewerSequential.Greys <- array(data = c(
255,255,255,
240,240,240,
217,217,217,
189,189,189,
150,150,150,
115,115,115,
82,82,82,
37,37,37,
0,0,0),
dim = c(3, 9))

brewerDiverging.PuOr <- array(data = c(
127,59,8,
179,88,6,
224,130,20,
253,184,99,
254,224,182,
247,247,247,
216,218,235,
178,171,210,
128,115,172,
84,39,136,
45,0,75),
dim = c(3, 11))

brewerDiverging.BrGr <- array(data = c(
84,48,5,
140,81,10,
191,129,45,
223,194,125,
246,232,195,
245,245,245,
199,234,229,
128,205,193,
53,151,143,
1,102,94,
0,60,48),
dim = c(3, 11))

brewerDiverging.PRGr <- array(data = c(
64,0,75,
118,42,131,
153,112,171,
194,165,207,
231,212,232,
247,247,247,
217,244,211,
168,216,183,
90,174,97,
27,120,55,
0,68,27),
dim = c(3, 11))

brewerDiverging.PiYG <- array(data = c(
142,1,82,
197,27,125,
222,119,174,
241,182,218,
253,224,239,
247,247,247,
230,245,208,
184,225,134,
127,188,65,
77,146,33,
39,100,25),
dim = c(3, 11))

brewerDiverging.RdBu <- array(data = c(
103,0,31,
178,24,43,
214,96,77,
244,165,130,
253,219,199,
247,247,247,
209,229,240,
146,197,222,
67,147,195,
33,102,172,
5,48,97),
dim = c(3, 11))

brewerDiverging.RdGy <- array(data = c(
103,0,31,
178,24,43,
214,96,77,
244,165,130,
253,219,199,
255,255,255,
224,224,224,
186,186,186,
135,135,135,
77,77,77,
26,26,26),
dim = c(3, 11))

brewerDiverging.RYB <- array(data = c(
165,0,38,
215,48,39,
244,109,67,
253,174,97,
254,224,144,
255,255,191,
224,243,248,
171,217,233,
116,173,209,
69,117,180,
49,54,149),
dim = c(3, 11))

brewerDiverging.spectral <- array(data = c(
158,1,66,
213,62,79,
244,109,67,
253,174,97,
254,224,139,
255,255,191,
230,245,152,
171,221,164,
102,194,165,
50,136,189,
94,79,162),
dim = c(3, 11))

brewerDiverging.RYG <- array(data = c(
165,0,38,
215,48,39,
244,109,67,
253,174,97,
254,224,139,
255,255,191,
217,239,139,
166,217,106,
102,189,99,
26,152,80,
0,104,55),
dim = c(3, 11))

brewerQualitative.Set3 <- array(data = c(
141,211,199,
255,255,179,
190,186,218,
251,128,114,
128,177,211,
253,180,98,
179,222,105,
252,205,229,
217,217,217,
188,128,189,
204,235,197,
255,237,111),
dim = c(3, 12))

brewerQualitative.Pastel1 <- array(data = c(
251,180,174,
179,205,227,
204,235,197,
222,203,228,
254,217,166,
255,255,204,
229,216,189,
253,218,236,
242,242,242),
dim = c(3, 9))

brewerQualitative.Set1 <- array(data = c(
228,26,28,
55,126,184,
77,175,74,
152,78,163,
255,127,0,
255,255,51,
166,86,40,
247,129,191,
153,153,153),
dim = c(3, 9))

brewerQualitative.Paired <- array(data = c(
166,206,227,
31,120,180,
178,223,138,
51,160,44,
251,154,153,
227,26,28,
253,191,111,
255,127,0,
202,178,214,
106,61,154,
255,255,153),
dim = c(3, 11))

brewerQualitative.Pastel2 <- array(data = c(
179,226,205,
253,205,172,
203,213,232,
244,202,228,
230,245,201,
255,242,174,
241,226,204,
204,204,204),
dim = c(3, 8))

brewerQualitative.Set2 <- array(data = c(
102,194,165,
252,141,98,
141,160,203,
231,138,195,
166,216,84,
255,217,47,
229,196,148,
179,179,179),
dim = c(3, 8))

brewerQualitative.Dark2 <- array(data = c(
27,158,119,
217,95,2,
117,112,179,
231,41,138,
102,166,30,
230,171,2,
166,118,29,
102,102,102),
dim = c(3, 8))

brewerQualitative.Accents <- array(data = c(
127,201,127,
190,174,212,
253,192,134,
255,255,153,
56,108,176,
240,2,127,
191,91,23,
102,102,102),
dim = c(3, 8))

brewer2rgb <- function(col, n = NA) {
  if (is.na(n)) {
    rgb(col[1, ] / 255, col[2, ] / 255, col[3, ] / 255)
  } else {
    seqin  <- seq(0, 1, length = ncol(col))
    seqout <- seq(0, 1, length = n)
    r <- predict(smooth.spline(seqin, col[1, ] / 255), seqout)$y
    g <- predict(smooth.spline(seqin, col[2, ] / 255), seqout)$y
    b <- predict(smooth.spline(seqin, col[3, ] / 255), seqout)$y
    r[r < 0] <- 0 ; r[r > 1] <- 1
    g[g < 0] <- 0 ; g[g > 1] <- 1
    b[b < 0] <- 0 ; b[b > 1] <- 1
    rgb(r, g, b)
  }
}

brewerRemap1 <- function(col, n) {
  seqin  <- seq(0, 1, length = ncol(col))
  seqout <- seq(0, 1, length = n)
  r <- predict(smooth.spline(seqin, col[1, ] / 255), seqout)$y
  g <- predict(smooth.spline(seqin, col[2, ] / 255), seqout)$y
  b <- predict(smooth.spline(seqin, col[3, ] / 255), seqout)$y
  r[r < 0] <- 0 ; r[r > 1] <- 1
  g[g < 0] <- 0 ; g[g > 1] <- 1
  b[b < 0] <- 0 ; b[b > 1] <- 1
  for (i in 1:n) {
    cat(r[i], g[i], b[i], "\n")
  }
}

brewerRemap255 <- function(col, n) {
  seqin  <- seq(0, 255, length = ncol(col))
  seqout <- seq(0, 255, length = n)
  r <- as.integer(predict(smooth.spline(seqin, col[1, ]), seqout)$y + .5)
  g <- as.integer(predict(smooth.spline(seqin, col[2, ]), seqout)$y + .5)
  b <- as.integer(predict(smooth.spline(seqin, col[3, ]), seqout)$y + .5)
  r[r < 0] <- 0 ; r[r > 255] <- 255
  g[g < 0] <- 0 ; g[g > 255] <- 255
  b[b < 0] <- 0 ; b[b > 255] <- 255
  for (i in 1:n) {
    cat(r[i], g[i], b[i], "\n")
  }
}

showpalette <- function (palette) {
  n <- length(palette)
  rgb2hsv <- function(v) rgb(v[1], v[2], v[3])
  x <- seq(0, 1, length=n)
  rgb.m <- matrix(col2rgb(palette) / 255, ncol=3,, byrow=TRUE,
                  dimnames=list(as.character(seq(length=n)),
                    c("red","green","blue")))
  hsv.v <- apply(rgb.m, 1, rgb2hsv)

  opar <- par("fig", "plt")
  par(fig=c(0,1,0,0.7), plt=c(0.15,0.9,0.2,0.95))
  plot(NA, xlim=c(-0.01,1.01), ylim=c(-0.01,1.01), xlab="Spectrum",
       ylab="", xaxs="i", yaxs="i", axes=FALSE)
  title(ylab="Value", mgp=c(3.5,0,0))
  matlines(x, rgb.m, col=colnames(rgb.m), lty=1, lwd=3)
  matpoints(x, rgb.m, col=colnames(rgb.m), pch=16)
  axis(1, at=0:1)
  axis(2, at=0:1, las=1)
  par(fig=c(0,1,0.75,0.9), plt=c(0.08,0.97,0,1), new=TRUE)
  midpoints <- barplot(rep(1,n), col=hsv.v, border=FALSE, space=FALSE,
                       axes=FALSE)
  axis(1, at=midpoints, labels=1:n, lty=0, cex.axis=0.6)
  par(opar)
}


-- 
Peter Kleiweg
http://www.let.rug.nl/~kleiweg/