无法在 Shinyapp 中删除/select 多列

Question

我正在使用 mtcars 数据构建 shinyApp。我已将 checkboxgroupinput 用于选择 cyl、vs、disp 等列。但它目前无法正常工作。出于同样的目的，我还设置了 DT 库的列可见性 ，但是当我删除列并下载数据时，它会在 excel 中显示完整的输出。我也在粘贴我的代码。请看一看。非常感谢:)

data_table<-mtcars[c(2,8,3,1,4,5,9,6,7, 10,11)]

  ncol(data_table)


  names(data_table)[4:11]<- rep(x = 
                                  c('OTS_lhr_Wave_1','OTS_isb_Wave_2','OTS_lhr_Wave_2','OTS_isb_Wave_1',                                                                            

                                    'NTS_lhr_Wave_1','NTS_isb_Wave_2','NTS_lhr_Wave_2','NTS_isb_Wave_1'), 
                                times=1, each=1) 




  library(readr)  
  library(shiny)   
  library(DT)     
  library(dplyr) 
  library(shinythemes) 
  library(htmlwidgets) 
  library(shinyWidgets) 



  ui = fluidPage( 
    sidebarLayout(
      sidebarPanel (


        downloadButton(outputId = "downLoadFilter",
                       label = "Download data"),






        selectInput(inputId = "disp",
                    label = "disp:",
                    choices = c("All",
                                unique(as.character(data_table$disp))),
                    selected = "All",
                    multiple = TRUE),





        radioButtons(inputId = "variables", label = "Choose Variable(s):",
                     choices =c("All","OTS", "NTS"), inline = FALSE,
                     selected = c("All")),



        selectInput(inputId = "regions1", label = "choose region",
                    choices =c("lhr"), 
                    multiple = TRUE,   selected = c("lhr")),


        selectInput(inputId = "regions2", label = "choose region",
                    choices =c("isb"), 
                    multiple = TRUE,   selected = c("isb")),




        selectInput(inputId = "waves", label = "choose wave",
                    choices =c("Wave_1", "Wave_2"), multiple  = TRUE,
                    selected = c("Wave_1", "Wave_2")),


        checkboxGroupInput(inputId = "columns", label = "Select Columns to display:",
                           choices =names(data_table)[1:3],
                           selected = names(data_table)[1:3], inline = TRUE)

      ),




      mainPanel(
        tags$h5('Download only current page using following buttons:'),
        DT::dataTableOutput('mytable') )))







  server = function(input, output, session) {



    #tab 1
    thedata <- reactive({



      if(input$disp != 'All'){
        data_table<-data_table[data_table$disp %in% input$disp,]
      }



      #starting OTS NTS


      if  (input$variables== 'All'){
        data_table<-  data_table[,c("cyl", "vs", "disp" ,
                                    names(data_table[grep(pattern = "TS", x = names(data_table), fixed = TRUE)])),drop=FALSE]    }




      if  (input$variables== 'OTS'){
        data_table<-  data_table[,c("cyl", "vs", "disp" ,
                                    names(data_table[grep(pattern = "OTS", x = names(data_table), fixed = TRUE)])),drop=FALSE]    }



      if  (input$variables== 'NTS'){
        data_table<-  data_table[,c("cyl", "vs", "disp" ,
                                    names(data_table[grep(pattern = "NTS", x = names(data_table), fixed = TRUE)])),drop=FALSE]    }






      #Region1
      all_cols <- names(data_table)
      region_cols <- c()




      if  ('lhr' %in% input$regions1){
        region_cols <- c(region_cols, all_cols[grep('lhr', all_cols, fixed = TRUE)])

      }  




      #Region2




      if  ('isb' %in% input$regions2){
        region_cols <- c(region_cols, all_cols[grep('isb', all_cols, fixed = TRUE)])

      }




      #Waves
      waves_cols <- c()


      if  ('Wave_1' %in% input$waves){
        waves_cols <- c(waves_cols, all_cols[grep('Wave_1', all_cols, fixed = TRUE)])
      }  

      if  ('Wave_2'  %in%  input$waves){
        waves_cols <- c(waves_cols, all_cols[grep('Wave_2', all_cols, fixed = TRUE)])
      }




      data_table <- data_table[,c( input$columns, intersect(region_cols, waves_cols)), drop=FALSE]







    })



    output$mytable = DT::renderDataTable({

      DT::datatable( filter = "top",  rownames = FALSE, escape = FALSE,
                     class = 'cell-border stripe',
                     extensions = c('FixedHeader', 'Buttons'),
                     options = list(pageLength = 50, autowidth=FALSE, fixedHeader = TRUE, 
                                    dom = 'Brtip', 


                                    buttons = list('copy', 'print', 
                                                   list(extend = 'collection', 
                                                        buttons = c('csv', 'excel', 'pdf'), 
                                                        text = 'Download'), 
                                                   list(extend = 'colvis', columns = c(0,1,2)))


                     ),
                     {     

                       thedata()   


                     }) 


    })




    output$downLoadFilter <- downloadHandler(
      filename = function() {
        paste('Filtered Data ', Sys.time(), '.csv', sep = '')
      },
      content = function(path){
        write_csv(thedata(), path)  # Call reactive thedata()
      }
    )




  }  


  shinyApp(ui = ui, server = server)

