堆栈内存溢出
  繁体   English   中英

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

[英]How to download multiple plots with only one download button in R shiny?

 原文  2021-07-17 10:55:42  6   1    r/ plot/ 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)

1 个解决方案

解决方案1
 2 已采纳  2021-07-17 22:03:31

也许您可以使用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.

相关问题 如何在一个下载按钮中下载几个png图 如何在 R shiny 中将多个图下载为 zip 文件？ 使用 R Shiny 一键下载多个 csv 文件（downloadhandler） R 闪亮-将下载按钮添加到非 ggplot 图中 下载多个情节图到PDF Shiny 如何使用downloadHandler下载闪亮的rCharts图 R Shiny 允许用户下载一个或多个数据集 select 如何使用Shiny中的下载按钮？ R-Shiny下载按钮说明 R - 计数闪亮的下载按钮点击次数
相关标签
 
粤ICP备18138465号  © 2020-2024 STACKOOM.COM