Shiny - 导出通过 renderUI 动态创建的多个图形

Question

我有一个应用程序，它根据各种用户输入创建动态数量的图像。绘图是在this link 之后使用renderUI 完成的，但我自己的设置需要进行修改。我现在需要导出这些图，但不知道如何实现。我知道如何导出单个图（包含在下面的示例中），但我希望修改下面的代码以便能够导出动态数量的模型。

希望有任何建议！

library(shiny)
library(dplyr)
library(ggplot2)

# fake data
df <- data.frame(x = 1:10, y = letters[1:10]) %>%
                mutate(Plot = x %/% 3.1 + 1)

# function for plotting dynamic number of plots
get_plot_output_list <- function(input_n, df) {
    
  # Insert plot output objects the list
  plot_output_list <- lapply(1:input_n, function(i) {
    sub <- df %>% filter(Plot == i)
    plotname <- paste("plot", i, sep="")
    plot_output_object <- plotOutput(plotname, height = 280, width = 250)
    plot_output_object <- renderPlot({
      ggplot(sub) + geom_point(aes(x = x, y = y))
    })
  })

  do.call(tagList, plot_output_list) # needed to display properly.
}
                
ui <- navbarPage("My app", id = "nav", 

  tabPanel("Single plot", 
    fluidRow(column(9, plotOutput("plot1")),
            column(2, downloadButton('ExportPlot1', label = "Download plot1")))),
   tabPanel("Multiple plots",
    fluidRow(column(9, 
    selectInput("NPlots", label = "Select number of plots to make", choices = 1:3, selected = 1),
    uiOutput("plots")),
            column(2, downloadButton('ExportPlots', label = "Download all dynamic plots")))))
                
server <- (function(input, output) {
  observe({
    output$plots <- renderUI({ get_plot_output_list(input$NPlots, df) })
  })
  
  plot.calc <- reactive({
        p <- ggplot(df) + geom_point(aes(x = x, y = y))
        output <- list(p = p)
                        })
                        
  output$plot1 <- renderPlot({ plot.calc()$p })                     

  output$ExportPlot1 <- downloadHandler(
    filename = 'Plot1.html',
    
    content = function(file) {
      src <- normalizePath(c('Plot1.Rmd')) # SEE HERE
      owd <- setwd(tempdir())
      on.exit(setwd(owd))
      file.copy(src, c('Plot1.Rmd'), overwrite = TRUE) # SEE HERE
      params <- list(Plot1 = plot.calc()$p)
      
      Sys.setenv(RSTUDIO_PANDOC="C:/Program Files/RStudio/bin/pandoc")
      out <- rmarkdown::render('Plot1.Rmd', output_file = file, params = params, envir = new.env(parent = globalenv()))
      file.rename(out, file)
    })  
})

shinyApp(ui, server)

Rmd 文件：

---
title: "Untitled"
author: "test"
date: "24 3 2021"
output: html_document
params:
  Plot1: NA
---

My plot

```{r, echo = FALSE, warning = FALSE, fig.width = 6.4, fig.height = 3.5}
params$Plot1
```

Answer 1

当您将绘图生成和实际绘图分开时，您可以将生成的绘图传递给Rmd。顺便说一句，当您使用 input$NPlots 之类的反应器时，您不需要 observe：

library(shiny)
library(dplyr)
library(ggplot2)

# fake data
df <- data.frame(x = 1:10, y = letters[1:10]) %>%
  mutate(Plot = x %/% 3.1 + 1)

generate_plots <- function(input_n, df) {
  plot_output_list <- lapply(1:input_n, function(i) {
    sub <- df %>% filter(Plot == i)
    p <- ggplot(sub) + geom_point(aes(x = x, y = y))
    p
  })
  plot_output_list
}

ui <- navbarPage("My app", id = "nav", 
                 
                 tabPanel("Single plot", 
                          fluidRow(column(9, plotOutput("plot1")),
                                   column(2, downloadButton('ExportPlot1', label = "Download plot1")))),
                 tabPanel("Multiple plots",
                          fluidRow(column(9, 
                                          selectInput("NPlots", label = "Select number of plots to make", choices = 1:3, selected = 1),
                                          uiOutput("plots")),
                                   column(2, downloadButton('ExportPlots', label = "Download all dynamic plots")))))

server <- (function(input, output) {
  
  plot_data <- reactive({
    generate_plots(input$NPlots, df)
  })
  
  output$plots <- renderUI({
    plot_output_list <- lapply(seq_len(length(plot_data())), function(i) {
      plotname <- paste("plot", i, sep="")
      plot_output_object <- plotOutput(plotname, height = 280, width = 250)
      plot_output_object <- renderPlot({
        plot_data()[[i]]
      })
    })
    do.call(tagList, plot_output_list) # needed to display properly.
  })
  
  plot.calc <- reactive({
    p <- ggplot(df) + geom_point(aes(x = x, y = y))
    output <- list(p = p)
  })
  
  output$plot1 <- renderPlot({ plot.calc()$p })                     
  
  output$ExportPlot1 <- downloadHandler(
    filename = 'Plot1.html',
    
    content = function(file) {
      src <- normalizePath(c('Plot1.Rmd')) # SEE HERE
      owd <- setwd(tempdir())
      on.exit(setwd(owd))
      file.copy(src, c('Plot1.Rmd'), overwrite = TRUE) # SEE HERE
      params <- list(Plot1 = plot.calc()$p,
                     Plot_list = plot_data())
      
      Sys.setenv(RSTUDIO_PANDOC="C:/Program Files/RStudio/bin/pandoc")
      out <- rmarkdown::render('Plot1.Rmd', output_file = file, params = params, envir = new.env(parent = globalenv()))
      file.rename(out, file)
    })  
  
  output$ExportPlots <- downloadHandler(
    filename = 'Plots.html',
    
    content = function(file) {
      src <- normalizePath(c('Plots.Rmd')) # SEE HERE
      owd <- setwd(tempdir())
      on.exit(setwd(owd))
      file.copy(src, c('Plots.Rmd'), overwrite = TRUE) # SEE HERE
      params <- list(Plot_list = plot_data())
      
      Sys.setenv(RSTUDIO_PANDOC="C:/Program Files/RStudio/bin/pandoc")
      out <- rmarkdown::render('Plots.Rmd', output_file = file, params = params, envir = new.env(parent = globalenv()))
      file.rename(out, file)
    })
})

shinyApp(ui, server)

Plots.Rmd

---
title: "Untitled"
author: "test"
date: "24 3 2021"
output: html_document
params:
  Plot_list: NA
---

Multiple Plots

```{r, echo = FALSE, warning = FALSE, fig.width = 6.4, fig.height = 3.5}
purrr::walk(params$Plot_list, print)
```