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