How to download multiple plots with only one download button in 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)
1 answers
solution1
2 ACCPTED 2021-07-17 22:03:31
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)
The technical post webpages of this site follow the CC BY-SA 4.0 protocol. If you need to reprint, please indicate the site URL or the original address.Any question please contact:yoyou2525@163.com.
Related Question
How to download several png plots within one download button in shiny
how to download multiple plots as a zip file in R shiny?
Download multiple csv files with one button (downloadhandler) with R Shiny
R shiny- add download button to non-ggplot plots
Download multiple plotly plots to PDF Shiny
How to download rCharts plots in shiny with downloadHandler
R Shiny allow user to select one or multiple datasets to download
How to use the download button in Shiny?
R-shiny download button explained
R - count Shiny download button clicks
Related Tags