如何让Shiny中ggplot动态保存与应用内同比例的图表？

我开发了一个大型Shiny应用，包含大量可由用户选择保存的图表。此前借助@stefan的方案实现了保存自动化功能，运行良好。但在探索性数据分析过程中，用户可在应用窗口内修改直方图的宽高比例，保存的图表却始终沿用首次设置的尺寸，后续调整不会生效。我猜测是响应式相关问题，但已尝试将当前宽高参数传递给保存图表的模块。

以下是最小可复现示例（MRE）：

library(shiny)
library(ggplot2)
library(shinyWidgets) # 注意：原代码用到pickerInput，需加载该包

######Save plot modules
downloadButtonUI <- function(id) {
  downloadButton(NS(id, "dl_plot"))
}
downloadSelectUI <- function(id) {
  pickerInput(NS(id, "format"), label = "Format: ", choices = c("eps","ps","tex","pdf","jpeg","tiff","png","bmp","svg","wmf","emf"),selected = "svg",width = "75px")
}
downloadServer <- function(id, plot,height=NA,width=NA) {
  moduleServer(id, function(input, output, session) {
    output$dl_plot <- downloadHandler(
      filename = function() {
        file_format <- tolower(input$format)
        paste0(id, ".", file_format)
      },
      content = function(file) {
        ggsave(file, plot = plot(),height = height, width=width, units = "px")
      }
    )
  })
}

ui <- fluidPage(

    titlePanel("Old Faithful Geyser Data"),

    sidebarLayout(
        sidebarPanel(
            sliderInput("hist_width",
                        "Width",
                        min = 300,
                        max = 1600,
                        value = 800,
                        step = 100),
            sliderInput("hist_height",
                        "Height",
                        min = 300,
                        max = 1600,
                        value = 800,
                        step = 100)
        ),

        # Show a plot of the generated distribution
        mainPanel(
           plotOutput("histo_plot",width = "auto",height = "auto"),
           fluidRow(
             column(3, downloadButtonUI("histoplot")),
             column(3,downloadSelectUI("histoplot")
                    )
           )
        )
    )
)

server <- function(input, output) {
  
  #global reactives
  hist_width<-reactive(input$hist_width)
  hist_height<-reactive(input$hist_height)
  
  ###Allows downloading of histograms
  output$histo_plot<-renderPlot(histo_plot(),width = hist_width,height = hist_height)
  
  downloadServer("histoplot", histo_plot, width=hist_width(),height = hist_height())
  ###

    histo_plot <- reactive({
        x    <- data.frame(faithful[, 2])
        names(x)<-"Data"
        
        # draw the histogram
        
        ggplot(x,aes(x=Data))+
          geom_histogram()+
          ggtitle("Data")
    })
}

# Run the application 
shinyApp(ui = ui, server = server)

解决方案 #

问题根源：调用downloadServer时，你传递的hist_width()和hist_height()是服务器启动时的静态初始值，这行代码只会执行一次，不会随滑块调整更新。需要让下载模块能获取到实时的响应式尺寸值。

修改步骤： #

1. 调整下载模块的参数接收方式：让downloadServer的height和width参数接受响应式对象（而非直接调用()获取值）
2. 在下载时实时获取尺寸：在downloadHandler的content函数中，调用height()和width()来获取最新的滑块值

修改后的完整代码： #

library(shiny)
library(ggplot2)
library(shinyWidgets)

######Save plot modules
downloadButtonUI <- function(id) {
  downloadButton(NS(id, "dl_plot"))
}
downloadSelectUI <- function(id) {
  pickerInput(NS(id, "format"), label = "Format: ", choices = c("eps","ps","tex","pdf","jpeg","tiff","png","bmp","svg","wmf","emf"),selected = "svg",width = "75px")
}
downloadServer <- function(id, plot, height = NA, width = NA) {
  moduleServer(id, function(input, output, session) {
    output$dl_plot <- downloadHandler(
      filename = function() {
        file_format <- tolower(input$format)
        paste0(id, ".", file_format)
      },
      content = function(file) {
        # 实时获取最新的宽高值，兼容静态参数场景
        current_height <- if(is.reactive(height)) height() else height
        current_width <- if(is.reactive(width)) width() else width
        ggsave(file, plot = plot(), height = current_height, width = current_width, units = "px")
      }
    )
  })
}

ui <- fluidPage(
    titlePanel("Old Faithful Geyser Data"),
    sidebarLayout(
        sidebarPanel(
            sliderInput("hist_width",
                        "Width",
                        min = 300,
                        max = 1600,
                        value = 800,
                        step = 100),
            sliderInput("hist_height",
                        "Height",
                        min = 300,
                        max = 1600,
                        value = 800,
                        step = 100)
        ),
        mainPanel(
           plotOutput("histo_plot", width = "auto", height = "auto"),
           fluidRow(
             column(3, downloadButtonUI("histoplot")),
             column(3, downloadSelectUI("histoplot"))
           )
        )
    )
)

server <- function(input, output) {
  #global reactives
  hist_width <- reactive(input$hist_width)
  hist_height <- reactive(input$hist_height)
  
  output$histo_plot <- renderPlot(histo_plot(), width = hist_width, height = hist_height)
  
  # 直接传递响应式对象，不加()
  downloadServer("histoplot", histo_plot, width = hist_width, height = hist_height)

  histo_plot <- reactive({
    x <- data.frame(faithful[, 2])
    names(x) <- "Data"
    ggplot(x, aes(x=Data)) +
      geom_histogram() +
      ggtitle("Data")
  })
}

# Run the application 
shinyApp(ui = ui, server = server)

关键修改说明： #

• 在downloadServer的content函数中增加判断：如果height/width是响应式对象，就调用()获取实时值，否则使用静态值，兼容原有使用场景
• 调用downloadServer时直接传递hist_width和hist_height（不带括号），让模块能监听响应式变化
• 补充shinyWidgets包的加载，避免pickerInput运行报错

内容的提问来源于stack exchange，提问作者Steven Ouellette