Answer 1

我已经根据您的代码实施了一个解决方案，允许您 select 并根据您的选择呈现特定列，并根据您的选择下载列过滤数据。

对代码进行了以下更改：

动态选项以 checkboxGroupInput() 的形式添加
- checkboxGroupInput(inputId = "columns", label = "Select Columns to display:", choices = data_table %>% colnames(), selected = NULL)
根据上面 (1) 的选择，将反应式过滤方法写入 return 所有 selected 列，如下所示：
- columnFilter <- shiny::reactive({ shiny::req(input$columns) data_table %>% select(input$columns) })
编写了一个响应式下载数据准备方法，可以按如下方式传入downloadHandler()：
- getDownloadData <- shiny::reactive({ if(is.null(input$columns)) return(thedata()) else return(columnFilter()) })

基于上面的（3），downloadHandler()现在变成：

 output$downLoadFilter <- downloadHandler(
   filename = function() {
     paste('Filtered Data ', Sys.time(), '.csv', sep = '')
  },
   content = function(path){
     write_csv(getDownloadData(), path)
  }
 )      
}

在数据渲染函数中，增加了逻辑触发器如下：
- if(is.null(input$columns)) thedata() else columnFilter()
其他一切都保持不变。

基于您的代码的完整解决方案如下：

data_table<-mtcars[,c(2,8,3,1,4,5,9,6,7, 10,11)]

ncol(data_table)


names(data_table)[4:11]<- rep(x =                                 

                                c('OTS_lhr_Wave_1','OTS_isb_Wave_2','OTS_lhr_Wave_2','OTS_isb_Wave_1',                                                                            

                                  'NTS_lhr_Wave_1','NTS_isb_Wave_2','NTS_lhr_Wave_2','NTS_isb_Wave_1'), 
                              times=1, each=1) 


library(readr)  
library(shiny)   
library(DT)     
library(dplyr) 
library(shinythemes) 
library(htmlwidgets) 
library(shinyWidgets) 



