Color a column by another column's value

Question

I would like to create a gt table where I display numeric values from two columns together in a single cell, but color the cells based on just one of the column's values.

For example using the ToothGrowth example data I'd like to put the len and dose columns together in a single cell but color the cell backgrounds by the value of dose.

I tried to manually create a vector of colors to color the len_dose column but this does not work because it seems like it is reapplying the color vector to each different level of len_dose, not dose. I guess you could manually format the cells with tab_style() but that seems inefficient and does not give you the nice feature where the text color changes to maximize contrast with background. I don't know an efficient way to do this.

What I tried:

library(gt)
library(dplyr)
library(scales)
library(glue)

# Manually map dose to color
dose_colors <- col_numeric(palette = 'Reds', domain = range(ToothGrowth$dose))(ToothGrowth$dose)

ToothGrowth %>%
  mutate(len_dose = glue('{len}: ({dose})')) %>%
  gt(rowname_col = 'supp') %>%
  cols_hide(c(len, dose)) %>%
  data_color(len_dose, colors = dose_colors)  

Output (not good because not colored by dose):

Answer 1

Update Feb 2023

The option to color based on another column has now been added to the gt package - data_color() has gained a taregt_columns argument. So this has become much simpler:

library(gt)
library(dplyr)

ToothGrowth %>%
  mutate(len_dose = glue('{len}: ({dose})')) %>%
  gt(rowname_col = 'supp') %>%
  cols_hide(c(len, dose)) %>%
  data_color(columns = "dose", target_columns = "len_dose",
             palette = "ggsci::green_material")

---

Outdated

I faced the same issue and adjusted the gt::data_color function to accept separate source and target columns - with that, the following should work to produce your desired output.

# Distinguish SOURCE_columns and TARGET_columns

my_data_color <- function (data, SOURCE_columns, TARGET_columns, colors, alpha = NULL, apply_to = c("fill", 
                                                                                                    "text"), autocolor_text = TRUE) 
{
  stop_if_not_gt(data = data)
  apply_to <- match.arg(apply_to)
  colors <- rlang::enquo(colors)
  data_tbl <- dt_data_get(data = data)
  colors <- rlang::eval_tidy(colors, data_tbl)
  resolved_source_columns <- resolve_cols_c(expr = {
    {
      SOURCE_columns
    }
  }, data = data)
  resolved_target_columns <- resolve_cols_c(expr = {
    {
      TARGET_columns
    }
  }, data = data)
  rows <- seq_len(nrow(data_tbl))
  data_color_styles_tbl <- dplyr::tibble(locname = character(0), 
                                         grpname = character(0), colname = character(0), locnum = numeric(0), 
                                         rownum = integer(0), colnum = integer(0), styles = list())
  for (i in seq_along(resolved_source_columns)) {
    data_vals <- data_tbl[[resolved_source_columns[i]]][rows]
    if (inherits(colors, "character")) {
      if (is.numeric(data_vals)) {
        color_fn <- scales::col_numeric(palette = colors, 
                                        domain = data_vals, alpha = TRUE)
      }
      else if (is.character(data_vals) || is.factor(data_vals)) {
        if (length(colors) > 1) {
          nlvl <- if (is.factor(data_vals)) {
            nlevels(data_vals)
          }
          else {
            nlevels(factor(data_vals))
          }
          if (length(colors) > nlvl) {
            colors <- colors[seq_len(nlvl)]
          }
        }
        color_fn <- scales::col_factor(palette = colors, 
                                       domain = data_vals, alpha = TRUE)
      }
      else {
        cli::cli_abort("Don't know how to map colors to a column of class {class(data_vals)[1]}.")
      }
    }
    else if (inherits(colors, "function")) {
      color_fn <- colors
    }
    else {
      cli::cli_abort("The `colors` arg must be either a character vector of colors or a function.")
    }
    color_fn <- rlang::eval_tidy(color_fn, data_tbl)
    color_vals <- color_fn(data_vals)
    color_vals <- html_color(colors = color_vals, alpha = alpha)
    color_styles <- switch(apply_to, fill = lapply(color_vals, 
                                                   FUN = function(x) cell_fill(color = x)), text = lapply(color_vals, 
                                                                                                          FUN = function(x) cell_text(color = x)))
    data_color_styles_tbl <- dplyr::bind_rows(data_color_styles_tbl, 
                                              generate_data_color_styles_tbl(column = resolved_target_columns[i], rows = rows, 
                                                                             color_styles = color_styles))
    if (apply_to == "fill" && autocolor_text) {
      color_vals <- ideal_fgnd_color(bgnd_color = color_vals)
      color_styles <- lapply(color_vals, FUN = function(x) cell_text(color = x))
      data_color_styles_tbl <- dplyr::bind_rows(data_color_styles_tbl, 
                                                generate_data_color_styles_tbl(column = resolved_target_columns[i], 
                                                                               rows = rows, color_styles = color_styles))
    }
  }
  dt_styles_set(data = data, styles = dplyr::bind_rows(dt_styles_get(data = data), 
                                                       data_color_styles_tbl))
}


# Add function into gt namespace (so that internal gt functions can be called)
library(gt)
tmpfun <- get("data_color", envir = asNamespace("gt"))
environment(my_data_color) <- environment(tmpfun)

library(dplyr)
#> 
#> Attaching package: 'dplyr'
#> The following objects are masked from 'package:stats':
#> 
#>     filter, lag
#> The following objects are masked from 'package:base':
#> 
#>     intersect, setdiff, setequal, union
library(glue)

# Map dose to color
ToothGrowth %>%
  mutate(len_dose = glue('{len}: ({dose})')) %>%
  gt(rowname_col = 'supp') %>%
  cols_hide(c(len, dose)) %>%
  my_data_color(SOURCE_columns = "dose", TARGET_columns = "len_dose", 
             colors = scales::col_numeric(palette = c("red", "green"), domain = c(min(ToothGrowth$dose), max(ToothGrowth$dose))))  

^{Created on 2022-11-03 with reprex v2.0.2}

Answer 2

Not sure if you found a solution to this yet but here is what I did:

• If you use tab_style() you don't need to try and create the vector of colors and can instead set the background color you want based on the dose column. If you want to color values differently based on dose, in addition to what I've colored here, then create another tab_style() for the desired value.

  library(gt)
   library(dplyr)
   library(scales)
   library(glue)
  
   ToothGrowth %>%
     mutate(len_dose = glue('{len}: ({dose})')) %>%
     gt(rowname_col = 'supp') %>%
     tab_style(
       style = cell_fill(color = "palegreen"),
       location = cells_body(
         columns = len_dose,
         rows = dose >= 1.0
       )
     ) %>%
     cols_hide(c(len, dose))