1#' Parse CSS color strings
2#'
3#' Parses/normalizes CSS color strings, and returns them as strings in
4#' `"#RRGGBB"` and/or `"#RRGGBBAA"` format. Understands hex colors in 3, 4, 6,
5#' and 8 digit forms, `rgb()`/`rgba()`, `hsl()`/`hsla()`, and color keywords.
6#'
7#' Note that `parseCssColors` may return colors in `#RRGGBBAA` format. Such
8#' values are not understood by Internet Explorer, and must be converted to
9#' `rgba(red, green, blue, alpha)` format to be safe for the web.
10#'
11#' @param str CSS color strings
12#' @param mustWork If true, invalid color strings will cause an error; if false,
13#'   then the result will contain `NA` for invalid colors.
14#' @return A vector of strings in `#RRGGBB` or `#RRGGBBAA` format (the latter is
15#'   only used for colors whose alpha values are less than `FF`), or `NA` for
16#'   invalid colors when `mustWork` is false. Such strings are suitable for
17#'   use in plots, or parsing with [col2rgb()] (be sure to pass `alpha = TRUE`
18#'   to prevent the alpha channel from being discarded).
19#'
20#' @examples
21#' parseCssColors(c(
22#'   "#0d6efd",
23#'   "#DC35457F",
24#'   "rgb(32,201,151)",
25#'   "  rgba( 23 , 162 , 184 , 0.5 )  ",
26#'   "hsl(261, 51%, 51%)",
27#'   "cornflowerblue"
28#' ))
29#' @export
30parseCssColors <- function(str, mustWork = TRUE) {
31  # Logic below assumes a character string with non-missing values
32  # Note that an empty string is not a valid color, so parsing fails
33  # on NA input values, and thus, will be converted back to NA
34  # when `mustWork = FALSE`
35  isNA <- is.na(str)
36  if (!(is.character(str) || all(isNA))) {
37    stop("`str` must be a character vector (or NA).")
38  }
39  str[isNA] <- ""
40
41  # Strip insignificant whitespace
42  str <- color_strip_ws(str)
43
44  strategies <- list(
45    # #RRGGBBAA and #RRGGBB
46    list(
47      pattern = "^#([[:xdigit:]]{2})([[:xdigit:]]{2})([[:xdigit:]]{2})([[:xdigit:]]{2})?$",
48      decoders = list(
49        decode_hex, # red
50        decode_hex, # green
51        decode_hex, # blue
52        decode_optional(decode_hex, 0xFF) # alpha, optional
53      ),
54      encoder = encode_hex
55    ),
56    # #RGBA and #RGB
57    list(
58      pattern = "^#([[:xdigit:]])([[:xdigit:]])([[:xdigit:]])([[:xdigit:]])?$",
59      decoders = list(
60        decode_hex, # red
61        decode_hex, # green
62        decode_hex, # blue
63        decode_optional(decode_hex, 0xFF) # alpha, optional
64      ),
65      encoder = encode_hex
66    ),
67    # rgb() and rgba()
68    list(
69      pattern = paste0("^rgba?\\(",
70        "(", regex_float, "),",
71        "(", regex_float, "),",
72        "(", regex_float, ")",
73        regex_non_capturing_group(",(", regex_float, ")"), "?",
74        "\\)$"),
75      decoders = list(
76        decode_float_255, # red   [0-255]
77        decode_float_255, # green [0-255]
78        decode_float_255, # blue  [0-255]
79        decode_optional(decode_float_1, 0xFF) # alpha [0-1], optional
80      ),
81      encoder = encode_hex
82    ),
83    # hsl() and hsla()
84    list(
85      pattern = paste0("^hsla?\\(",
86        "(", regex_float, "),",
87        "(", regex_float, ")%,",
88        "(", regex_float, ")%",
89        regex_non_capturing_group(",(", regex_float, ")"), "?",
90        "\\)$"),
91      decoders = list(
92        decode_float_identity, # hue        [0-360]
93        decode_float_identity, # saturation [0-255]
94        decode_float_identity, # lightness  [0-255]
95        decode_optional(decode_float_1, 0xFF) # alpha [0-1], optional
96      ),
97      encoder = encode_hsl
98    ),
99    # color keywords
100    list(
101      pattern = paste0("^", regex_color_keyword, "$"),
102      decoders = list(decode_color_keyword),
103      encoder = encode_hex
104    )
105  )
106
107  success <- rep_len(FALSE, length(str))
108  result <- rep_len(NA_character_, length(str))
109
110  for (strat in strategies) {
111    if (all(success)) {
112      break
113    }
114
115    res <- match_and_decode(
116      str[!success],
117      strat$pattern,
118      !!!strat$decoders
119    )
120    if (any(res$matching_rows)) {
121      result[!success][res$matching_rows] <- strat$encoder(res$values)
122      success[!success][res$matching_rows] <- TRUE
123    }
124  }
125
126  if (mustWork && any(!success)) {
127    stop(sprintf("CSS color value(s) could not be parsed: '%s'", paste0(str[!success], collapse = "', '")))
128  }
129
130  result
131}
132
133# Strips whitespace that isn't significant in the parsing of CSS colors.
134color_strip_ws <- function(str) {
135  str <- gsub("\\s+", " ", str)
136  str <- gsub("^ | $", "", str)
137  str <- gsub(" ?, ?", ",", str)
138  str <- gsub("\\( ", "(", str)
139  str <- gsub(" \\)", ")", str)
140  str
141}
142
143#' Match and decode a string
144#'
145#' Given a vector of strings, applies a regex that contains one or more
146#' capturing groups. Each group's matching substrings are then passed to a
147#' decoder function, which is responsible for returning decoded values. (One
148#' decoder function is provided per capturing roup.)
149#'
150#' After decoding, all of the decoded values are cbind-ed together. The caller
151#' needs to know which elements in `str` actually matched; therefore, the actual
152#' return value is a list with names `matching_rows` and `values` (the latter is
153#' only present if one or more rows actually matched).
154#'
155#' @param pattern Regex that contains the same number of capturing groups as
156#'   unnamed arguments in `...`. The capturing groups MUST be non-overlapping.
157#' @param ... Functions for decoding each capturing group
158#' @noRd
159match_and_decode <- function(str, pattern, ...) {
160  # Example:
161  # str <- c("#123456", "#ABCDEF")
162  # pattern <- "#([0-9A-F]{2})([0-9A-F]{2})([0-9A-F]{2})"
163  # args <- list(decode_hex, decode_hex, decode_hex)
164
165  args <- rlang::list2(...)
166  stopifnot(all(vapply(args, is.function, logical(1))))
167
168  m <- regexec(pattern, str, ignore.case = TRUE)
169  matching_rows <- vapply(m, function(x) { x[1] >= 0 }, logical(1)) # Ex: c(T,T)
170  matches <- regmatches(str[matching_rows], m[matching_rows])
171  if (length(matches) == 0) {
172    return(list(
173      matching_rows = matching_rows
174    ))
175  }
176
177  col_count <- length(matches[[1]])
178  str_matrix <- matrix(unlist(matches), ncol = col_count, byrow = TRUE)
179  # Drop the first column, which is the entire matched string; we only want the
180  # capturing groups
181  str_matrix <- str_matrix[,-1,drop=FALSE]
182  # Number of function arguments should match number of regex's capturing groups
183  stopifnot(length(args) == ncol(str_matrix))
184  # Ex: str_matrix
185  #      [,1] [,2] [,3]
186  # [1,] "12" "34" "56"
187  # [2,] "AB" "CD" "EF"
188  vals <- lapply(seq_len(ncol(str_matrix)), function(i) {
189    # Ex: decode_hex(c("12", "AB")) => c(18, 171)
190    args[[i]](str_matrix[,i])
191  })
192  results <- do.call(cbind, vals)
193  # Ex: results
194  #      [,1] [,2] [,3]
195  # [1,]   18   52   86
196  # [2,]  171  205  239
197
198  return(list(
199    matching_rows = matching_rows,
200    values = results
201  ))
202}
203
204decode_optional <- function(func, default_value) {
205  force(func)
206  force(default_value)
207
208  function(str) {
209    result <- rep_len(default_value, length(str))
210    has_value <- nzchar(str, keepNA = FALSE) & !is.na(str)
211    result[has_value] <- func(str[has_value])
212    result
213  }
214}
215
216# Takes a vector of strings whose elements represent a SINGLE hex color channel
217# (one or two hexadecimal digits) and return an integer in the range [0-255].
218decode_hex <- function(str) {
219  stopifnot(all(nchar(str) %in% c(1,2)))
220
221  # Single hex digits get doubled up
222  str <- ifelse(nchar(str) == 1, paste0(str, str), str)
223
224  res <- strtoi(str, 16)
225  stopifnot(!anyNA(res))
226  res
227}
228
229# Convert strings of floating point numbers [0-255] to integer values in the
230# same range. Valid values outside the range will be clamped. Invalid values
231# will raise errors.
232decode_float_255 <- function(str) {
233  as.integer(pmax(0, pmin(255, round(decode_float_identity(str)))))
234}
235
236# Convert strings of floating point numbers [0-1] to integer values [0-255].
237# Valid values outside the range will be clamped. Invalid values will raise
238# errors.
239decode_float_1 <- function(str) {
240  as.integer(pmax(0, pmin(255, round(decode_float_identity(str) * 255))))
241}
242
243decode_float_identity <- function(str) {
244  stopifnot(all(grepl(paste0("^", regex_float, "$"), str)))
245  as.numeric(str)
246}
247
248encode_hex <- function(values) {
249  if (length(values) == 0) {
250    return(character(0))
251  }
252
253  if (!is.matrix(values)) {
254    stop("encode_hex requires a matrix argument")
255  }
256  if (ncol(values) < 3) {
257    stop("encode_hex called with too few columns")
258  }
259  if (ncol(values) > 4) {
260    stop("encode_hex called with too many columns")
261  }
262  if (!is.numeric(values)) {
263    stop("encode_hex requires numeric values")
264  }
265
266  if (!is.integer(values)) {
267    values <- round(values)
268  }
269
270  if (any(values > 255) || any(values < 0)) {
271    stop("encode_hex values out of bounds")
272  }
273
274  red <- values[,1]
275  green <- values[,2]
276  blue <- values[,3]
277  alpha <- if (ncol(values) > 3) {
278    values[,4]
279  } else {
280    0xFF
281  }
282  colors <- ifelse(alpha == 0xFF,
283    sprintf("#%02X%02X%02X", red, green, blue),
284    sprintf("#%02X%02X%02X%02X", red, green, blue, alpha)
285  )
286  colors
287}
288
289# Convert HTML color keywords (plus "transparent") to integer matrix with 3
290# columns (r, g, b) and length(str) rows. Errors on invalid strings.
291decode_color_keyword <- function(str) {
292  color <- css_color_keywords[tolower(str)]
293  if (anyNA(color)) {
294    stop("Invalid color keyword(s)")
295  }
296  unname(t(grDevices::col2rgb(color, alpha = TRUE)))
297}
298
299encode_hsl <- function(values) {
300  if (length(values) == 0) {
301    return(character(0))
302  }
303
304  if (!is.matrix(values)) {
305    stop("encode_hsl requires a matrix argument")
306  }
307  if (ncol(values) < 3) {
308    stop("encode_hsl called with too few columns")
309  }
310  if (ncol(values) > 4) {
311    stop("encode_hsl called with too many columns")
312  }
313  if (!is.numeric(values)) {
314    stop("encode_hsl requires numeric values")
315  }
316
317  # https://www.w3.org/TR/css-color-3/#hsl-color
318
319  H <- values[,1]
320  S <- values[,2] / 100
321  L <- values[,3] / 100
322  alpha <- if (ncol(values) > 3) {
323    values[,4]
324  } else {
325    0xFF
326  }
327
328  # Clamp
329  H <- (((H %% 360) + 360) %% 360) / 360
330  S <- pmax(0, pmin(1, S))
331  L <- pmax(0, pmin(1, L))
332
333  hue_to_rgb <- function(m1, m2, h) {
334    h <- ifelse(h < 0, h + 1,
335      ifelse(h > 1, h - 1,
336        h))
337    ifelse(h * 6 < 1, m1+(m2-m1)*h*6,
338      ifelse(h * 2 < 1, m2,
339        ifelse(h * 3 < 2, m1+(m2-m1)*(2/3-h)*6,
340          m1)))
341  }
342
343  M2 <- ifelse(L <= 0.5,
344    L * (S + 1),
345    L + S - L * S
346  )
347  M1 <- L * 2 - M2
348
349  rgb <- cbind(
350    hue_to_rgb(M1, M2, H+1/3),
351    hue_to_rgb(M1, M2, H    ),
352    hue_to_rgb(M1, M2, H-1/3)
353  ) * 255
354  rgb <- cbind(rgb, alpha)
355
356  encode_hex(rgb)
357}
358
359css_color_keywords <- c(
360  "transparent" = "#00000000",
361  "aliceblue" = "#F0F8FF", "antiquewhite" = "#FAEBD7", "aqua" = "#00FFFF", "aquamarine" = "#7FFFD4", "azure" = "#F0FFFF", "beige" = "#F5F5DC", "bisque" = "#FFE4C4", "black" = "#000000", "blanchedalmond" = "#FFEBCD", "blue" = "#0000FF", "blueviolet" = "#8A2BE2", "brown" = "#A52A2A", "burlywood" = "#DEB887", "cadetblue" = "#5F9EA0", "chartreuse" = "#7FFF00", "chocolate" = "#D2691E", "coral" = "#FF7F50", "cornflowerblue" = "#6495ED", "cornsilk" = "#FFF8DC", "crimson" = "#DC143C", "cyan" = "#00FFFF", "darkblue" = "#00008B", "darkcyan" = "#008B8B", "darkgoldenrod" = "#B8860B", "darkgray" = "#A9A9A9", "darkgreen" = "#006400", "darkgrey" = "#A9A9A9", "darkkhaki" = "#BDB76B", "darkmagenta" = "#8B008B", "darkolivegreen" = "#556B2F", "darkorange" = "#FF8C00", "darkorchid" = "#9932CC", "darkred" = "#8B0000", "darksalmon" = "#E9967A", "darkseagreen" = "#8FBC8F", "darkslateblue" = "#483D8B", "darkslategray" = "#2F4F4F", "darkslategrey" = "#2F4F4F", "darkturquoise" = "#00CED1", "darkviolet" = "#9400D3", "deeppink" = "#FF1493", "deepskyblue" = "#00BFFF", "dimgray" = "#696969", "dimgrey" = "#696969", "dodgerblue" = "#1E90FF", "firebrick" = "#B22222", "floralwhite" = "#FFFAF0", "forestgreen" = "#228B22", "fuchsia" = "#FF00FF", "gainsboro" = "#DCDCDC", "ghostwhite" = "#F8F8FF", "gold" = "#FFD700", "goldenrod" = "#DAA520", "gray" = "#808080", "green" = "#008000", "greenyellow" = "#ADFF2F", "grey" = "#808080", "honeydew" = "#F0FFF0", "hotpink" = "#FF69B4", "indianred" = "#CD5C5C", "indigo" = "#4B0082", "ivory" = "#FFFFF0", "khaki" = "#F0E68C", "lavender" = "#E6E6FA", "lavenderblush" = "#FFF0F5", "lawngreen" = "#7CFC00", "lemonchiffon" = "#FFFACD", "lightblue" = "#ADD8E6", "lightcoral" = "#F08080", "lightcyan" = "#E0FFFF", "lightgoldenrodyellow" = "#FAFAD2", "lightgray" = "#D3D3D3", "lightgreen" = "#90EE90", "lightgrey" = "#D3D3D3", "lightpink" = "#FFB6C1", "lightsalmon" = "#FFA07A", "lightseagreen" = "#20B2AA", "lightskyblue" = "#87CEFA", "lightslategray" = "#778899", "lightslategrey" = "#778899", "lightsteelblue" = "#B0C4DE", "lightyellow" = "#FFFFE0", "lime" = "#00FF00", "limegreen" = "#32CD32", "linen" = "#FAF0E6", "magenta" = "#FF00FF", "maroon" = "#800000", "mediumaquamarine" = "#66CDAA", "mediumblue" = "#0000CD", "mediumorchid" = "#BA55D3", "mediumpurple" = "#9370DB", "mediumseagreen" = "#3CB371", "mediumslateblue" = "#7B68EE", "mediumspringgreen" = "#00FA9A", "mediumturquoise" = "#48D1CC", "mediumvioletred" = "#C71585", "midnightblue" = "#191970", "mintcream" = "#F5FFFA", "mistyrose" = "#FFE4E1", "moccasin" = "#FFE4B5", "navajowhite" = "#FFDEAD", "navy" = "#000080", "oldlace" = "#FDF5E6", "olive" = "#808000", "olivedrab" = "#6B8E23", "orange" = "#FFA500", "orangered" = "#FF4500", "orchid" = "#DA70D6", "palegoldenrod" = "#EEE8AA", "palegreen" = "#98FB98", "paleturquoise" = "#AFEEEE", "palevioletred" = "#DB7093", "papayawhip" = "#FFEFD5", "peachpuff" = "#FFDAB9", "peru" = "#CD853F", "pink" = "#FFC0CB", "plum" = "#DDA0DD", "powderblue" = "#B0E0E6", "purple" = "#800080", "rebeccapurple" = "#663399", "red" = "#FF0000", "rosybrown" = "#BC8F8F", "royalblue" = "#4169E1", "saddlebrown" = "#8B4513", "salmon" = "#FA8072", "sandybrown" = "#F4A460", "seagreen" = "#2E8B57", "seashell" = "#FFF5EE", "sienna" = "#A0522D", "silver" = "#C0C0C0", "skyblue" = "#87CEEB", "slateblue" = "#6A5ACD", "slategray" = "#708090", "slategrey" = "#708090", "snow" = "#FFFAFA", "springgreen" = "#00FF7F", "steelblue" = "#4682B4", "tan" = "#D2B48C", "teal" = "#008080", "thistle" = "#D8BFD8", "tomato" = "#FF6347", "turquoise" = "#40E0D0", "violet" = "#EE82EE", "wheat" = "#F5DEB3", "white" = "#FFFFFF", "whitesmoke" = "#F5F5F5", "yellow" = "#FFFF00", "yellowgreen" = "#9ACD32"
362)
363
364regex_non_capturing_group <- function(...) { paste0("(?:", ..., ")")}
365regex_float <- "[-+]?[0-9]*\\.?[0-9]+"
366regex_color_keyword <- paste0("(", paste0(names(css_color_keywords), collapse = "|"), ")")
367