如何在R Shiny中创建点击即可导出表格为PDF文件的按钮

当前代码的downloadHandler逻辑存在两处核心错误：

• 仅调用pdf(file)打开了PDF写入设备，既没有向设备中写入表格内容，也没有关闭写入设备，生成的PDF为空
• filename回调函数参数定义错误，Shiny无法正确识别导出文件格式，默认返回HTML页面

我们使用gridExtra包将数据框渲染为PDF格式的表格，按以下步骤修改：

1. 安装依赖包：install.packages("gridExtra")
2. 在代码开头引入gridExtra包
3. 替换原有downloadSummary对应的downloadHandler代码块

library(shiny)
library(xlsx)
library(shinyWidgets)
library(gridExtra)

# 注意替换为你自己的population.xlsx文件路径
population <- read.xlsx("population.xlsx", 1)

fieldsMandatory <- c("selectedCountry")

labelMandatory <- function(label) {
  tagList(
    label,
    span("*", class = "mandatory_star")
  )
}

appCSS <-
  ".mandatory_star {color: red;}"

ui <- fluidPage(
  
  navbarPage(title = span("Spatial Tracking of COVID-19 using Mathematical Models", style = "color:#000000; font-weight:bold; font-size:15pt"),
             
             tabPanel(title = "Model",
                      sidebarLayout(
                        sidebarPanel(
                          shinyjs::useShinyjs(),
                          shinyjs::inlineCSS(appCSS),
                          div(
                            id = "dashboard",
                            pickerInput(
                              inputId = "selectedCountry",
                              labelMandatory ("Country"), 
                              choices = population$Country,
                              multiple = FALSE,
                              options = pickerOptions(
                                actionsBox = TRUE,
                                title = "Please select a country")
                            ),
                            
                            sliderInput(inputId = "agg", 
                                        label = "Aggregation Factor", 
                                        min = 0, max = 50, step = 5, value = 10), 
                            
                            actionButton("go","Run Simulation")
                          )
                        ),
                        mainPanel(
                          tabsetPanel(
                            tabPanel("Input Summary", verbatimTextOutput("summary"),
                                     tableOutput("table"),
                                     downloadButton(outputId = "downloadSummary", label = "Save Summary"))
                          )
                        )
                      )
             )
  )
)

server <- function(input, output, session){
  
  observeEvent(input$resetAll, {
    shinyjs::reset("dashboard")
  })
  
  values <- reactiveValues()
  values$df <- data.frame(Variable = character(), Value = character()) 
  
  observeEvent(input$go, {
    row1 <- data.frame(Variable = "Country", Value = input$selectedCountry)
    row2 <- data.frame(Variable = "Aggregation Factor", Value = input$agg)
    values$df <- rbind(row1, row2)
  })
  
  output$table <- renderTable(values$df)
  
  observe({
    # check if all mandatory fields have a value
    mandatoryFilled <-
      vapply(fieldsMandatory,
             function(x) {
               !is.null(input[[x]]) && input[[x]] != ""
             },
             logical(1))
    mandatoryFilled <- all(mandatoryFilled)
    
    # enable/disable the submit button
    shinyjs::toggleState(id = "go", condition = mandatoryFilled)
  })
  
  # 修正后的下载逻辑
  output$downloadSummary <- downloadHandler(
    filename = function() {
      paste0('my-report_', Sys.Date(), '.pdf')
    },
    content = function(file) {
      pdf(file)
      grid.table(values$df)
      dev.off()
    }
  )
  
}

shinyApp(ui,server)

内容的提问来源于stack exchange，提问作者student_1999