根据分类值有条件地为htmlTable中的单元格着色。 该表根据用户输入动态显示（r Shiny0

Question

I've created an app that allows user to select an electoral division and then a table is updated showing all the political parties which had been voted into power over the years.

I would like to color the cells containing the political party abbreviations with the corresponding party color. 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)

Now my question is how do I set the background colour of the cells to match the party colors if:

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

I've tried a bunch of different options based on what I have read here but none work (kable, col.rgroup, background = , cell_apec).

Thanks in advance

Answer 1

Is it what you want ?

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)

UPDATE

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)