R闪亮代码通过单击生成excel选项卡

Question

我正在尝试通过单击创建一个新的 Excel 工作簿，其中包含新的选项卡（加载了数据）。例如，当用户单击“保存此视图”时，代码应生成一个 excel（首先），添加选项卡并复制表格。下次单击时，代码应将选项卡添加到现有 excel 并复制数据。

library(writexl)
library(shiny)
library(shinyWidgets)
library(shinythemes)
library(shinydashboard)
library(openxlsx)
library(DT)
library(dplyr)
library(rlist)
ui <- fluidPage(
  sidebarPanel(
    fluidRow(    column(  width = 10,
                          tags$h3("Select Filters"),
                          panel(  selectizeGroupUI(
                            id = "my-filters1",
                            inline = F,
                            params = list(
                              cyl = list(inputId = "cyl", title = "cyl",multiple=TRUE),
                              gear = list(inputId = "gear", title = "gear",multiple=TRUE),
                              carb = list(inputId = "carb", title = "carb",multiple=TRUE)
                            )
                          ), status = "primary"))),
    actionButton("add1","Save This Veiw"),textAreaInput("caption", "Sheetname", "Output", width = "150px",height=40),
    pickerInput("filter", "Select",multiple = TRUE,options = list(
      `actions-box` = TRUE),c("gear","carb","gear"),selected = c("gear"))



  ),
  mainPanel(
    downloadButton("dl", "Download"),
  dataTableOutput("data1")
)

)
server <- function(input, output) {

  res_mod1 <- callModule(
    module = selectizeGroupServer,
    id = "my-filters1",
    data = mtcars,
    vars = c("cyl","gear","carb")

  )


  base_data <- reactive({ 
    res<- mtcars

    #res$Settlement.Amount.GBP<-ifelse(is.na(res$Settlement.Amount),0,res$Settlement.Amount) 
    if (!(is.null(input$`my-filters1-cyl`))) res<-filter(res, (cyl) == input$`my-filters1-cyl`)
    if (!(is.null(input$`my-filters1-gear`))) res<-filter(res, (gear) == input$`my-filters1-gear`)
    if (!(is.null(input$`my-filters1-carb`))) res<-filter(res, (carb) == input$`my-filters1-carb`)

    res2<- res%>% select(input$filter,mpg)%>%
      group_by(!!!rlang::syms(input$filter)) %>% 
      summarise_at(vars(mpg),funs(sum))


    res2
  }) 




  output$data1 <- DT::renderDataTable(datatable(base_data()))



   filename = function() {
          "output_file.xlsx"
       }
   content = function(file) {
         my_workbook <- createWorkbook()}





   x<-reactive({ observeEvent(input$add1, {
     addWorksheet(
              wb = my_workbook,
             sheetName = input$caption
           )
     writeData(
              my_workbook,
             sheet = 1,
             base_data1(),
             startRow = 6,
             startCol = 2
          )

   })})
   # 
  # 
  # 
  # 
  output$downloadData <- downloadHandler(

    filename,
   content,x
  #     
  #   }
  #   
 )

}
shinyApp(ui, server)

谢谢，

Answer 1

正如我之前的评论中提到的：

library(writexl)
library(shiny)
library(shinyWidgets)
library(shinythemes)
library(shinydashboard)
library(openxlsx)
library(DT)
library(dplyr)
library(rlist)

my_workbook <- createWorkbook()

ui <- fluidPage(
  sidebarPanel(
    fluidRow(    column(  width = 10,
                          tags$h3("Select Filters"),
                          panel(  selectizeGroupUI(
                            id = "my-filters1",
                            inline = F,
                            params = list(
                              cyl = list(inputId = "cyl", title = "cyl",multiple=TRUE),
                              gear = list(inputId = "gear", title = "gear",multiple=TRUE),
                              carb = list(inputId = "carb", title = "carb",multiple=TRUE)
                            )
                          ), status = "primary"))),
    actionButton("add1","Save This Veiw"),textAreaInput("caption", "Sheetname", "Output", width = "150px",height=40),
    pickerInput("filter", "Select",multiple = TRUE,options = list(
      `actions-box` = TRUE),c("gear","carb","gear"),selected = c("gear"))



  ),
  mainPanel(
    downloadButton("dl", "Download"),
    dataTableOutput("data1")
  )

)
server <- function(input, output) {

  res_mod1 <- callModule(
    module = selectizeGroupServer,
    id = "my-filters1",
    data = mtcars,
    vars = c("cyl","gear","carb")

  )


  base_data <- reactive({ 
    res<- mtcars

    #res$Settlement.Amount.GBP<-ifelse(is.na(res$Settlement.Amount),0,res$Settlement.Amount) 
    if (!(is.null(input$`my-filters1-cyl`))) res<-filter(res, (cyl) == input$`my-filters1-cyl`)
    if (!(is.null(input$`my-filters1-gear`))) res<-filter(res, (gear) == input$`my-filters1-gear`)
    if (!(is.null(input$`my-filters1-carb`))) res<-filter(res, (carb) == input$`my-filters1-carb`)

    res2<- res%>% select(input$filter,mpg)%>%
      group_by(!!!rlang::syms(input$filter)) %>% 
      summarise_at(vars(mpg),funs(sum))


    res2
  }) 




  output$data1 <- DT::renderDataTable(datatable(base_data()))



  output$dl <- downloadHandler(
    filename = function() {
      paste("output_file",".xlsx", sep = "")
    },
    content = function(file) {
      saveWorkbook(my_workbook, file, overwrite = TRUE)
    }
  )




observeEvent(input$add1, {
    addWorksheet(
      wb = my_workbook,
      sheetName = input$caption
    )
    writeData(
      my_workbook,
      sheet = 1,
      base_data(),
      startRow = 6,
      startCol = 2
    )

  })


}
shinyApp(ui, server)

这应该可以解决问题。一旦用户单击“保存此视图”，您需要调用 observeEvent 将表格添加到全局工作簿占位符。之后，只要用户单击下载按钮，您只需 saveWorkbook。