Autocoloroptions

DESCRIPTION

@@ -38,6 +38,7 @@ Imports:
     cli (>= 3.6.3),
     commonmark (>= 1.9.1),
     dplyr (>= 1.1.4),
+    farver,
     fs (>= 1.6.4),
     glue (>= 1.8.0),
     htmltools (>= 0.5.8.1),

R/data_color.R

@@ -57,7 +57,8 @@
 #' text
 #' - text autocoloring: if colorizing the cell background, `data_color()` will
 #' automatically recolor the foreground text to provide the best contrast (can
-#' be deactivated with `autocolor_text = FALSE`)
+#' be deactivated with `autocolor_text = FALSE`; a light and dark color to be
+#' used can be specified with `autocolor_light` and `autocolor_dark`)
 #'
 #' `data_color()` won't fail with the default options used, but
 #' that won't typically provide you the type of colorization you really need.
@@ -233,6 +234,22 @@
 #'   default this is `"apca"` (Accessible Perceptual Contrast Algorithm) and the
 #'   alternative to this is `"wcag"` (Web Content Accessibility Guidelines).
 #'
+#' @param autocolor_light
+#'
+#'   `scalar<character>` // *default:* `"white"`
+#'
+#'   The light color to use when `autocolor_text = TRUE`. By default the color
+#'   `"white"` will be used (`#FFFFFF"`). Alpha channel values will be set to
+#'   1.0 (fully opaque).
+#'
+#' @param autocolor_dark
+#'
+#'   `scalar<character>` // *default:* `"black"`
+#'
+#'   The dark color to use when `autocolor_text = TRUE`. By default the color
+#'   `"black"` will be used (`#000000"`). Alpha channel values will be set to
+#'   1.0 (fully opaque).
+#'
 #' @param colors *[Deprecated] Color mapping function*
 #'
 #'   `function` // *default:* `NULL` (`optional`)
@@ -363,7 +380,9 @@
 #' setting `autocolor_text` to `FALSE`. The `contrast_algo` argument lets us
 #' choose between two color contrast algorithms: `"apca"` (*Accessible
 #' Perceptual Contrast Algorithm*, the default algo) and `"wcag"` (*Web Content
-#' Accessibility Guidelines*).
+#' Accessibility Guidelines*). `autocolor_light` and `autocolor_dark` allow for
+#' further customization, however, should only be used if you are sure that
+#' accessibility criteria are guaranteed.
 #'
 #' @section Examples:
 #'
