R Shiny 根据 DT 的自定义表容器的输入更改列名

Question

我有一个以特定方式格式化的数据表，其中列名使用由草图定义的自定义表容器以两列为中心。列名列为 Store1 或 Store2，但我希望能够填充实际的商店名称，这取决于选择的状态。

是否可以根据所选状态输入更新列名？或者也许有更好的方法来完全做到这一点？

下面是我的代码：

#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

您可以创建一个函数来创建容器，该函数将获取名称并相应地创建容器。我已经编辑了你提供的代码来做到这一点：

#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))
    })
  }

)

希望对你有帮助！