maintaining gt conditional color formatting in shiny selection

Question

I'm building a shiny app of NBA players and field goal%. The app will return a gt table of the selected players. The issue I'm having is that the conditional formatting doesn't hold for the population as it re-adjusted to the selected players from the ui. Does anyone know if there is a way to work around this? Here is an example:

Load Packages and Data

library(tidyverse)
library(shiny)
library(gt)

dat <- tribble(~player, ~fg_pct,
  "A", 0.43,
  "B", 0.427,
  "C", 0.475,
  "D", 0.36,
  "E", 0.4,
  "F", 0.382,
  "G", 0.48,
  "H", 0.291,
  "I", 0.45) 

Build Shiny App

# user interface
u <- fluidPage(
  
  selectInput("player",
              label = "Player:",
              choices = unique(dat$player),
              selected = "A",
              multiple = TRUE),
  
  gt_output(outputId = "tbl")
)

# server
s <- function(input, output){
  
  tbl_df <- reactive({
    dat %>%
    filter(player %in% input$player)
  })
  
  output$tbl <- render_gt({
    
    tbl_df() %>%
      gt() %>%
      data_color(
        vars(fg_pct),
        colors = scales::col_numeric(palette = c("red","white","blue"),domain = NULL)
      )
    
    
  })
  
}

# run app
shinyApp(u, s)

Example with one player selected

Example with two players selected

What I really want

What I'd really like is for gt to maintain the color scaling across the entire data set and return that. One thing I've thought of is actually building a second column that has a z-score and then seeing if I can color the fg_pct column with that info (without actually showing that column explicitly) but it doesn't seem like that is possible either. The full color scaling that I'd like to retain, regardless of player selection is this:

dat %>%
  gt() %>%
  data_color(
    vars(fg_pct),
    colors = scales::col_numeric(palette = c("red","white","blue"),domain = NULL)
  )

Answer 1

I figured out that the simple way to achieve this goal is to set the domain to equal the min and max values of the column you are attempting to conditionally format.

library(tidyverse)
library(shiny)
library(gt)
library(scales)

### create data
dat <- tribble(~player, ~fg_pct,
               "A", 0.43,
               "B", 0.427,
               "C", 0.475,
               "D", 0.36,
               "E", 0.4,
               "F", 0.382,
               "G", 0.48,
               "H", 0.291,
               "I", 0.45) 

# user interface
u <- fluidPage(
  
  selectInput("player",
              label = "Player:",
              choices = unique(dat$player),
              selected = "A",
              multiple = TRUE),
  
  gt_output(outputId = "tbl")
)

# server
s <- function(input, output){
  
  tbl_df <- reactive({
    dat %>%
      filter(player %in% input$player)
  })
  
  
  output$tbl <- render_gt({
    
    tbl_df() %>%
      arrange(desc(fg_pct)) %>%
      gt() %>%
      data_color(
        vars(fg_pct),
        apply = "fill",
        colors = col_numeric(palette = c("red","white","green"), domain = c(min(dat$fg_pct), max(dat$fg_pct)
        )))
  })
  
}

# run app
shinyApp(u, s)

Alternatively, if you'd like to do this in DT instead of gt you can do it like this (just need to preset the breaks and colors).

# preset breaks and coloring
brks <- as.vector(quantile(dat$fg_pct, probs = seq(0, 1, 0.1)))
ramp <- colorRampPalette(c("red", "green"))
clrs <- ramp(length(brks) + 1)

u <- fluidPage(
  
  selectInput("player",
              label = "Player:",
              choices = unique(dat$player),
              selected = "A",
              multiple = TRUE),
  
  DTOutput(outputId = "tbl")
)

# server
s <- function(input, output){
  
  tbl_df <- reactive({
    dat %>%
      filter(player %in% input$player)
  })
  
  
  output$tbl <- renderDT({
    
    tbl_df() %>%
      arrange(desc(fg_pct)) %>%
      datatable() %>%
      formatStyle(columns = "fg_pct",
                  background = styleInterval(
                    cuts = brks, 
                    values = clrs))
    
  })
  
}

# run app
shinyApp(u, s)