@@ -669,6 +688,8 @@ data_color <- function(
     apply_to = c("fill", "text"),
     autocolor_text = TRUE,
     contrast_algo = c("apca", "wcag"),
+    autocolor_light = "#FFFFFF",
+    autocolor_dark = "#000000",
     colors = NULL
 ) {
 
@@ -679,7 +700,7 @@ data_color <- function(
   direction <- rlang::arg_match0(direction, values = c("column", "row"))
 
   # Get the correct `method` value
-  method <- 
+  method <-
     rlang::arg_match0(
       method,
       values = c("auto", "numeric", "bin", "quantile", "factor")
@@ -1122,6 +1143,8 @@ data_color <- function(
       color_vals <-
         ideal_fgnd_color(
           bgnd_color = color_vals,
+          light = autocolor_light,
+          dark = autocolor_dark,
           algo = contrast_algo
         )
 
@@ -1268,8 +1291,10 @@ expand_short_hex <- function(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
-#' output is a single color value in #RRGGBB hexadecimal format
+#' The `bgnd_color` input for this function is a single color value in 'rgba()'
+#' format. The output is a single color value in #RRGGBB hexadecimal format.
+#' `light` and `dark` accepts every color(specification) that can be handled by
+#' {farver}.
 #'
 #' @noRd
 ideal_fgnd_color <- function(
@@ -1282,6 +1307,9 @@ ideal_fgnd_color <- function(
   # Get the correct `algo` value
   algo <- rlang::arg_match0(algo, values = c("apca", "wcag"))
 
+  light_color <- farver::encode_colour(farver::decode_colour(light))
+  dark_color <- farver::encode_colour(farver::decode_colour(dark))
+
   # Normalize color to hexadecimal color if it is in the 'rgba()' string format
   bgnd_color <- rgba_to_hex(colors = bgnd_color)
 
@@ -1291,17 +1319,17 @@ ideal_fgnd_color <- function(
   if (algo == "apca") {
 
     # Determine the ideal color for the chosen background color with APCA
-    contrast_dark <- get_contrast_ratio(color_1 = dark, color_2 = bgnd_color, algo = "apca")[, 1]
-    contrast_light <- get_contrast_ratio(color_1 = light, color_2 = bgnd_color, algo = "apca")[, 1]
+    contrast_dark <- get_contrast_ratio(color_1 = dark_color, color_2 = bgnd_color, algo = "apca")[, 1]
+    contrast_light <- get_contrast_ratio(color_1 = light_color, color_2 = bgnd_color, algo = "apca")[, 1]
 
   } else {
 
     # Determine the ideal color for the chosen background color with WCAG
-    contrast_dark <- get_contrast_ratio(color_1 = dark, color_2 = bgnd_color, algo = "wcag")
-    contrast_light <- get_contrast_ratio(color_1 = light, color_2 = bgnd_color, algo = "wcag")
+    contrast_dark <- get_contrast_ratio(color_1 = dark_color, color_2 = bgnd_color, algo = "wcag")
+    contrast_light <- get_contrast_ratio(color_1 = light_color, color_2 = bgnd_color, algo = "wcag")
   }
 
-  ifelse(abs(contrast_dark) >= abs(contrast_light), dark, light)
+  ifelse(abs(contrast_dark) >= abs(contrast_light), dark_color, light_color)
 }
 
 #' Convert colors in mixed formats (incl. rgba() strings) format to hexadecimal

R/utils_color_contrast.R

@@ -135,7 +135,7 @@ get_relative_luminance_wcag <- function(col) {
 
   coef <- round(c(apca_coeffs$sRco, apca_coeffs$sGco, apca_coeffs$sBco), 4)
 
-  rgb[] <- ifelse(rgb <= 0.03928, rgb / 12.92, ((rgb + 0.055) / 1.055)^2.4)
+  rgb[] <- ifelse(rgb <= 0.04045, rgb / 12.92, ((rgb + 0.055) / 1.055)^2.4)
 
   as.numeric(rgb %*% coef)
 }

tests/testthat/test-data_color.R

@@ -467,6 +467,53 @@ test_that("The correct color values are obtained when defining a palette", {
     html_color(alpha = 1) %>%
     expect_in(pal_12)
 
+  # Create a `tbl_html_6` object by using `data_color` with color names (random
+  # selection) on the `min_sza` column (which is of the `numeric` class); this
+  # time use non-default `autocolor_light` and `autocolor_dark` with #RRGGBB
+  # format
+  tbl_html_6 <-
+    test_tbl %>%
+    gt() %>%
+    data_color(
+      columns = min_sza,
+      palette = c("red", "white", "blue"),
+      autocolor_text = TRUE,
+      autocolor_light = "#EEE9E9",
+      autocolor_dark = "#0D0D0D"
+    ) %>%
+    render_as_html() %>%
+    xml2::read_html()
+
+  # Expect that the text colors vary between #0D0D0D and #EEE9E9
+  # since the `autocolor_text` option is TRUE and these colors are used
+  tbl_html_6 %>%
+    selection_value("style") %>%
+    gsub("(.*: |;$)", "", .) %>%
+    expect_in(c("#0D0D0D", "#EEE9E9"))
+
+  # Create a `tbl_html_7` object by using `data_color` with color names (random
+  # selection) on the `min_sza` column (which is of the `numeric` class); this
+  # time use non-default `autocolor_light` and `autocolor_dark` with color names
+  tbl_html_7 <-
+    test_tbl %>%
+    gt() %>%
+    data_color(
+      columns = min_sza,
+      palette = c("red", "white", "blue"),
+      autocolor_text = TRUE,
+      autocolor_light = "snow2",
+      autocolor_dark = "gray5"
+    ) %>%
+    render_as_html() %>%
+    xml2::read_html()
+
+  # Expect that the text colors vary between #0D0D0D and #EEE9E9
+  # since the `autocolor_text` option is TRUE and these colors are used
+  tbl_html_7 %>%
+    selection_value("style") %>%
+    gsub("(.*: |;$)", "", .) %>%
+    expect_in(c("#0D0D0D", "#EEE9E9"))
+
   # Expect that NAs in column values will result in default colors
   tbl <-
     countrypops %>%
@@ -1192,6 +1239,56 @@ test_that("data_color() validates its input related to color", {
         target_columns = c(row, group),
       )
   )
+
+  # Expect an error if there is a malformed hexadecimal color value given
+  # to `autocolor_light`
+  expect_error(
+    test_tbl %>%
+      gt() %>%
+      data_color(
+        columns = min_sza,
+        palette = c("#EEFFAA", "#45AA22"),
+        autocolor_text = TRUE,
+        autocolor_light = "##EEE9E9"
+      )
+  )
+
+  # Expect an error if there is a malformed hexadecimal color value given
+  # to `autocolor_dark`
+  expect_error(
+    test_tbl %>%
+      gt() %>%
+      data_color(
+        columns = min_sza,
+        palette = c("#EEFFAA", "#45AA22"),
+        autocolor_text = TRUE,
+        autocolor_dark = "#0D0D0DF"
+      )
+  )
+
+  # Expect an error if there is a invalid color name given to `autocolor_light`
+  expect_error(
+    test_tbl %>%
+      gt() %>%
+      data_color(
+        columns = min_sza,
+        palette = c("#EEFFAA", "#45AA22"),
+        autocolor_text = TRUE,
+        autocolor_light = "snoow2"
+      )
+  )
+
+  # Expect an error if there is a invalid color name given to `autocolor_dark`
+  expect_error(
+    test_tbl %>%
+      gt() %>%
+      data_color(
+        columns = min_sza,
+        palette = c("#EEFFAA", "#45AA22"),
+        autocolor_text = TRUE,
+        autocolor_dark = "ggrreey5"
+      )
+  )
 })
 
 test_that("Certain warnings can be expected when using deprecated arguments", {
@@ -1587,7 +1684,7 @@ test_that("The various color utility functions work correctly", {
       "rgba(255,170,0,0.5)", "rgba(255,187,52,1)", "rgba( 127, 46, 22, 0.523 )",
       "rgba(0,0,0,0)", "rgba(128,    20 , 94, 1.000)"
       )
-  ) %>%
+    ) %>%
     all() %>%
     expect_true()
 
@@ -1597,7 +1694,7 @@ test_that("The various color utility functions work correctly", {
       "rgba (255,170,0,0.5)", "rgbc(255,187,52,1)", "rgb( 127, 46, 22, 0.523 )",
       "#FFFFFF", "rgba(128,    20 , 94, a)"
     )
-  ) %>%
+    ) %>%
     any() %>%
     expect_false()
 
@@ -1787,8 +1884,8 @@ test_that("The various color utility functions work correctly", {
 
   # Expect that the `ideal_fgnd_color()` function returns a vector containing
   # either a light color ("#FFFFFF") or a dark color ("#000000") based on the
-  # input colors; this should work with all of the color formats that
-  # `html_color()` produces
+  # `bgnd_color` input colors; this should work with all of the color formats
+  # that `html_color()` produces
   expect_equal(
     ideal_fgnd_color(bgnd_color = c(c_name, c_hex, c_hex_a, c_rgba)),
     c(
@@ -1798,6 +1895,23 @@ test_that("The various color utility functions work correctly", {
     )
   )
 
+  # Expect that the `ideal_fgnd_color()` function returns a vector containing
+  # either a light color or a dark color based on the `bgnd_color` input colors;
+  # this should work with all of the color formats that `html_color()`
+  # produces; this time using non-default `light` and `dark`
+  expect_equal(
+    ideal_fgnd_color(
+      bgnd_color = c(c_name, c_hex, c_hex_a, c_rgba),
+      light = "snow2",
+      dark = "#0D0D0D"
+      ),
+    c(
+      "#EEE9E9", "#0D0D0D", "#EEE9E9", "#0D0D0D", "#0D0D0D", "#EEE9E9",
+      "#0D0D0D", "#0D0D0D", "#EEE9E9", "#EEE9E9", "#EEE9E9", "#EEE9E9",
+      "#0D0D0D", "#0D0D0D", "#0D0D0D", "#0D0D0D", "#0D0D0D"
+    )
+  )
+
   # Expect that the vector of light and dark colors returned is not affected
   # by any of the colors' alpha values
   expect_equal(
@@ -1832,6 +1946,26 @@ test_that("The various color utility functions work correctly", {
   expect_error(
     ideal_fgnd_color(bgnd_color = c(c_hex, c_hex_a, "#FF0033100"))
   )
+  expect_error(
+    ideal_fgnd_color(
+      bgnd_color = c(c_name, c_hex, c_hex_a, c_rgba), light = "##EEE9E9"
+    )
+  )
+  expect_error(
+    ideal_fgnd_color(
+      bgnd_color = c(c_name, c_hex, c_hex_a, c_rgba), dark = "#0D0D0DF"
+    )
+  )
+  expect_error(
+    ideal_fgnd_color(
+      bgnd_color = c(c_name, c_hex, c_hex_a, c_rgba), light = "snoow2"
+    )
+  )
+  expect_error(
+    ideal_fgnd_color(
+      bgnd_color = c(c_name, c_hex, c_hex_a, c_rgba), dark = "ggrreey5"
+    )
+  )
 
   # Expect specific and reproducible output color values in the #RRGGBBAA
   # hexadecimal color format when adjusting color palettes with