如何为 R 闪亮网页中的所有数据表设置一个下载按钮

Question

我正在使用一个闪亮的应用程序，希望在应用程序的 header 中有一个 downloadButton 来下载 [=27] 中存在的数据 table =] page/tab.

下面是一个简单的应用程序，它有两个数据 table 在第 1 页和一个在第 2 页。每个数据 table 都有 csv ， excel 按钮每个数据的顶部 table.

能否删除这些 csv、excel 按钮，并在 header 栏中的固定位置放置一个 downloadButton，提供下载 csv/excel 当前页面或选项卡中活动 table 的选项。

想法是在 header 栏中为整个应用程序设置一个固定的 downloadButton。 shiny 中任何可能的解决方案来做到这一点，或者如果有人以前尝试过这个。

library(shiny)
library(shinydashboard)

ui <- dashboardPage(
  dashboardHeader(title = "Header",
                  dropdownMenuOutput("updatedTimeOutput"),
                  dropdownMenu(type = "notifications", 
                               badgeStatus = "warning",
                               icon = icon("bullhorn", "fa-lg"),
                               notificationItem(icon = icon("bullhorn", "fa-1x"),
                                                status = "info",
                                                text = tags$span(
                                                  tags$b("Please notice!")
                                                )
                               ))),
  dashboardSidebar( sidebarMenu(id = "tabs",
                                menuItem("Page1", tabName = "page1"),
                                menuItem("Page2", tabName = "page2"))),
  dashboardBody(
    tabItems(
      tabItem(
        tabName = "page1",

      tabBox(id="tabs",
      tabPanel("tab1",
          column(12,
                 DT::dataTableOutput("table1")
                 )),
       
       tabPanel( "tab2",
          column(12,
                DT::dataTableOutput("table2")
                ))
       )
      )
      ,
      tabItem(
        tabName = "page2",
        fluidRow(
          column(12,
                 DT::dataTableOutput("table3")
          ))
      )
    )
    )
    )



server <- function(input, output) {
  
  output$table1 <- DT::renderDataTable({
    datatable( data = mtcars,
               options = DToptions,
               extensions = 'Buttons',
               rownames = TRUE,
               selection = 'none'
    )
  })
  
  output$table2 <- DT::renderDataTable({
    datatable( data = mtcars,
               options = DToptions,
               extensions = 'Buttons',
               rownames = TRUE,
               selection = 'none'
    )
  })
    
  output$table3 <- DT::renderDataTable({
    datatable( data = mtcars,
               options = DToptions,
               extensions = 'Buttons',
               rownames = TRUE,
               selection = 'none'
    )
  })
  
  
}

shinyApp(ui, server)

Answer 1

(a) 如果您只想“在活动页面或选项卡中下载 table 的所有页面共有的页眉中可见一个 downloadButton”，则首先需要知道活动页面和选项卡在页面/选项卡 ID 上。 (b) 如果您只需要一个按钮即可下载所有 table，您可以将它们下载到一个 .xlsx 文件中（参见）。 (c)如果每个选项卡都需要一个按钮，请将按钮放在每个选项卡中，您只需将 table 保存为 .csv 即可。这是情况（a）的代码。

library(shiny)
library(shinydashboard)
library(DT)

ui <- dashboardPage(
  dashboardHeader(title = "Header",
                  dropdownMenuOutput("updatedTimeOutput"),
                  dropdownMenu(type = "notifications", 
                               badgeStatus = "warning",
                               icon = icon("bullhorn", "fa-lg"),
                               notificationItem(icon = icon("bullhorn", "fa-1x"),
                                                status = "info",
                                                text = tags$span(
                                                  tags$b("Please notice!")
                                                )
                               ))),
  dashboardSidebar( sidebarMenu(id = "pages", # use unique id for pages
                                menuItem("Page1", tabName = "page1"),
                                menuItem("Page2", tabName = "page2"))),
  dashboardBody(
    
    # Add download button 
    downloadButton('downloadData', 'Download Table',
                   style="font-weight:bold;"
    ),
    helpText(
      hr(style = "border-top: 1px solid #000000;"), 
    ),
    
    tabItems(
      tabItem(
        tabName = "page1",

         tabsetPanel(id="tabs",
                      
               tabPanel("tab1",

                        column(12,
                               DT::dataTableOutput("table1")
                        )),
               
               tabPanel( "tab2",

                         column(12,
                                DT::dataTableOutput("table2")
                         ))
        )
      )
      ,
      tabItem(
        tabName = "page2",
        fluidRow(
          column(12,
                 DT::dataTableOutput("table3")
          ))
      )
    )
  )
)



