[英]How to download multiple plots with only one download button in R shiny?
[請參閱我嘗試使用 ggsave 每個 YBS 答案解決此問題的失敗嘗試,如果有人知道我做錯了什么,則在最底部失敗 MWE。]原始問題:我想通過單擊一個下載按鈕來下載多個圖(防止屏幕過於雜亂)。 所有圖都將作為單獨的 PNG 文件進入下載目錄。
在下面的 MWE 代碼中,我有第一個圖的下載按鈕,但我無法弄清楚如何包含第二個圖。 無需添加第二個按鈕!
我希望下載的文件是 .PNG(如下所示)。
在提取此 MWE 的完整應用程序中,還有更多圖,而不僅僅是此 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)
這是我嘗試使用ggsave
下載多個圖的 MWE 失敗,就在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)
也許您可以使用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)
聲明:本站的技術帖子網頁,遵循CC BY-SA 4.0協議,如果您需要轉載,請注明本站網址或者原文地址。任何問題請咨詢:yoyou2525@163.com.