如何在 R Shiny 中只用一个下载按钮下载多个图？

Question

[See my failed attempt to address this question with ggsave per YBS answer, failed MWE at the very bottom in case anyone knows what I'm doing wrong.] Original question: I would like to download multiple plots with the click of one download button (to prevent an overly-cluttered screen). All plots would go to the download directory, as separate PNG files.

In the below MWE code I have the download button working for the first plot but I haven't been able to figure out how to include the 2nd plot. Without adding a second button!

I'd like the downloaded file to be .PNG (as the below does).

In the full App this MWE is extracted from, there are several more plots and not just the 2 shown in this MWE.

Any thoughts on how to do this?

Here's the MWE code:

library(shiny)
library(shinyMatrix)
library(shinyjs)
library(DT)

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", "Download"),
                 
                 uiOutput("vectorTable")),
        id = "tabselected")
    ) # close main panel
  ) # close page with sidebar

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() {paste("yieldVector","png",sep=".")},
    content = function(file){
      png(file)
      plot(vectorVariable(input$base_input[1,1],vector_input()))
      dev.off()}
  ) # close download handler
  
  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)

Here´s my MWE failed attempt to use ggsave to download multiple plots, just beneath the commented-out section under Server :

library(shiny)
library(shinyMatrix)
library(shinyjs)
library(DT)
library(ggplot2)

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'),
                 
                 actionButton("download", "Download"),
                 
                 uiOutput("vectorTable")),
        id = "tabselected")
    ) # close main panel
  ) # close page with sidebar

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() {paste("yieldVector","png",sep=".")},
  #   content = function(file){
  #     png(file)
  #     plot(vectorVariable(input$base_input[1,1],vector_input()))
  #     dev.off()}
  # ) # close download handler
  
  mydata <- reactive(list(
    plot(vectorVariable(input$base_input[1,1],vector_input())),
    plot(vectorVariable(input$base_input[2,1],vector1_input()))
      ) # close list
    ) # close reactive
  nplots <- reactive(length(mydata))
  
  observeEvent(input$download, {
    lapply(1:nplots, function(i){
      ggsave(paste0("yplot",i,".png"), plot(mydata[[i]]))
    })
  }, ignoreInit = TRUE)
  
  
  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)

Answer 1

Perhaps you can use ggsave to save your plots as shown below.

library(shiny)

ui <- fluidPage(
  actionButton("down", "Download", icon = icon("download"))
)

server <- function(input, output, session) {
  mydata <- list(cars,pressure,airquality)
  nplots <- length(mydata)
  
  observeEvent(input$down, {
    lapply(1:nplots, function(i){
      ggsave(paste0("yplot",i,".png"), plot(mydata[[i]]))
    })
  }, ignoreInit = TRUE)
}

shinyApp(ui=ui,server=server)

This could be implemented in your MRE as shown below.

library(shiny)
library(shinyMatrix)
library(shinyjs)
library(DT)
library(ggplot2)

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'),
                 
                 actionButton("download", "Download"), 
                 
                 uiOutput("vectorTable")),
        id = "tabselected")
    ) # close main panel
  ) # close page with sidebar

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() {paste("yieldVector","png",sep=".")},
  #   content = function(file){
  #     png(file)
  #     plot(vectorVariable(input$base_input[1,1],vector_input()))
  #     dev.off()}
  # ) # close download handler
  
  mydata <- reactive(list(
  
    data.frame(vectorVariable(input$base_input[1,1],vector_input())),
    data.frame(vectorVariable(input$base_input[2,1],vector1_input()))
  ) # close list
  ) # close reactive
  nplots <- reactive(length(mydata()))
  
  observeEvent(input$download, {
    lapply(1:nplots(), function(i){
      ggsave(paste0("yplot",i,".png"), plot(mydata()[[i]]))
    })
  }, ignoreInit = TRUE)
  
  
  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)