r - 在闪亮的选择中保持 gt 条件颜色格式

Question

我正在构建一个shiny关于 NBA 球员和投篮命中率的应用程序。该应用程序将返回gt所选玩家的表格。我遇到的问题是条件格式不适用于人口，因为它重新调整为从ui. 有谁知道是否有办法解决这个问题？这是一个例子：

加载包和数据

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) 

构建闪亮的应用程序

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

选择一名玩家的示例

选择两名玩家的示例

我真正想要的

我真正想要的是gt保持整个数据集的颜色缩放并将其返回。我想到的一件事实际上是构建具有 z 分数的第二列，然后查看我是否可以使用该信息为 fg_pct 列着色（实际上没有明确显示该列），但似乎不可能任何一个。无论玩家选择如何，我想保留的全色缩放是这样的：

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

Answer 1

我发现实现此目标的简单方法是将 设置domain为等于您尝试有条件地格式化的列的值min。max

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)

或者，如果你想这样做DT而不是这样做，gt你可以这样做（只需要预设中断和颜色）。

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