Color or style a column by values in another column

[jthomasmock]

Prework

• Read and abide by gt's code of conduct and contributing guidelines.
• Search for duplicates among the existing issues (both open and closed).

Proposal

There are a few requests I've seen on Twitter and gtExtras re: color the background of column 1 based on column 2. Right now, data_color() only operates on the current column, text_transform() only works on the current column (although this can be "abused"), and to properly color the background of a column you end up needing to use tab_style() multiple times.

Requests:

• https://twitter.com/owenlhjphillips/status/1367477806935003139?s=20&t=Y7nOPpiuzeEWgd85L4kwaQ
• https://twitter.com/thomas_mock/status/1302009668814934017?s=20&t=Y7nOPpiuzeEWgd85L4kwaQ
• https://twitter.com/thomas_mock/status/1279090021337903106?s=20&t=Y7nOPpiuzeEWgd85L4kwaQ
• https://twitter.com/robert_binion/status/1557530494102712320?s=20&t=Y7nOPpiuzeEWgd85L4kwaQ
• gt_color_row colouring based on value in a different column jthomasmock/gtExtras#68

Generally, I think that this should be limited to coloring factors/characters with values on another column, but I know that folks may be able to justify coloring numbers by other numbers.

I have a prototype that works like below, relying on tab_style() and a for loop.

set.seed(37)
base_tab <- head(mtcars) |>
  dplyr::slice_sample(n = 6) |>
  dplyr::arrange(desc(mpg)) |>
  gt::gt()

base_tab |>
  gt_color_by_col(mpg, cyl, domain = range(gtExtras::gt_index(base_tab, mpg)))

Full Code

fn_data_clr_by_col <- function(gt_object, col2, value, row_id, color_add){

  gt_object |>
    tab_style(
      style = list(
        cell_fill(color = color_add),
        cell_text(color = gt:::ideal_fgnd_color(color_add))
      ),
      locations = cells_body({{ col2 }}, rows = row_id)
    )

}

gt_color_by_col <- function(
    gt_object, col1, col2, ..., domain = NULL, direction = 1, type = "continuous",
    palette = c("#af8dc3", "#e7d4e8", "#f7f7f7", "#d9f0d3", "#7fbf7b")){

  stopifnot("Table must be of class 'gt_tbl'" = "gt_tbl" %in% class(gt_object))

  full_vals <- gtExtras::gt_index(gt_object = gt_object, {{ col1 }})

  rng_vals <- range(full_vals, na.rm = TRUE)

  if(is.null(domain)){

    domain <- rng_vals
    warning(
      "Domain not specified, defaulting to observed range within each specified column.",
      call. = FALSE
    )
  }

  color_add <- scales::col_numeric(
    palette = if(grepl(x = palette[1], pattern = "::")){
      paletteer::paletteer_d(
        palette = palette,
        direction = direction,
        type = pal_type
      ) %>% as.character()
    } else {
      if(direction == -1){
        rev(palette)
      } else {
        palette
      }
    },
    ...,
    domain = domain
  )(full_vals)

  for (i in 1:length(full_vals)){
    gt_object <- fn_data_clr_by_col(gt_object, {{ col2 }}, full_vals[i], i, color_add[i])
  }
  return(gt_object)
}

[rich-iannone]

Thanks @jthomasmock for collecting all of the requests and providing a prototype in the proposal! We can definitely make this happen soon.