-
Notifications
You must be signed in to change notification settings - Fork 22
/
colors.R
269 lines (235 loc) · 10 KB
/
colors.R
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
#' @title Color palettes in `jtools` functions
#'
#' @description `jtools` combines several options into the `colors`
#' argument in plotting functions.
#'
#' @details
#' The argument to `colors` in functions like `effect_plot`,
#' `plot_coefs`, and others is very flexible but may also
#' cause confusion.
#'
#' If you provide an argument of length 1, it is assumed that you are naming
#' a palette. `jtools` provides 6 color palettes design for qualitative data.
#' 4 of the 6 are based on Paul Tol's suggestions (see references) and are
#' meant to both optimize your ability to quickly differentiate the colors
#' and to be distinguishable to colorblind people.
#' These are called
#' `"Qual1"`, `"Qual2"`, `"Qual3"`, `"CUD"`, `"CUD Bright"`, and `"Rainbow"`.
#' Each of the "Qual" schemes comes from Paul Tol.
#' "Rainbow" is Paul Tol's compromise rainbow color scheme that is fairly
#' differentiable for colorblind people and when rendered in grayscale.
#' `"CUD Bright"` is a brightened and reordered version of Okabe and Ito's
#' suggestions for 'Color Universal Design' while `"CUD"` is their exact
#' scheme (see references). `"CUD Bright"` is the default for qualitative
#' scales in `jtools` functions.
#'
#' You may also provide any color palette supported by `RColorBrewer`.
#' See all of those options at [RColorBrewer::brewer.pal()]'s documentation.
#' If you provide one of `RColorBrewer`'s sequential palettes, like "Blues",
#' `jtools` automatically requests one more color than needed from
#' `brewer.pal` and then drops the lightest color. My experience is that
#' those scales tend to give one color that is too light to easily
#' differentiate against a white background.
#'
#' For **gradients**, you can use any of the `RColorBrewer` sequential palette
#' names and get comparable results on a continuous scale. There are also some
#' `jtools`-specific gradient schemes: `"blue"`, `"blue2"`, `"green"`,
#' `"red"`, `"purple"`, `"seagreen"`.
#' If you want something a little non-standard, I'd suggest taking a look
#' at `"blue2"` or `"seagreen"`.
#'
#' Lastly, you may provide colors by name. This must be a vector of the
#' same length as whatever it is the colors will correspond to. The format
#' must be one understood by `ggplot2`'s manual scale functions. This
#' basically means it needs to be in hex format (e.g., "#000000") or
#' one of the many names R understands (e.g., "red"; use `colors()` to
#' see all of those options).
#'
#' @references
#'
#' Paul Tol's site is what is used to derive 4 of the 6 `jtools`-specific
#' qualitative palettes: \url{https://personal.sron.nl/~pault/}
#'
#' Okabe and Ito's palette inspired "CUD Bright", though "CUD Bright" is not
#' exactly the same. "CUD" is the same.
#' See \url{https://web.archive.org/web/20190216090108/jfly.iam.u-tokyo.ac.jp/color/}
#' for more.
#'
#' @rdname jtools_colors
#' @name jtools_colors
NULL
#' @title Get colors for plotting functions
#' @description This is a helper function that provides hex color codes for
#' `jtools`, `interactions`, and perhaps other packages.
#' @param colors The name of the desired color class or a vector of colors.
#' See details of [jtools_colors].
#' @param num.colors How many colors should be returned? Default is 1.
#' @param reverse Should the colors be returned in reverse order, compared to
#' normal? Default is FALSE.
#' @param gradient Return endpoints for a gradient? Default is FALSE. If TRUE,
#' `num.colors` is ignored.
#' @importFrom grDevices rgb
#' @export
get_colors <- function(colors, num.colors = 1, reverse = FALSE,
gradient = FALSE) {
# Check if just passing through user-specified colors
if (length(colors) > 1 && gradient == FALSE) {
if (reverse) colors <- rev(colors)
return(colors)
}
# Save all valid color brewer names
## Sequential palettes get different treatment
sequentials <-
c("Blues", "BuGn", "BuPu", "GnBu", "Greens", "Greys", "Oranges", "OrRd",
"PuBu", "PuBuGn", "PuRd", "Purples", "RdPu", "Reds", "YlGn", "YlGnBu",
"YlOrBr", "YlOrRd")
div_or_qual <-
c("BrBG", "PiYG", "PRGn", "PuOr", "RdBu", "RdGy", "RdYlBu", "RdYlGn",
"Spectral", "Accent", "Dark2", "Paired", "Pastel1", "Pastel2", "Set1",
"Set2", "Set3")
brewers <- c(sequentials, div_or_qual)
viridis <- c("viridis", "magma", "A", "inferno", "B", "plasma", "C",
"D", "cividis", "E")
if (length(colors) == 1 && colors %in% c(brewers, viridis) &&
gradient == FALSE) {
if (colors %in% sequentials) {
# I drop the lightest color if possible
colors <- RColorBrewer::brewer.pal(num.colors + 1, colors)[-1]
colors <- colors[seq_len(num.colors)]
} else if (colors %in% viridis) {
colors <- rev(scales::viridis_pal(option = colors)(num.colors))
} else {
colors <- RColorBrewer::brewer.pal(num.colors, colors)
}
} else if (length(colors) == 1 && colors %in% viridis) {
# I order these differently than the default for gradients
colors <- rev(scales::viridis_pal(option = colors)(num.colors))
}
# My own palettes
mine <- c("CUD", "CUD Bright", "Rainbow", "Qual1", "Qual2", "Qual3")
if (length(colors) == 1 && colors %in% mine) {
# The order of these depends on how many are requested
cb14 <- c("#4477AA", "#EE6677", "#228833", "#CC8844")
cb16 <- c("#4477AA", "#66CCEE", "#228833", "#CC8844", "#EE6677",
"#AA3377")
cb22 <- c("#4477AA", "#CC6677")
cb21 <- cb22[1]
cb23 <- c("#4477AA", "#DDCC77", "#CC6677")
cb24 <- c("#4477AA", "#117733", "#DDCC77", "#CC6677")
cb25 <- c("#332288", "#88CCEE", "#117733", "#DDCC77", "#CC6677")
cb26 <- c("#332288", "#88CCEE", "#117733", "#DDCC77",
"#CC6677", "#AA4499")
cb27 <- c("#332288", "#88CCEE", "#44AA99", "#117733", "#DDCC77",
"#CC6677", "#AA4499")
cb28 <- c("#332288", "#88CCEE", "#44AA99", "#117733", "#DDCC77",
"#CC6677")
cb29 <- c("#332288", "#88CCEE", "#44AA99", "#117733", "#999933",
"#DDCC77", "#CC6677")
cb2 <- list(cb21, cb22, cb23, cb24, cb25, cb26, cb27, cb28, cb29)
cb3 <- c("#3366AA", "#EE3333", "#11AA99", "#992288", "#66AA55",
"#EE7722", "#CCCC55", "#FFEE33")
cud <- c("#D55E00", "#56B4E9", "#009E73", "#CC79A7", "#0072B2", "#E69F00",
"#F0E442", "#999999")
cudb <- c("#49b7fc", "#ff7b00", "#17d898", "#ff0083", "#0015ff", "#e5d200",
"#999999")
# Function to produce rainbow color
rainbow_col <- function(x) {
r_num <- .472 - .567*x + 4.05*(x^2)
r_den <- 1 + 8.72*x - 19.17*(x^2) + 14.1*(x^3)
r <- r_num/r_den
g <- .108932 - 1.22635*x + 27.284*(x^2) - 98.577*(x^3) +
163.3*(x^4) - 131.395*(x^5) + 40.634*(x^6)
b <- 1.97 + 3.54*x - 68.5*(x^2) + 243*(x^3) - 297*(x^4) + 125*(x^5)
b <- 1/b
rgb <- c("r" = r, "g" = g, "b" = b)
return(rgb)
}
# This function gives a vector of the colors of length y
rainbow_cols <- function(y) {
y <- seq(from = 0, to = 1, length = y)
rgbs <- lapply(y, rainbow_col) # nolint
hexs <- sapply(rgbs, function(x) {
rgb(x[1], x[2], x[3])
})
return(hexs)
}
if (colors == "Qual2") {
if (num.colors <= 4) {
colors <- cb14[seq_len(num.colors)]
} else if (num.colors %in% c(5, 6)) {
colors <- cb16[seq_len(num.colors)]
} else {
stop_wrap("Only 6 or fewer colors supported with the Qual2 color
class.")
}
} else if (colors == "Qual3") {
if (num.colors > length(cb2)) {
stop_wrap("Only ", length(cb2), " or fewer colors are supported with
the Qual3 color class.")
}
colors <- unlist(cb2[num.colors])
} else if (colors == "Qual1") {
if (num.colors > length(cb3)) {
stop_wrap("Only ", length(cb3), " or fewer colors are supported with
the Qual1 color class.")
}
colors <- cb3[seq_len(num.colors)]
} else if (colors == "CUD Bright") {
if (num.colors > length(cudb)) {
stop_wrap("Only ", length(cudb), " or fewer colors are supported with
the CUD Bright color class.")
}
colors <- cudb[seq_len(num.colors)]
} else if (colors == "CUD") {
if (num.colors > length(cud)) {
stop_wrap("Only ", length(cud), " or fewer colors are supported with
the CUD color class.")
}
colors <- cud[seq_len(num.colors)]
} else if (colors == "Rainbow") {
colors <- rainbow_cols(num.colors)
}
}
if (gradient == TRUE && length(colors) == 1) {
if (colors == "Blues") {
colors <- c("#C6DBEF", "#08519C")
} else if (colors == "Oranges") {
colors <- c("#FDD0A2", "#7F2704")
} else if (colors == "Greens") {
colors <- c("#C7E9C0", "#00441B")
} else if (colors == "Reds") {
colors <- c("#FCBBA1", "#67000D")
} else if (colors == "Purples") {
colors <- c("#DADAEB", "#3F007D")
} else if (colors == "Greys") {
colors <- c("#D9D9D9", "#000000")
} else if (colors == "blue") {
# colors <- c("#99bbff", "#003399")
colors <- c("#9ed2fa", "#06477a")
} else if (colors == "green") {
colors <- c("#33ff33", "#004d00")
} else if (colors == "red") {
colors <- c("#ff9999", "#800000")
} else if (colors == "purple") {
colors <- c("#cc99ff", "#330066")
} else if (colors == "seagreen") {
colors <- c("#85e0e0", "#004d4d")
} else if (colors == "blue2") {
colors <- c("#C2CEFA", "#33559B")
} else if (colors %in% brewers) {
colors <- RColorBrewer::brewer.pal(num.colors, colors)
} else {
stop_wrap(colors, " color class was not found.")
}
}
if (length(colors) >= num.colors) {
colors <- colors[seq_len(num.colors)]
} else if (length(colors) == 2 && gradient == TRUE) {
colors <- colors
} else {
stop_wrap("Provided colors vector is not as long as the number of colors
needed.")
}
if (reverse == TRUE) colors <- rev(colors)
return(colors)
}