基于DT的自定义表容器的输入的R闪亮更改列名称

Question

I have a data table formatted in a specific manner where the column names are centered over two columns using a custom table container that is defined by sketch. The column names are listed as Store1 or Store2, but I wanted to be able to have the actual store names populate, which are dependent on what state is selected.

Is it possible to have the column names update based on the selected state input? Or maybe there is a better way to do this entirely?

Below is my code:

#Packages
library(reshape2)
library(shiny)
library(DT)
library(shinydashboard)
library(dplyr)

#Data
data<-data.frame("State"=c("AK","AK","AK","AK","AK","AK","AK","AK","AR","AR","AR","AR","AR","AR","AR","AR"),
                 "StoreRank" = c(1,1,1,1,2,2,2,2,1,1,1,1,2,2,2,2),
                 "Year" = c(2017,2018,2017,2018,2017,2018,2017,2018,2017,2018,2017,2018,2017,2018,2017,2018),
                 "Region" = c("East","East","West","West","East","East","West","West","East","East","West","West","East","East","West","West"),
                 "Store" = c("Ingles","Ingles","Ingles","Ingles","Safeway","Safeway","Safeway","Safeway","Albertsons","Albertsons","Albertsons","Albertsons","Safeway","Safeway","Safeway","Safeway"),
                 "Total" = c(500000,520000,480000,485000,600000,600000,500000,515000,500100,520100,480100,485100,601010,601000,501000,515100))

#Formatting data for Data table
reform.data<-dcast(data, State+Region~StoreRank+Year, value.var = 'Total')

#For selecting state inputs
state.list<-reform.data %>%
  select(State) %>%
  unique

#List for state, store, and rank
Store.Ranks<-data %>%
  select('State', 'Store', 'StoreRank') %>%
  unique()

#Custom Table Container
sketch = htmltools::withTags(table(
  class = 'display',
  thead(
    tr(
      th(rowspan = 2, 'Region'),
      th(colspan = 2, 'Store1', style="text-align:center"),  #Tried and failer to create a function with sketch and change Store1 to Store.Ranks$Store[Store.Ranks$State == input$selectstate & Store.Ranks$StoreRank == 1]
      th(colspan = 2, 'Store2', style="text-align:center")
    ),
    tr(
      lapply(rep(c('2017 Total', '2018 Total'), 2), th)
    )
  )
))



#App. Code
shinyApp (

  ui<-dashboardPage(
    dashboardHeader(),

    dashboardSidebar(width=200,
                     sidebarMenu(id = "tabs",  
                                 menuItem(text = "State", tabName="state", icon=icon("chevron-right")),
                                 conditionalPanel(condition = "input.tabs == 'state' ",
                                                  menuSubItem((selectInput("selectstate", "Select state", 
                                                                           choices = state.list))))
                     )),
    dashboardBody(

        tabItem(tabName = 'Store',


                fluidRow(
                  column(10,
                         tabBox(width = 12,
                                title = tagList(shiny::icon("gear"), "Stores"),
                                id = "storedat",
                                tabPanel(
                                  title = "Store Ranks", 
                                  textOutput("selected_state"),
                                  DT::dataTableOutput("storetable"))
                                )
                         ))
                ))

  ),

  server <- function(input, output) {
    output$storetable <- DT::renderDataTable({
      DT::datatable(reform.data[ ,c(2:6)] %>%  
                      dplyr::filter(reform.data$State == input$selectstate), 
                      rownames = FALSE,
                      extensions = c('FixedColumns', "FixedHeader"),
                      container = sketch)
      })
  }

)

Answer 1

You could create a function to create the container which would take the names and create the container accordingly. I have edited the code you provided to do exactly that:

#Packages
library(reshape2)
library(shiny)
library(DT)
library(shinydashboard)
library(dplyr)

#Data
data<-data.frame("State"=c("AK","AK","AK","AK","AK","AK","AK","AK","AR","AR","AR","AR","AR","AR","AR","AR"),
                 "StoreRank" = c(1,1,1,1,2,2,2,2,1,1,1,1,2,2,2,2),
                 "Year" = c(2017,2018,2017,2018,2017,2018,2017,2018,2017,2018,2017,2018,2017,2018,2017,2018),
                 "Region" = c("East","East","West","West","East","East","West","West","East","East","West","West","East","East","West","West"),
                 "Store" = c("Ingles","Ingles","Ingles","Ingles","Safeway","Safeway","Safeway","Safeway","Albertsons","Albertsons","Albertsons","Albertsons","Safeway","Safeway","Safeway","Safeway"),
                 "Total" = c(500000,520000,480000,485000,600000,600000,500000,515000,500100,520100,480100,485100,601010,601000,501000,515100))

#Formatting data for Data table
reform.data<-dcast(data, State+Region~StoreRank+Year, value.var = 'Total')

#For selecting state inputs
state.list<-reform.data %>%
  select(State) %>%
  unique

#List for state, store, and rank
Store.Ranks<-data %>%
  select('State', 'Store', 'StoreRank') %>%
  unique()

#Custom Table Container
createContainer <- function(store1Name = 'Store1', store2Name='Store2'){
  sketch = htmltools::withTags(table(
    class = 'display',
    thead(
      tr(
        th(rowspan = 2, 'Region'),
        th(colspan = 2, store1Name, style="text-align:center"),  #Tried and failer to create a function with sketch and change Store1 to Store.Ranks$Store[Store.Ranks$State == input$selectstate & Store.Ranks$StoreRank == 1]
        th(colspan = 2, store2Name, style="text-align:center")
      ),
      tr(
        lapply(rep(c('2017 Total', '2018 Total'), 2), th)
      )
    )
  ))
  return(sketch);
}



#App. Code
shinyApp (

  ui<-dashboardPage(
    dashboardHeader(),

    dashboardSidebar(width=200,
                     sidebarMenu(id = "tabs",  
                                 menuItem(text = "State", tabName="state", icon=icon("chevron-right")),
                                 conditionalPanel(condition = "input.tabs == 'state' ",
                                                  menuSubItem((selectInput("selectstate", "Select state", 
                                                                           choices = state.list))))
                     )),
    dashboardBody(

      tabItem(tabName = 'Store',


              fluidRow(
                column(10,
                       tabBox(width = 12,
                              title = tagList(shiny::icon("gear"), "Stores"),
                              id = "storedat",
                              tabPanel(
                                title = "Store Ranks", 
                                textOutput("selected_state"),
                                DT::dataTableOutput("storetable"))
                       )
                ))
      ))

  ),

  server <- function(input, output) {

    output$storetable <- DT::renderDataTable({
      store1Name = Store.Ranks$Store[Store.Ranks$State == input$selectstate & Store.Ranks$StoreRank ==1]
      store2Name = Store.Ranks$Store[Store.Ranks$State == input$selectstate & Store.Ranks$StoreRank ==2]
      DT::datatable(reform.data[ ,c(2:6)] %>%  
                      dplyr::filter(reform.data$State == input$selectstate), 
                    rownames = FALSE,
                    extensions = c('FixedColumns', "FixedHeader"),
                    container = createContainer(store1Name, store2Name))
    })
  }

)

Hope it helps!