如何在 R Shiny 中仅使用一个下载按钮下载多个图？
Posted
技术标签:
【中文标题】如何在 R Shiny 中仅使用一个下载按钮下载多个图？【英文标题】：How to download multiple plots with only one download button in R shiny? 【发布时间】：2021-09-25 21:33:07 【问题描述】：[查看我在 YBS 答案中使用 ggsave 解决此问题的失败尝试，MWE 在最底部失败，以防有人知道我做错了什么。] 原始问题：我想单击一个下载按钮即可下载多个图（以防止屏幕过于杂乱）。所有绘图都将作为单独的 PNG 文件进入下载目录。
在下面的 MWE 代码中，我的下载按钮适用于第一个图，但我无法弄清楚如何包含第二个图。无需添加第二个按钮！
我希望下载的文件为 .PNG（如下所示）。
在提取此 MWE 的完整 App 中，还有多个绘图，而不仅仅是此 MWE 中显示的 2 个。
关于如何做到这一点的任何想法？
这是 MWE 代码：
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)
这是我的 MWE 尝试使用 ggsave 下载多个绘图失败，就在 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)
【问题讨论】：
建议您查看shinyWidget集合中的选择小部件：rdrr.io/cran/shinyWidgets/man/shinyWidgetsGallery.htmlshinyapps.dreamrs.fr/shinyWidgets 【参考方案1】：也许您可以使用ggsave 来保存您的绘图，如下所示。
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)
这可以在您的 MRE 中实现，如下所示。
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)
【讨论】：
您的示例效果很好，正是我所需要的。从中提取 MWE 的完整应用程序使用 ggplot2，因此您的解决方案很好。但是，我很难在我原来的 MWE 中实施这个建议。请查看我编辑的问题以及我尝试合并 ggsave 的无效尝试，以防有人看到解决方案。可能是反应链中的一个错误，我一直在四处寻找没有运气的解决方案。 网上有很多帖子基本上都在问同样的问题，但答案很麻烦、复杂或不充分，例如为所有图创建一个 zip 文件或将所有图拟合到 1 个 PDF 中。我希望许多其他人也发现这个时尚的解决方案对他们有帮助！ 这个 ggsave 方法效果很好。但是，downloadHandler 函数在提示用户输入保存下载的目录方面做了非常棒的用户友好工作。你知道如何使用 downloadHandler 而不是 ggplot 来做同样的事情（一键下载多个 PNG 文件）吗？到目前为止，我一直在尝试这样做，但没有运气。 我可以使用onclick() 从 shinyjs 下载一个带有 downloadhandler 的文件。但是，我不知道如何将一系列 ID 传递给onclick()。具有良好 javascript 知识的人可以做到这一点。以上是关于如何在 R Shiny 中仅使用一个下载按钮下载多个图？的主要内容，如果未能解决你的问题，请参考以下文章
R Shiny DT::renderDataTable ...如何在下载的表格中自定义标题