Условно цвет ячеек в htmlTable основан на категориальных значениях.Таблица отображается динамически при вводе пользователем - PullRequest
Новая
       9

Условно цвет ячеек в htmlTable основан на категориальных значениях.Таблица отображается динамически при вводе пользователем

0 голосов
/ 30 января 2019

Я создал приложение, которое позволяет пользователю выбирать избирательный округ, а затем обновляется таблица, показывающая все политические партии, которые были избраны во власть за эти годы.

Я хотел бы закрасить ячейки, содержащие сокращения политических партий, соответствующим цветом партии. изображение примера таблицы, показывающей цветные ячейки на основе категориального значения (аббревиатура участника) 

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

Спасибо взаранее

1 Ответ

0 голосов
/ 30 января 2019

Это то, что вы хотите?

enter image description here

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)

enter image description here

...