server <- function(input, output) {
  
  # table1
  tbl1 <- mtcars[1:30, ] # tables 1, 2, 3 use different rows of mtcars to differentiate tables
  
  output$table1 <- DT::renderDataTable({
    datatable( tbl1,
               #    options = DToptions, # no such object called "DToptions"
               extensions = 'Buttons',
               rownames = TRUE,
               selection = 'none'
    )
  })
  
  
  # table2
  tbl2 <-  mtcars[5:45, ]
  
  output$table2 <- DT::renderDataTable({
    datatable( tbl2,
               #    options = DToptions,
               extensions = 'Buttons',
               rownames = TRUE,
               selection = 'none'
    )
  })
  
  # table3
  tbl3 <-  mtcars[11:35, ]
  
  output$table3 <- DT::renderDataTable({
    datatable( tbl3,
               #    options = DToptions,
               extensions = 'Buttons',
               rownames = TRUE,
               selection = 'none'
    )
  })
  

  page_name <- reactive({
    input$pages
  })
  
  # select table on the active page / tab
  selected_table <- reactive({
    if(page_name() == "page1"){
      tbl.list <- list("tab1" = tbl1, "tab2" = tbl2)
      select_tbl <- tbl.list[input$tabs]
    }else{
      select_tbl <- tbl3
    }
    return(select_tbl)
  })
  
  # download table
  output$downloadData <- downloadHandler(
    filename = function() {"table.csv"},
    content = function(file) {write.csv(selected_table(), file, row.names=TRUE)}   
  )    
}

shinyApp(ui, server)

Answer 2


library(shiny)
library(shinydashboard)
library(DT)
library(writexl)

ui <- dashboardPage(
  dashboardHeader(title = "Header",
                  dropdownMenuOutput("updatedTimeOutput"),
                  dropdownMenu(type = "notifications", 
                               badgeStatus = "warning",
                               icon = icon("bullhorn", "fa-lg"),
                               notificationItem(icon = icon("bullhorn", "fa-1x"),
                                                status = "info",
                                                text = tags$span(
                                                  tags$b("Please notice!")
                                                )
                               ))),
  
  dashboardSidebar(sidebarMenu(id = "pages", # use unique id for pages
                                menuItem("Page1", tabName = "page1"),
                                menuItem("Page2", tabName = "page2"))),
  
  dashboardBody(
    
    # Add download button and radioButton
    fluidRow(
      column(3,
             downloadButton('downloadData', 'Download Table',
                            style="font-weight:bold;"
             ),
             helpText(
               hr(style = "border-top: 1px solid #000000;"), 
             )),
      column(3, 
             radioButtons("f", "Download format:",
                          c("csv" = "csv",
                            "Excel" = "xlsx"), inline=T) 
    )),
    
    tabItems(
      tabItem(
        tabName = "page1",

         tabsetPanel(id="tabs",
                      
               tabPanel("tab1",

                        column(12,
                               DT::dataTableOutput("table1")
                        )),
               
               tabPanel( "tab2",

                         column(12,
                                DT::dataTableOutput("table2")
                         ))
        )
      )),
     
      tabItem(
        tabName = "page2",
        fluidRow(
          column(12,
                 DT::dataTableOutput("table3")
          ))
      )
    )
)



server <- function(input, output) {
  
  # table1
  tbl1 <- mtcars[1:30, ] # tables 1, 2, 3 use different rows of mtcars to differentiate tables
  
  output$table1 <- DT::renderDataTable({
    datatable( tbl1,
               #    options = DToptions, # no such object called "DToptions"
               extensions = 'Buttons',
               rownames = TRUE,
               selection = 'none'
    )
  })
  
  
  # table2
  tbl2 <-  mtcars[5:45, ]
  
  output$table2 <- DT::renderDataTable({
    datatable( tbl2,
               #    options = DToptions,
               extensions = 'Buttons',
               rownames = TRUE,
               selection = 'none'
    )
  })
  
  # table3
  tbl3 <-  mtcars[11:35, ]
  
  output$table3 <- DT::renderDataTable({
    datatable( tbl3,
               #    options = DToptions,
               extensions = 'Buttons',
               rownames = TRUE,
               selection = 'none'
    )
  })
  

  page_name <- reactive({
    input$pages
  })
  
  # select table on the active page / tab
  selected_table <- reactive({
    if(page_name() == "page1"){
      tbl.list <- list("tab1" = tbl1, "tab2" = tbl2)
      select_tbl <- tbl.list[input$tabs]
    }else{
      select_tbl <- tbl3
    }
    return(select_tbl)
  })
  
  # select download format
  select_format <- reactive(input$f)
  
  # download table
    output$downloadData <- downloadHandler(
      filename = function(){
        if(select_format() == "csv"){
          {"table.csv"}
      }else{
        {"table.xlsx"}
       }
      } ,
      content = function(file){
        if(select_format() == "csv"){
          {write.csv(selected_table(), file, row.names=TRUE)}
        }else{
          {write_xlsx(selected_table(), file)}
        }  
      } 
    )

}

shinyApp(ui, server)

如何为 R 闪亮网页中的所有数据表设置一个下载按钮

How to have a single download button for all datatables in R shiny webpage

datatable

r

download

shiny