Search code examples
rif-statementdplyrpurrrgt

Dynamically named gt plots based on color palettes selected using R

With sample data and code below, I'm able to dynamically draw gt() plots for each element of list of dataframes, and I set color for error column:

df <- structure(list(id = c("M0000607", "M0000609", "M0000612"), `2021-08(actual)` = c(12.6, 
19.2, 8.3), `2021-09(actual)` = c(10.3, 17.3, 6.4), `2021-10(actual)` = c(8.9, 
15.7, 5.3), `2021-11(actual)` = c(7.3, 14.8, 3.1), `2021-12(actual)` = c(6.1, 
14.2, 3.5), `2021-08(pred)` = c(11.65443222, 14.31674997, 7.084180415
), `2021-09(pred)` = c(12.29810914, 17.7143733, 6.057927385), 
    `2021-10(pred)` = c(9.619846116, 15.54553601, 6.525992602
    ), `2021-11(pred)` = c(8.352097939, 13.97318204, 3.164682627
    ), `2021-12(pred)` = c(6.113631596, 14.16243166, 3.288372517
    ), `2021-08(error)` = c(2.082307066, 1.146759554, 0.687406723
    ), `2021-09(error)` = c(1.631350383, 2.753457736, 2.952737781
    ), `2021-10(error)` = c(0.945567783, 4.883250027, 1.215819585
    ), `2021-11(error)` = c(1.998109138, 0.414373304, 0.342072615
    ), `2021-12(error)` = c(0.719846116, 0.154463985, 1.225992602
    )), class = "data.frame", row.names = c(NA, -3L))

year_months <- c('2021-12', '2021-11', '2021-10')  
curr <- lubridate::ym(year_months)
prev <- curr - months(2L)
dfs <- mapply(function(x, y) {
  df[c(
    "id", 
    format(seq.Date(y, x, by = "month"), "%Y-%m(actual)"), 
    format(x, "%Y-%m(pred)"), 
    format(x, "%Y-%m(error)")
  )]
}, curr, prev, SIMPLIFY = FALSE)

plotGT <- function(data){
  plot <- data %>% 
    gt() %>% 
    data_color(
      columns = 6, # set color for error column
      colors = scales::col_numeric(
        palette =
          c("blue", "green", "orange", "red"),  # named with color 1
          # c('#feb8cd', '#ffffff', '#69cfd5'), # named with color 2
        domain = c(0, 10)
      )
    )
  print(plot)
  # gtsave(plot, file = file.path(glue("./plot_color1.png")))
  
}

mapply(plotGT, dfs)

Result for colors c("blue", "green", "orange", "red"):

enter image description here

Result for colors c('#feb8cd', '#ffffff', '#69cfd5'):

enter image description here

In order to go further, I hope to save the outputs based if conditions: if I choose the first color palette, I will name the plot by i.e., plot_color1.png, for the second, named by plot_color2.png, but I wish to run the whole code once, save all two figures one time.

So my question is how could I modify the code above to achieve that? Thanks for your help at advance.

Maybe some code like: gtsave(plot, file = file.path(glue("./plot_color{i}.png"))) based on if-else conditions, but I don't know how to do that exactly.

Solution

  • One option would be to make use of a named list of color palettes like so, which would also make it easier to switch between different palettes:

    EDIT

    • I fixed a bug. I used a <- inside the pals list instead of = which was the reason for the error you got.

    • To loop over the palettes I added pal_choice as an argument to your table function. Doing so we can loop over pals using e.g. lapply.

    • Additionally, as you are looping over multiple dfs I added a name argument and added names to your list of data frames. As is the tables were exported under the same filename so actually you ended up with one file containing the last table.

    • I also uncommented the print for the reprex.

    library(gt)

pal_choice <- "color2"
pals <- list(color1 = c("blue", "green", "orange", "red"), 
             color2 = c('#feb8cd', '#ffffff', '#69cfd5'))


plotGT <- function(data, name, pal_choice){
  plot <- data %>% 
    gt() %>% 
    data_color(
      columns = 6, # set color for error column
      colors = scales::col_numeric(
        palette = pals[[pal_choice]],
        domain = c(0, 10)
      )
    )
  #print(plot)
  gtsave(plot, file = glue::glue("./plot_{name}_{pal_choice}.png"))
}

names(dfs) <- letters[seq_along(dfs)]

lapply(names(pals), function(x) {
  mapply(plotGT, dfs, names(dfs), MoreArgs = list(pal_choice = x))  
})
#> [[1]]
#>                                                                                                                     a 
#> "/private/var/folders/l7/hltv70p95zqfdq9z09h8m9bw0000gn/T/Rtmp9LLLHO/reprex-2b71746b0fd-petit-dore/plot_a_color1.png" 
#>                                                                                                                     b 
#> "/private/var/folders/l7/hltv70p95zqfdq9z09h8m9bw0000gn/T/Rtmp9LLLHO/reprex-2b71746b0fd-petit-dore/plot_b_color1.png" 
#>                                                                                                                     c 
#> "/private/var/folders/l7/hltv70p95zqfdq9z09h8m9bw0000gn/T/Rtmp9LLLHO/reprex-2b71746b0fd-petit-dore/plot_c_color1.png" 
#> 
#> [[2]]
#>                                                                                                                     a 
#> "/private/var/folders/l7/hltv70p95zqfdq9z09h8m9bw0000gn/T/Rtmp9LLLHO/reprex-2b71746b0fd-petit-dore/plot_a_color2.png" 
#>                                                                                                                     b 
#> "/private/var/folders/l7/hltv70p95zqfdq9z09h8m9bw0000gn/T/Rtmp9LLLHO/reprex-2b71746b0fd-petit-dore/plot_b_color2.png" 
#>                                                                                                                     c 
#> "/private/var/folders/l7/hltv70p95zqfdq9z09h8m9bw0000gn/T/Rtmp9LLLHO/reprex-2b71746b0fd-petit-dore/plot_c_color2.png"