根据分类值有条件地为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，background =和cell_apec）。

预先感谢

Answer 1

是您想要的吗？

Theme Kit

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)