ui <- fluidPage( 
  sidebarLayout(
    sidebarPanel (


      downloadButton(outputId = 
                       "downLoadFilter",
                     label = "Download data"),




      selectInput(inputId = "cyl",
                  label = "cyl:",
                  choices = c("All",

                              unique(as.character(data_table$cyl))),
                  selected = "All",
                  multiple = TRUE),


      selectInput(inputId = "vs",
                  label = "vs:",
                  choices = c("All",

                              unique(as.character(data_table$vs))),
                  selected = "All",
                  multiple = TRUE),



      selectInput(inputId = "disp",
                  label = "disp:",
                  choices = c("All",  
                              unique(as.character(data_table$disp))),
                  selected = "All",
                  multiple = TRUE),

      checkboxGroupInput(inputId = "columns", 
                         label = "Select Columns to display:",
                         choices = data_table %>% colnames(),
                         selected = NULL),

      radioButtons(inputId = "variables", 
                   label = "Choose Variable(s):",
                   choices =c("All","OTS", 
                              "NTS"), inline = FALSE,
                   selected = c("OTS")),



      selectInput(inputId = "regions", label = "choose region",
                  choices =c("lhr", 
                             "isb"), 
                  multiple = TRUE,   
                  selected = c("lhr")),




      selectInput(inputId = "waves", label =  "choose wave",
                  choices =c("Wave_1", 
                             "Wave_2"), multiple  = TRUE,
                  selected = c("Wave_1"))

    ),


    mainPanel(
      tags$h5('Download only current page using following 
              buttons:'),
      DT::dataTableOutput('mytable') )))



server <- function(input, output, session) {

  columnFilter <- shiny::reactive({
    shiny::req(input$columns)
    data_table %>% select(input$columns)
  })

  getDownloadData <- shiny::reactive({
    if(is.null(input$columns)) return(thedata()) 
    else return(columnFilter())
  })

  #tab 1
  thedata <- reactive({

    if(input$cyl != 'All'){
      data_table<-data_table[data_table$cyl %in% input$cyl,]
    }

    if(input$vs != 'All'){
      data_table<-data_table[data_table$vs %in% input$vs,]
    }


    if(input$disp != 'All'){
      data_table<-data_table[data_table$disp %in% input$disp,]
    }


    #starting OTS NTS


    if  (input$variables== 'All'){
      data_table<-  data_table[,c("cyl", "vs", "disp" ,
                                  names(data_table[grep(pattern = "TS", x = 
                                                          names(data_table), 
                                                        fixed = TRUE)])),drop=FALSE]    }


    if  (input$variables== 'OTS'){
      data_table<-  data_table[,c("cyl", "vs", "disp" ,
                                  names(data_table[grep(pattern = "OTS", x = 
                                                          names(data_table), 
                                                        fixed = TRUE)])),drop=FALSE]    }



    if  (input$variables== 'NTS'){
      data_table<-  data_table[,c("cyl", "vs", "disp" ,
                                  names(data_table[grep(pattern = "NTS", x = 
                                                          names(data_table), 
                                                        fixed = TRUE)])),drop=FALSE]    }


    #Region
    all_cols <- names(data_table)
    region_cols <- c("cyl", "vs", "disp" )


    if  ('lhr' %in% input$regions){
      region_cols <- c(region_cols, all_cols[grep('lhr', all_cols, fixed = 
                                                    TRUE)])

    }  
    if  ('isb' %in% input$regions){
      region_cols <- c(region_cols, all_cols[grep('isb', all_cols, fixed = 
                                                    TRUE)])

    }

    #Waves
    waves_cols <- c("cyl", "vs", "disp" )


    if  ('Wave_1' %in% input$waves){
      waves_cols <- c(waves_cols, all_cols[grep('Wave_1', all_cols, fixed = 
                                                  TRUE)])
    }  

    if  ('Wave_2'  %in%  input$waves){
      waves_cols <- c(waves_cols, all_cols[grep('Wave_2', all_cols, fixed = 
                                                  TRUE)])
    }


    data_table <- data_table[,intersect(region_cols, waves_cols), 
                             drop=FALSE]


  })

  output$mytable = DT::renderDataTable({
    DT::datatable( filter = "top",  rownames = FALSE, escape = FALSE,
                   class = 'cell-border stripe',
                   extensions = c('FixedHeader', 'Buttons'),
                   options = list(pageLength = 50, autowidth=FALSE, 
                                  fixedHeader = TRUE, 
                                  dom = 'Brtip', 


                                  buttons = list('copy', 'print', 
                                                 list(extend = 'collection', 
                                                      buttons = c('csv', 
                                                                  'excel', 
                                                                  'pdf'), 
                                                      text = 'Download'), 
                                                 list(extend = 'colvis', 
                                                      columns = c(0,1,2)))


                   ),
                   {
                     if(is.null(input$columns)) thedata()
                     else columnFilter()
                   }) 

  })


  output$downLoadFilter <- downloadHandler(
    filename = function() {
      paste('Filtered Data ', Sys.time(), '.csv', sep = '')
    },
    content = function(path){
      write_csv(getDownloadData(), path)
    }
  )

}      

shinyApp(ui = ui, server = server)

截图如下：

希望对您有所帮助:-)

Answer 2

