根据类别值对htmlTable中的单元格进行有条件的着色。表在用户输入时动态显示(r shiny0

Question

我已经创建了一个应用程序，允许用户选择一个选举部门，然后更新一个表格，显示多年来投票上台的所有政党。

我想用相应的政党颜色给包含政党缩写的单元格着色。image of example table showing colored cells based on categorical value (party abbreviation)

 Example data:
     Elect_div<-c("Blair","Bonner","Bowman","Brisbane","Capricornia","Dawson","Dickson")
     Elected_party_2016<-c("ALP","LNP","LNP","LNP","LNP","LNP","LNP)
     Elected_party_2013<-c("ALP","LNP","LNP","LNP","LNP","LNP","LNP)

     df.party <- data.frame(Elect_div, Elected_party_2016, Elected_party_2013)
     # i need the table in long format as the real data goes back to 2004 and 
     the table displays below a map and some graphs
     df.melted<-melt(df.party, idvars="Elect_div", measure.vars=c("Elected_party_2016", "Elected_party_2013"))
     #removing varible column as I am manually setting the row names within the htmlTable below
     df.melted$variable <- NULL
     #bring the valu column to the first position
     df.melted<-df.melted[,c(ncol(df.melted),1:(ncol(df.melted)-1))]

     #shiny app

     ui<- fluidPage(
             selectInput("division", "",
          label="Select an electorate, graphs below will be updated.",
          choices = df.melted$Elect_div),
          htmlOutput("table"))

     server <- function(input, output, session) {  
           selectedData<-eventReactive(df.melted$Elect_div==input$division,  {

           HTML(
             htmlTable(subset(df.melted,df.melted$Elect_div==input$division), 
             align="l",
             header=c("",""),
             rnames= paste(c("Party elected 2016","Party elected 2013")), 
            caption="Historic elected party data from the Australian Electoral Commission (AEC)",
             tfoot="&dagger;Participation & Unemployment rate calculated using data from Australian Government Dept of Jobs & Small Business (2018)"

              ))

                    })
                 output$table <- renderUI({selectedData()})

                      }

                  shinyApp(ui, server)

现在我的问题是如何设置单元格的背景颜色，以匹配党的颜色，如果：

                party_cols<-c("LNP"="blue","ALP" = "red","IND" = "grey", "KAP = "purple")

根据我在这里读到的内容，我尝试了一堆不同的选项，但都不起作用(kable，col.rgroup，cell_apec=，kable)。

提前感谢

Answer 1

这是你想要的吗？

​

​

Elect_div<-c("Blair","Bonner","Bowman","Brisbane","Capricornia","Dawson","Dickson")
Elected_party_2016<-c("ALP","LNP","LNP","LNP","LNP","LNP","LNP")
Elected_party_2013<-c("ALP","LNP","LNP","LNP","LNP","LNP","LNP")

df.party <- data.frame(Elect_div, Elected_party_2016, Elected_party_2013)
# i need the table in long format as the real data goes back to 2004 and the table displays below a map and some graphs
df.melted<- reshape2::melt(df.party, idvars="Elect_div", measure.vars=c("Elected_party_2016", "Elected_party_2013"))
#removing varible column as I am manually setting the row names within the htmlTable below
df.melted$variable <- NULL
#bring the valu column to the first position
df.melted<-df.melted[,c(ncol(df.melted),1:(ncol(df.melted)-1))]

party_cols<-c("LNP"="blue","ALP" = "red","IND" = "grey", "KAP" = "purple")

library(shiny)
library(htmlTable)

ui<- fluidPage(
  selectInput("division", "",
              label="Select an electorate, graphs below will be updated.",
              choices = df.melted$Elect_div),
  htmlOutput("table"))

server <- function(input, output, session) {  
  selectedData<-eventReactive(df.melted$Elect_div==input$division,  {
    dat <- subset(df.melted,df.melted$Elect_div==input$division)
    party <- dat$value[1]
    HTML(
      htmlTable(
        dat, 
        align="l",
        header=c("",""),
        rnames= paste(c("Party elected 2016","Party elected 2013")), 
        css.cell = rep(sprintf("background-color: %s;", party_cols[party]), 2),
        caption="Historic elected party data from the Australian Electoral Commission (AEC)",
        tfoot="&dagger;Participation & Unemployment rate calculated using data from Australian Government Dept of Jobs & Small Business (2018)"
      ))

  })
  output$table <- renderUI({selectedData()})

}

shinyApp(ui, server)

更新

Elect_div<-c("Blair","Bonner","Bowman","Brisbane","Capricornia","Dawson","Dickson")
Elected_party_2016<-c("ALP","LNP","LNP","LNP","LNP","LNP","LNP")
Elected_party_2013<-c("ALP","KAP","LNP","LNP","LNP","LNP","LNP")

df.party <- data.frame(Elect_div, Elected_party_2016, Elected_party_2013)
# i need the table in long format as the real data goes back to 2004 and the table displays below a map and some graphs
df.melted<- reshape2::melt(df.party, idvars="Elect_div", measure.vars=c("Elected_party_2016", "Elected_party_2013"))
#removing varible column as I am manually setting the row names within the htmlTable below
df.melted$variable <- NULL
#bring the valu column to the first position
df.melted<-df.melted[,c(ncol(df.melted),1:(ncol(df.melted)-1))]

party_cols<-c("LNP"="blue","ALP" = "red","IND" = "grey", "KAP" = "purple")

library(shiny)
library(htmlTable)

ui<- fluidPage(
  selectInput("division", "",
              label="Select an electorate, graphs below will be updated.",
              choices = df.melted$Elect_div),
  htmlOutput("table"))

server <- function(input, output, session) {  
  selectedData<-eventReactive(df.melted$Elect_div==input$division,  {
    dat <- subset(df.melted,df.melted$Elect_div==input$division)
    HTML(
      htmlTable(
        dat, 
        align="l",
        header=c("",""),
        rnames= paste(c("Party elected 2016","Party elected 2013")), 
        css.cell = t(vapply(party_cols[dat$value], function(x) rep(sprintf("background-color: %s;", x), 2), character(2))),
        caption="Historic elected party data from the Australian Electoral Commission (AEC)",
        tfoot="&dagger;Participation & Unemployment rate calculated using data from Australian Government Dept of Jobs & Small Business (2018)"
      ))

  })
  output$table <- renderUI({selectedData()})

}

shinyApp(ui, server)

​

​