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)
  )

Create a data.frame that holds your information and color you want to pin to that. Use that corresponding color to apply to the cell background. — Roman Luštrik, Feb 05 '21 at 16:39
I've one that before and it works if the values are discrete. But if I have a continuous variable across hundreds of players, I need a continuous color gradient. Any ideas on how I might go about structuring that in a separate column? — user3585829, Feb 05 '21 at 20:21
It does? The FG% in my sample above is continuous data and the color scheme is continuous via the `col_numeric` function. Sorry if that wasn't more explicit. — user3585829, Feb 07 '21 at 19:34

user3585829 · Accepted Answer · 2021-03-15T13:59:43.220

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)

maintaining gt conditional color formatting in shiny selection

1 Answers1