Search code examples
rif-statementgtcolor-palette

R gt Package - Choose colorpalette accodring to value in cells

I am sorry, I already asked 2 similar questions, but I guess they werent clear enough.

My problem: I have a dataframe with a very wide range of numbers. Since I have numbers that are 300x higher than the average, I cant use a normal color scheme, since most of the colors would be the same. I also want to see the differences in the smaller numbers aswell.

I saw this question, similar to mine, but only with 2 different color palettes. Set asymmetric midpoint for data_color in gt table

Now I have created color-palettes on my own and wrote that function. It works perfectly with only 2 color-palettes. But I am struggling to do it with 4. The ifelse-statement doesnt work there and I cant think of any other alternative.

emerald = c("#d3f2a3","#97e196","#6cc08b","#4c9b82","#217a79","#105965","#074050")
oryel = c("#ecda9a","#efc47e","#f3ad6a","#f7945d","#f97b57","#f66356","#ee4d5a")
sunshort = c("#dc3977","#b9257a","#7c1d6f")
toplevel = c("#6c2167", "#541f3f")



pal <- function(x) {
  f_neg <- scales::col_numeric(
    palette = c(emerald),
    domain = c(min(test), 0))
  f_pos1 <- scales::col_numeric(
    palette = c(oryel),
    domain = c(0, 300))
  f_pos2 <- scales::col_numeric(
      palette = c(sunshort),
      domain = c(300, 500))
  f_pos3 <- scales::col_numeric(
    palette = c(toplevel),
    domain = c(500, max(test))
  
  ifelse(x < 0, f_neg(x), f_pos1(x))}

library(gt)
    gt(test)%>%
      data_color(columns = c(1,2),
               colors = pal)


structure(list(Delta_p = c(-19.98, 51.22, NA, 57.61, -17.01, 
    27.76, NA, 43.7, 25.75, NA, NA, 28.72, NA, 52.07, 45.12, NA, 
    -41.56, -16.81, 14.35, -20.09, -35.17, NA, 23.91, 54.09, NA, 
    NA, 10.53, NA, 28.97, 36.76, -11.25, 48.61, 99.01, -20, 137.5, 
    NA, 29.19, 26.71, -29.74, -18, 57.66, -41.91, 25.5, 29.01, 12.47, 
    NA, 22.19, -52.42, 19.01, 32.71, 43.39, NA, 123.88, 76.71, 45.96, 
    105.85, 47.71, 51.72, NA, 43.7, -38.04, -25.05, 45.96, NA, 71.93, 
    12.77, NA, -33.59, 577.78, 52.2, 24.44, 27.06, 127.27, -35.53, 
    -21.34, NA, 8.33, 22.46, 27.65, 93.1, 37.87, 58.9, -19.67, -25.53, 
    -24.35, 27.21, NA, -57.4, 16.62, 16.48, 14.71, 24.81, -30.33, 
    40.79, 45.02, 70.13, 68.65, 29.6, 13.28, -11.87), Delta_n = c(32.25, 
    NA, -20.49, 43.61, -22.97, 26.87, 46.58, 28.69, 46.56, 94.12, 
    36.67, 96.05, 50.15, 59.35, 24.95, 47.93, NA, NA, 28.26, 59.56, 
    -17.03, 89.47, -26.11, 35.5, 29.76, 69.09, NA, 27.75, -13.47, 
    43.58, NA, 72.22, 52.28, -24.95, NA, -16.4, 65.49, 51.58, 23.94, 
    -19.1, -21.1, 70.97, NA, -26.96, 22.39, -21.74, 20.47, 27.33, 
    41.44, 24.69, 32.33, 68.16, -23.7, NA, -19.9, NA, NA, -19.9, 
    -19.71, 24.91, NA, 24.85, 30.38, 23.72, 89.67, NA, 69.05, NA, 
    NA, 35.07, 37.39, -32.13, 90.91, 28.08, -13.34, 24.23, -20.49, 
    NA, -15.04, 100.86, NA, NA, -18.1, 16.85, NA, 18.38, 276.83, 
    22.82, 36, -9.78, NA, 20.83, NA, 21.54, 52.36, -23.95, NA, 12.74, 
    NA, 20.36)), row.names = c(2117L, 2609L, 200L, 340L, 1576L, 1353L, 
    1710L, 832L, 1530L, 895L, 1980L, 92L, 273L, 884L, 1784L, 452L, 
    2610L, 2109L, 733L, 261L, 2277L, 1447L, 1588L, 1803L, 1989L, 
    275L, 2192L, 2500L, 1876L, 2077L, 1637L, 2536L, 971L, 2596L, 
    283L, 360L, 1316L, 83L, 1310L, 2000L, 529L, 2201L, 2189L, 563L, 
    1486L, 487L, 2046L, 97L, 98L, 1554L, 1769L, 2318L, 782L, 1845L, 
    196L, 802L, 2414L, 198L, 1712L, 2220L, 1201L, 2480L, 2491L, 2237L, 
    2539L, 2207L, 2537L, 1432L, 73L, 730L, 2477L, 582L, 1209L, 2291L, 
    2336L, 737L, 1853L, 2409L, 1281L, 426L, 1054L, 1205L, 566L, 1299L, 
    129L, 2069L, 948L, 846L, 1723L, 1148L, 208L, 490L, 2269L, 6L, 
    1187L, 1184L, 2091L, 2143L, 1439L, 1703L), class = "data.frame")

UPDATE

pal <- function(x) {
  f_neg <- scales::col_numeric(
    palette = c(emerald),
    domain = c(min_delta, 0))
  f_pos1 <- scales::col_numeric(
    palette = c(oryel),
    domain = c(0, 300))
  f_pos2 <- scales::col_numeric(
    palette = c(sunshort),
    domain = c(300, 500))
  f_pos3 <- scales::col_numeric(
    palette = c(toplevel),
    domain = c(500, max_delta))
  
  dplyr::case_when(
    x < 0 ~ f_neg(x),
    x < 300 ~ f_pos1(x),
    x < 500 ~ f_pos2(x),
    x < max_delta+1 ~ f_pos3(x),
    .default = "#808080")}

It gives me this error when plotting the table:

   data_color(columns = c(Delta_p, Delta_n),
              colors = pal) %>% 

Error in `dplyr::case_when()`:
! Case 5 (`x < 0 ~ f_neg(x)`) must be a two-sided formula, not a character vector.
Run `rlang::last_error()` to see where the error occurred.
Solution

  • You could use e.g. dplyr::case_when. And as you data contains NAs I added na.rm=TRUE when computing the min and max values. Finally, I used a more minimal example dataset.

    library(gt)

pal <- function(x) {
  f_neg <- scales::col_numeric(
    palette = c(emerald),
    domain = c(min(test, na.rm = TRUE), 0)
  )
  f_pos1 <- scales::col_numeric(
    palette = c(oryel),
    domain = c(0, 300)
  )
  f_pos2 <- scales::col_numeric(
    palette = c(sunshort),
    domain = c(300, 500)
  )
  f_pos3 <- scales::col_numeric(
    palette = c(toplevel),
    domain = c(500, max(test, na.rm = TRUE))
  )

  dplyr::case_when(
    x < 0 ~ f_neg(x),
    x < 300 ~ f_pos1(x),
    x < 500 ~ f_pos2(x),
    .default = f_pos3(x)
  )
}

test <- data.frame(
  Delta_p = seq(-100, 600, length.out = 10),
  Delta_n = rev(seq(-100, 600, length.out = 10))
)

gt(test) %>%
  data_color(
    columns = c(1, 2),
    colors = pal
  )

    enter image description here