data_table<-mtcars[,c(2,8,3,1,4,5,9,6,7, 10,11)]

  ncol(data_table)


  names(data_table)[4:11]<- rep(x = 

c('OTS_lhr_Wave_1','OTS_isb_Wave_2','OTS_lhr_Wave_2','OTS_isb_Wave_1',                                                                            


'NTS_lhr_Wave_1','NTS_isb_Wave_2','NTS_lhr_Wave_2','NTS_isb_Wave_1'), 
                                times=1, each=1) 




  library(readr)  
  library(shiny)   
  library(DT)     
  library(dplyr) 
  library(shinythemes) 
  library(htmlwidgets) 
  library(shinyWidgets) 



  ui = fluidPage( 
    sidebarLayout(
      sidebarPanel (


        downloadButton(outputId = "downLoadFilter",
                       label = "Download data"),






        selectInput(inputId = "disp",
                    label = "disp:",
                    choices = c("All",
                                unique(as.character(data_table$disp))),
                    selected = "All",
                    multiple = TRUE),





        radioButtons(inputId = "variables", label = "Choose Variable(s):",
                     choices =c("All","OTS", "NTS"), inline = FALSE,
                     selected = c("All")),



        selectInput(inputId = "regions1", label = "choose region",
                    choices =c("lhr"), 
                    multiple = TRUE,   selected = c("lhr")),


        selectInput(inputId = "regions2", label = "choose region",
                    choices =c("isb"), 
                    multiple = TRUE,   selected = c("isb")),




        selectInput(inputId = "waves", label = "choose wave",
                    choices =c("Wave_1", "Wave_2"), multiple  = TRUE,
                    selected = c("Wave_1", "Wave_2")),


        checkboxGroupInput(inputId = "columns", label = "Select Columns to 
display:",
                           choices =names(data_table)[1:3],
                           selected = names(data_table)[1:3], inline = TRUE)

      ),




      mainPanel(
        tags$h5('Download only current page using following buttons:'),
        DT::dataTableOutput('mytable') )))







  server = function(input, output, session) {



    #tab 1
    thedata <- reactive({



      if(input$disp != 'All'){
        data_table<-data_table[data_table$disp %in% input$disp,]
      }



      #starting OTS NTS


      if  (input$variables== 'All'){
        data_table<-  data_table[,c("cyl", "vs", "disp" ,
                                    names(data_table[grep(pattern = "TS", x 
= names(data_table), fixed = TRUE)])),drop=FALSE]    }




      if  (input$variables== 'OTS'){
        data_table<-  data_table[,c("cyl", "vs", "disp" ,
                                    names(data_table[grep(pattern = "OTS", x 
= names(data_table), fixed = TRUE)])),drop=FALSE]    }



      if  (input$variables== 'NTS'){
        data_table<-  data_table[,c("cyl", "vs", "disp" ,
                                    names(data_table[grep(pattern = "NTS", x 
= names(data_table), fixed = TRUE)])),drop=FALSE]    }






      #Region1
      all_cols <- names(data_table)
      region_cols <- c()




      if  ('lhr' %in% input$regions1){
        region_cols <- c(region_cols, all_cols[grep('lhr', all_cols, fixed = 
TRUE)])

      }  




      #Region2




      if  ('isb' %in% input$regions2){
        region_cols <- c(region_cols, all_cols[grep('isb', all_cols, fixed = 
TRUE)])

      }




      #Waves
      waves_cols <- c()


      if  ('Wave_1' %in% input$waves){
        waves_cols <- c(waves_cols, all_cols[grep('Wave_1', all_cols, fixed 
= TRUE)])
      }  

      if  ('Wave_2'  %in%  input$waves){
        waves_cols <- c(waves_cols, all_cols[grep('Wave_2', all_cols, fixed 
= TRUE)])
      }




      data_table <- data_table[,c( input$columns, intersect(region_cols, 
waves_cols)), drop=FALSE]







    })



    output$mytable = DT::renderDataTable({

      DT::datatable( filter = "top",  rownames = FALSE, escape = FALSE,
                     class = 'cell-border stripe',
                     extensions = c('FixedHeader', 'Buttons'),
                     options = list(pageLength = 50, autowidth=FALSE, 
fixedHeader = TRUE, 
                                    dom = 'Brtip', 


                                    buttons = list('copy', 'print', 
                                                   list(extend = 
'collection', 
                                                        buttons = c('csv', 
'excel', 'pdf'), 
                                                        text = 'Download'), 
                                                   list(extend = 'colvis', 
columns = c(0,1,2)))


                     ),
                     {     

                       thedata()   


                     }) 


    })




    output$downLoadFilter <- downloadHandler(
      filename = function() {
        paste('Filtered Data ', Sys.time(), '.csv', sep = '')
      },
      content = function(path){
        write_csv(thedata(), path)  # Call reactive thedata()
      }
    )




  }  


  shinyApp(ui = ui, server = server)

无法在 Shinyapp 中删除/select 多列

Unable to drop / select multiple columns in Shinyapp

dashboard

r

radio-button

shiny

dt