无法在 Shinyapp 中删除/选择多个列

【问题标题】：Unable to drop / select multiple columns in Shinyapp无法在 Shinyapp 中删除/选择多个列
【发布时间】：2019-06-08 05:00:20
【问题描述】：

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

data_table 

  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)

【问题讨论】：

  • 有人有想法吗？

标签： r shiny radio-button dashboard dt


【解决方案1】：

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

对代码进行了以下更改：

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

  4. 基于上述 (3)，downloadHandler() 现在变为：

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

  5. 在数据渲染功能中，增加了一个逻辑触发器，如下：

    • if(is.null(input$columns)) thedata() else columnFilter()
  6. 其他一切都保持不变。

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

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)

截图如下：

我希望这会有所帮助:-)

【讨论】：

  • 嗨伙计，我之前尝试过使用 input$columns 但它没有提供所需的输出
  • 嗨@Doctor，我已经设法实施了一个解决方案。以上满足您的需求，即动态列过滤。
  • 嗨，伙计，很抱歉回复晚了，非常感谢您付出的努力。但是，选择变量、选择区域和选择波浪的最后 3 个输入不起作用。你能看看问候吗？
  • 嗨@Doctor，我已经测试过了，一切都很好。我添加了一个屏幕截图来演示所有数据都是根据选择呈现的。您可以看到 wave1 和 wave2 都有 ihr 和 isb。我已经测试了所有组合，它们都可以正常工作。
  • 嗨@Doctor，您是否设法找出解决方案对您不起作用的原因？
【解决方案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)

【讨论】：

    猜你喜欢
    • 2019-05-01
    • 1970-01-01
    • 1970-01-01
    • 2014-04-28
    • 1970-01-01
    • 2019-05-01
    • 2011-12-03
    • 2023-01-13
    • 2019-06-19
    相关资源
    最近更新 更多
    热门标签
    Java Python linux javascript Mysql C# Docker 算法 前端 SpringBoot Redis Vue spring 设计模式 .net core .net kubernetes c++ 数据库 数据结构 大数据 js 机器学习 微服务 Android Go 程序员 面试 JVM ASP.net core 云原生 人工智能 后端 PHP git CSS golang k8s Nginx Django mybatis 深度学习 多线程 React 架构 devops 爬虫 云计算 Spring Boot LeetCode