Merge branch 'master' into useful-error-msgs

R/compile_scss.R

@@ -4,8 +4,15 @@ compile_scss <- function(data, id = NULL) {
   # Obtain the SCSS options table from `data`
   gt_options_tbl <-
     dt_options_get(data = data) %>%
-    subset(scss) %>%
-    subset(!is.na(value))
+    dplyr::filter(scss) %>%
+    dplyr::filter(!is.na(value)) %>%
+    dplyr::mutate(
+      value = {
+        color_rows <- grepl("_color", .data$parameter)
+        value[color_rows] <- lapply(value[color_rows], html_color)
+        value
+      }
+    )
 
   has_id <- !is.null(id)
 

R/data_color.R

@@ -288,17 +288,28 @@ is_rgba_col <- function(colors) {
   grepl("^rgba\\(\\s*(?:[0-9]+?\\s*,\\s*){3}[0-9\\.]+?\\s*\\)$", colors)
 }
 
+#' Are color values in hexadecimal format?
+#'
+#' This regex checks for valid hexadecimal colors in either the `#RRGGBB` and
+#' `#RRGGBBAA` forms (not including shortened form `#RGB` here)
+#'
+#' @noRd
+is_hex_col <- function(colors) {
+
+  grepl("^#[0-9a-fA-F]{6}([0-9a-fA-F]{2})?$", colors)
+}
+
 #' For a background color, which foreground color provides better contrast?
 #'
-#' The input for this function is a single color value in rgba() format. The
+#' The input for this function is a single color value in 'rgba()' format. The
 #' output is a single color value in #RRGGBB hexadecimal format
 #'
 #' @noRd
 ideal_fgnd_color <- function(bgnd_color,
                              light = "#FFFFFF",
                              dark = "#000000") {
 
-  # Normalize color to hexadecimal color if it is in the rgba() string format
+  # Normalize color to hexadecimal color if it is in the 'rgba()' string format
   bgnd_color <- rgba_to_hex(colors = bgnd_color)
 
   # Normalize color to a #RRGGBB (stripping the alpha channel)
@@ -314,9 +325,9 @@ ideal_fgnd_color <- function(bgnd_color,
 #' Convert colors in mixed formats (incl. rgba() strings) format to hexadecimal
 #'
 #' This function will accept colors in mixed formats and convert any in the
-#' rgba() string format (e.g., "`rgba(255,170,0,0.5)`") to a hexadecimal format
-#' the preserves the alpha information (#RRGGBBAA). This function is required
-#' for the `ideal_fgnd_color()` function.
+#' 'rgba()' string format (e.g., "`rgba(255,170,0,0.5)`") to a hexadecimal
+#' format that preserves the alpha information (#RRGGBBAA). This function is
+#' required for the `ideal_fgnd_color()` function.
 #'
 #' @noRd
 rgba_to_hex <- function(colors) {
@@ -361,7 +372,7 @@ rgba_to_hex <- function(colors) {
 #' colors in hexadecimal format with or without an alpha component (either
 #' #RRGGBB or #RRGGBBAA). Output is the same length vector as the
 #' input but it will contain a mixture of either #RRGGBB colors (if the input
-#' alpha value for a color is 1) or rgba() string format colors (if the input
+#' alpha value for a color is 1) or 'rgba()' string format colors (if the input
 #' alpha value for a color is not 1).
 #'
 #' @noRd
@@ -372,21 +383,67 @@ html_color <- function(colors, alpha = NULL) {
     stop("No values supplied in `colors` should be NA")
   }
 
-  # Utility function for creating rgba() color values
-  # from an RGBA color matrix (already subsetted to those
-  # rows where alpha < 1)
-  col_matrix_to_rgba <- function(color_matrix) {
-
-    paste0(
-      "rgba(",
-      color_matrix[, "red"], ",",
-      color_matrix[, "green"], ",",
-      color_matrix[, "blue"], ",",
-      round(color_matrix[, "alpha"], 2),
-      ")"
-    )
+  is_rgba <- is_rgba_col(colors)
+  is_hex <- is_hex_col(colors)
+  is_named <- !is_rgba & !is_hex
+
+  colors[is_named] <- tolower(colors[is_named])
+
+  named_colors <- colors[is_named]
+
+  if (length(named_colors) > 0) {
+
+    # Ensure that all color names are in the set of X11/R color
+    # names or CSS color names
+    check_named_colors(named_colors)
+
+    # Translate any CSS exclusive colors to hexadecimal values;
+    # there are nine CSS 3.0 named colors that don't belong to the
+    # set of X11/R color names (not included numbered variants and
+    # the numbered grays, those will be handled by `grDevices::col2rgb()`)
+    is_css_excl_named <- colors %in% names(css_exclusive_colors())
+
+    if (any(is_css_excl_named)) {
+
+      # The `css_exclusive_colors()` function returns a named vector
+      # of the CSS colors not in the X11/R set; the names are the hexadecimal
+      # color values
+      colors[is_css_excl_named] <-
+        unname(css_exclusive_colors()[colors[is_css_excl_named]])
+    }
   }
 
+  # Normalize all non-'rgba()' color values and combine
+  # with any preexisting 'rgba()' color values
+  colors[!is_rgba] <-
+    normalize_colors(
+      colors = colors[!is_rgba],
+      alpha = alpha
+    )
+
+  colors
+}
+
+# Utility function for creating 'rgba()' color values
+# from an RGBA color matrix (already subsetted to those
+# rows where alpha < 1)
+col_matrix_to_rgba <- function(color_matrix) {
+
+  paste0(
+    "rgba(",
+    color_matrix[, "red"], ",",
+    color_matrix[, "green"], ",",
+    color_matrix[, "blue"], ",",
+    round(color_matrix[, "alpha"], 2),
+    ")"
+  )
+}
+
+# Utility function for generating hexadecimal or 'rgba()' colors (for IE11
+# compatibility with colors having some transparency) from hexadecimal color
+# values and X11/R color names
+normalize_colors <- function(colors, alpha) {
+
   # Create a color matrix with an `alpha` column
   color_matrix <- t(grDevices::col2rgb(col = colors, alpha = TRUE))
   color_matrix[, "alpha"] <- color_matrix[, "alpha"] / 255
@@ -418,3 +475,43 @@ html_color <- function(colors, alpha = NULL) {
 
   colors_html
 }
+
+css_exclusive_colors <- function() {
+
+  color_tbl_subset <- css_colors[!css_colors$is_x11_color, ]
+
+  color_values <- color_tbl_subset[["hexadecimal"]]
+
+  color_values <-
+    stats::setNames(
+      color_values,
+      tolower(color_tbl_subset[["color_name"]])
+    )
+
+  color_values
+}
+
+valid_color_names <- function() {
+  c(tolower(grDevices::colors()), names(css_exclusive_colors()))
+}
+
+check_named_colors <- function(named_colors) {
+
+  named_colors <- tolower(named_colors)
+
+  if (!all(named_colors %in% valid_color_names())) {
+
+    invalid_colors <- base::setdiff(unique(named_colors), valid_color_names())
+
+    stop(
+      ifelse(
+        length(invalid_colors) > 1,
+        "Several invalid color names were ",
+        "An invalid color name was "
+      ), "used (", str_catalog(invalid_colors, conj = "and"), "):\n",
+      " * Only R/X11 color names and CSS 3.0 color names can be used",
+      call. = FALSE
+    )
+  }
+}
+

R/helpers.R

@@ -1790,16 +1790,15 @@ cell_text <- function(color = NULL,
                       transform = NULL) {
 
   # Get all assigned values for the functions' arguments
-  style_names <- formals(cell_text) %>% names()
-  style_names <- mget(style_names)
+  style_names <- mget(names(formals(cell_text)))
 
   # Filter list by only the non-NULL (e.g., assigned with
   # value) elements
-  style_vals <- style_names %>% .[!vapply(., is.null, logical(1))]
+  style_vals <- style_names[!vapply(style_names, is.null, logical(1))]
 
   # Get a vector of argument names (`style_names`) for
   # validation purposes
-  style_names <- style_vals %>% names()
+  style_names <- names(style_vals)
 
   #
   # Validate textual styles values with `validate_style_in()`
@@ -1851,12 +1850,18 @@ cell_text <- function(color = NULL,
     in_vector = c("uppercase", "lowercase", "capitalize")
   )
 
+  # Transform the `color` value, if present, so that X11 color names
+  # can be used in all output contexts
+  if ("color" %in% style_names) {
+    style_vals$color <- html_color(colors = style_vals$color)
+  }
+
   cell_style_structure(name = "cell_text", obj = style_vals)
 }
 
 cell_style_to_html.cell_text <- function(style) {
 
-  css <- style %>% unclass()
+  css <- unclass(style)
 
   css_names <-
     c(
@@ -1940,9 +1945,9 @@ cell_fill <- function(color = "#D3D3D3",
     stop("If provided, `alpha` must be a single value", call. = FALSE)
   }
 
-  if (!is_rgba_col(color)) {
-    color <- html_color(colors = color, alpha = alpha)
-  }
+  # Transform the `color` value, if present, so that X11 color names
+  # can be used in all output contexts
+  color <- html_color(colors = color, alpha = alpha)
 
   style_vals <- list(color = color)
 
@@ -2072,14 +2077,16 @@ cell_borders <- function(sides = "all",
     "bottom", "b",
     "all", "everything", "a"
   ))) {
-    stop("The `sides` vector for `cell_borders()` has to include one ",
-         "or more of the following keywords (or short forms):\n",
-         " * \"left\" (or: \"l\")\n",
-         " * \"right\" (or: \"r\")\n",
-         " * \"top\" (or: \"t\")\n",
-         " * \"bottom\" (or: \"b\")\n",
-         " * \"all\" (or: \"a\", \"everything\"",
-         call. = FALSE)
+    stop(
+      "The `sides` vector for `cell_borders()` has to include one ",
+      "or more of the following keywords (or short forms):\n",
+      " * \"left\" (or: \"l\")\n",
+      " * \"right\" (or: \"r\")\n",
+      " * \"top\" (or: \"t\")\n",
+      " * \"bottom\" (or: \"b\")\n",
+      " * \"all\" (or: \"a\", \"everything\"",
+      call. = FALSE
+    )
   }
 
   # Resolve the selection of borders into a vector of