如何在R Shiny中通过单个下载按钮导出多个PNG格式绘图

核心思路 #

Shiny的单个downloadHandler默认只能返回一个文件，因此我们可以将所有生成的独立PNG图片打包为一个ZIP压缩包提供下载，用户解压后即可获得所有单独的PNG绘图文件，完美适配多图批量导出、仅用一个下载按钮的需求。

之前尝试失败的原因 #

1. 使用的是R基础绘图函数plot()，它的返回值为NULL，不是ggplot2的绘图对象，直接传入ggsave()会无法识别绘图内容
2. 直接在按钮的observeEvent中调用ggsave，文件只会保存在Shiny服务端的运行目录，用户的浏览器端无法直接获取到这些文件，必须通过downloadHandler触发浏览器的下载流程。

修改后完整可运行代码 #

library(shiny)
library(shinyMatrix)
library(shinyjs)
library(DT)
library(zip) # 用于打包zip文件

matrix1.input <- function(x){
  matrixInput(x, 
              value = matrix(c(0.2), 2, 1, dimnames = list(c("A","B"),NULL)),
              rows = list(extend = FALSE,  names = TRUE),
              cols = list(extend = FALSE, names = FALSE, editableNames = FALSE),
              class = "numeric")}

matrix2.input <- function(x,y,z){
  matrixInput(x,
              value = matrix(c(y,z),1,2,dimnames=list(NULL,c("Y","Z"))),
              rows = list(extend = TRUE,  names = FALSE),
              cols = list(extend = FALSE, names = TRUE, editableNames = FALSE),
              class = "numeric")}  

matrix.validate <- function(x,y){
  a <- y        
  a[,1][a[,1]>x] <- x 
  b <- diff(a[,1,drop=FALSE]) 
  b[b<=0] <- NA               
  b <- c(1,b)                 
  a <- cbind(a,b)
  a <- na.omit(a) 
  a <- a[,-c(3),drop=FALSE]         
  return(a)}

vector.base <- function(x,y){
  a <- rep(y,x) 
  b <- seq(1:x) 
  c <- data.frame(x = b, y = a) 
  return(c)}

vector.multi <- function(x,y,z){                                            
  a <- rep(NA, x)
  a[y] <- z       
  a[seq_len(min(y)-1)] <- a[min(y)] 
  if(max(y) < x){a[seq(max(y)+1, x, 1)] <- 0}   
  a <- approx(seq_along(a)[!is.na(a)],a[!is.na(a)],seq_along(a))$y  
  b <- seq(1:x)                                                     
  c <- data.frame(x = b, z = a)                                     
  return(c)}

vector.multiFinal <- function(x,y){
  vector.multi(x,matrix.validate(x,y)[,1],matrix.validate(x,y)[,2])}

matrix.link <- function(x,y){
  observeEvent(input$periods|input$base_input,{
    updateMatrixInput(session,x,value=matrix(c(input$periods,y),1,2,dimnames=list(NULL, c("y","z"))))})}

ui <- 
  pageWithSidebar(
    headerPanel("Model"),
    sidebarPanel(uiOutput("Panels")),
    mainPanel(
      tabsetPanel(
        tabPanel("Dynamic", value=2,
                 actionButton('showVectorPlotBtn','Vector plots'),
                 actionButton('showVectorValueBtn','Vector values'),
                 
                 downloadButton("downloadData", "下载所有绘图"),
                 
                 uiOutput("vectorTable")),
        id = "tabselected")
    ) 
  ) 

server <- function(input,output,session)({
  periods       <- reactive(input$periods)
  base_input    <- reactive(input$base_input)
  vector_input  <- reactive(input$vector_input)
  vector1_input <- reactive(input$vector1_input)
  yld           <- reactiveValues()
  
  vectorVariable <- function(x,y){
    if(input$showVectorBtn == 0) vector.base(input$periods,x)
    else vector.multiFinal(input$periods,matrix.validate(input$periods,y))}
  
  output$Panels <- renderUI({
    tagList( 
      conditionalPanel(
        condition="input.tabselected==2",
        sliderInput('periods','',min=1,max=120,value=60),
        matrix1.input("base_input"),
        useShinyjs(),
        actionButton('showVectorBtn','Show'), 
        actionButton('hideVectorBtn','Hide'),
        actionButton('resetVectorBtn','Reset'),
        hidden(uiOutput("Vectors"))))})
  
  renderUI({
    matrix.link("vector_input",input$base_input[1,1])
    matrix.link("vector1_input",input$base_input[2,1])})
  
  output$Vectors <- renderUI({input$resetVectorBtn
    tagList(matrix2.input("vector_input",input$periods,input$base_input[1,1]),
            matrix2.input("vector1_input",input$periods,input$base_input[2,1]))})
  
  observeEvent(input$showVectorBtn,{shinyjs::show("Vectors")})
  observeEvent(input$hideVectorBtn,{shinyjs::hide("Vectors")})
  
  output$graph1 <- renderPlot(plot(vectorVariable(input$base_input[1,1],vector_input())))
  output$graph2 <- renderPlot(plot(vectorVariable(input$base_input[2,1],vector1_input())))
  
  # 修改后的多图下载逻辑
  output$downloadData <- downloadHandler(
    filename = function() {
      paste0("yieldVector_", Sys.Date(), ".zip")
    },
    content = function(file) {
      # 新建临时目录存所有png
      temp_dir <- tempdir()
      # 存第一个图
      png(file.path(temp_dir, "plot_1_A.png"))
      plot(vectorVariable(input$base_input[1,1],vector_input()))
      dev.off()
      # 存第二个图
      png(file.path(temp_dir, "plot_2_B.png"))
      plot(vectorVariable(input$base_input[2,1],vector1_input()))
      dev.off()
      # 如果有更多图，按上面的逻辑循环添加即可
      
      # 打包所有png为zip
      zip_files <- list.files(temp_dir, pattern = "^plot_.*\\.png$", full.names = TRUE)
      zip::zipr(zipfile = file, files = zip_files)
    }
  ) 
  
  output$table1 <- renderDT({vectorsAll()})
  
  observeEvent(input$showVectorPlotBtn,{yld$showme <- tagList(plotOutput("graph1"), plotOutput("graph2"))},ignoreNULL = FALSE)
  observeEvent(input$showVectorValueBtn,{yld$showme <- DTOutput("table1")})
  
  output$vectorTable <- renderUI({yld$showme})
  
  vectorsAll <- reactive({
    cbind(1:periods(),
          vectorVariable(input$base_input[1,1],vector_input())[,2],
          vectorVariable(input$base_input[2,1],vector1_input())[,2])})})

shinyApp(ui, server)

扩展说明 #

如果后续需要导出更多绘图，只需要在downloadHandler的content函数里新增对应绘图的生成逻辑即可，不需要新增下载按钮，适配任意数量的绘图导出需求。如果后续改用ggplot2绘图，把png()+plot()+dev.off()的逻辑换成ggsave()写入临时目录即可，打包逻辑不用修改。

内容的提问来源于stack exchange，提问作者Curious Jorge - user9788072