r - 从 Shiny 保存 ggplot 会给出空白 png 文件

Question

我正在尝试保存在 shiny 应用程序中创建的 ggplot2 对象。基本上，此代码允许上传 .xlsx 文件，并在从某些选项中进行选择后创建绘图。然后我添加了一个下载按钮，以便用户可以下载他们创建的绘图。我正在使用 downloadHandler() 和 grDevices::png()。按下按钮确实会下载 .png 文件，但当我打开它时，它只是一个空白的白色方 block 。我是如此接近!任何帮助将非常感激。谢谢。

#initialize
library(shiny)
library(ggplot2)
library(purrr)
library(dplyr)
library(plotly)


#example data
data(iris)

#make some factors
#easier to let ggplot2 control plotting (color, fill) based on type
data(mtcars)
uvals<-sapply(mtcars,function(x){length(unique(x))})
mtcars<-map_if(mtcars,uvals<4,as.factor) %>%
  as.data.frame()


#plotting theme for ggplot2
.theme<- theme(
  axis.line = element_line(colour = 'gray', size = .75),
  panel.background = element_blank(),
  plot.background = element_blank()
)


# UI for app
ui<-(pageWithSidebar(
  # title
  headerPanel("Select Options"),

  #input
  sidebarPanel
  (
    # Input: Select a file ----

    fileInput("file1", "Choose xlsx File",
              multiple = TRUE,
              accept = c(".xlsx")),


    # Horizontal line ----
    tags$hr(),


    #download button
     fluidPage(downloadButton('down')),

    # Input: Select what to display
    selectInput("dataset","Data:",
                choices =list(iris = "iris", mtcars = "mtcars",
                              uploaded_file = "inFile"), selected=NULL),
    selectInput("xaxis","X axis:", choices = NULL),
    selectInput("yaxis","Y axis:", choices = NULL),
    selectInput("fill","Fill:", choices = NULL),
    selectInput("group","Group:", choices = NULL),
    selectInput("plot.type","Plot Type:",
                list(boxplot = "boxplot", histogram = "histogram", density = "density", bar = "bar")
    ),
    checkboxInput("show.points", "show points", TRUE)
  ),

  # output
  mainPanel(
    h3(textOutput("caption")),
    #h3(htmlOutput("caption")),
    uiOutput("plot") # depends on input
  )
))


# shiny server side code for each call
server<-function(input, output, session){

  #update group and
  #variables based on the data
  observe({
    #browser()
    if(!exists(input$dataset)) return() #make sure upload exists
    var.opts<-colnames(get(input$dataset))
    updateSelectInput(session, "xaxis", choices = var.opts)
    updateSelectInput(session, "yaxis", choices = var.opts)
    updateSelectInput(session, "fill", choices = var.opts)
    updateSelectInput(session, "group", choices = var.opts)
  })

  output$caption<-renderText({
    switch(input$plot.type,
           "boxplot"    =   "Boxplot",
           "histogram" =    "Histogram",
           "density"    =   "Density plot",
           "bar"        =   "Bar graph")
  })


  output$plot <- renderUI({
    plotOutput("p")
  })

  #get data object
  get_data<-reactive({

    if(!exists(input$dataset)) return() # if no upload

    check<-function(x){is.null(x) || x==""}
    if(check(input$dataset)) return()

    obj<-list(data=get(input$dataset),
              yaxis=input$yaxis,
              xaxis=input$xaxis,
              fill=input$fill,
              group=input$group
    )

    #require all to be set to proceed
    if(any(sapply(obj,check))) return()
    #make sure choices had a chance to update
    check<-function(obj){
      !all(c(obj$yaxis,obj$xaxis, obj$fill,obj$group) %in% colnames(obj$data))
    }

    if(check(obj)) return()


    obj

  })

  #plotting function using ggplot2
  output$p <- renderPlot({

    plot.obj<-get_data()

    #conditions for plotting
    if(is.null(plot.obj)) return()

    #make sure variable and group have loaded
    if(plot.obj$yaxis == "" | plot.obj$xaxis =="" | plot.obj$fill ==""| plot.obj$group =="") return()

    #plot types
    plot.type<-switch(input$plot.type,
                      "boxplot"     = geom_boxplot(),
                      "histogram" = geom_histogram(alpha=0.5,position="identity"),
                      "density"     =   geom_density(alpha=.75),
                      "bar"         =   geom_bar(position="dodge")
    )


    if(input$plot.type=="boxplot")  {       #control for 1D or 2D graphs
      p<-ggplot(plot.obj$data,
                aes_string(
                  x         = plot.obj$xaxis,
                  y         = plot.obj$yaxis,
                  fill  = plot.obj$fill,# let type determine plotting
                  group = plot.obj$group
                )
      ) + plot.type

      if(input$show.points==TRUE)
      {
        p<-p+ geom_point(color='black',alpha=0.5, position = 'jitter')
      }

    } else {

      p<-ggplot(plot.obj$data,
                aes_string(
                  x         = plot.obj$xaxis,
                  fill  = plot.obj$fill,
                  group     = plot.obj$group
                  #color    = as.factor(plot.obj$group)
                )
      ) + plot.type
    }

    p<-p+labs(
      fill  = input$fill,
      x         = "",
      y         = input$yaxis
    )  +
      .theme
    print(p)
  })

  # set uploaded file
  upload_data<-reactive({

    inFile <- input$file1

    if (is.null(inFile))
      return(NULL)

    #could also store in a reactiveValues
    read_excel(inFile$datapath)
  })

  observeEvent(input$file1,{
    inFile<<-upload_data()
  })

  # downloadHandler contains 2 arguments as functions, namely filename, content
  output$down <- downloadHandler(
    filename =  function() {
      paste(input$dataset,"png" , sep=".")
    },
    # content is a function with argument file. content writes the plot to the device
    content = function(file) {
      png(file) # open the png device
      p # for GGPLOT
      dev.off()  # turn the device off

    } 
  )

}

# Create Shiny app ----
shinyApp(ui, server)

Answer 1

我以评论的形式回复，但我意识到这有点难以理解，因此我将发布完整的修改后的代码以使其更清晰。

我通常建议不要在 render*() 调用中执行过多操作。相反，在单独的 reactive() 对象中设置您要创建的对象，然后在 renderPlot() 中引用该对象。在下面的代码中，我将创建绘图的所有代码移动到名为 p 的 reactive 对象中，然后我可以在 ggsave()< 中引用它 用于下载。

#initialize
library(shiny)
library(ggplot2)
library(purrr)
library(dplyr)
library(plotly)


#example data
data(iris)

#make some factors
#easier to let ggplot2 control plotting (color, fill) based on type
data(mtcars)
uvals<-sapply(mtcars,function(x){length(unique(x))})
mtcars<-map_if(mtcars,uvals<4,as.factor) %>%
  as.data.frame()


#plotting theme for ggplot2
.theme<- theme(
  axis.line = element_line(colour = 'gray', size = .75),
  panel.background = element_blank(),
  plot.background = element_blank()
)


# UI for app
ui<-(pageWithSidebar(
  # title
  headerPanel("Select Options"),

  #input
  sidebarPanel
  (
    # Input: Select a file ----

    fileInput("file1", "Choose xlsx File",
              multiple = TRUE,
              accept = c(".xlsx")),


    # Horizontal line ----
    tags$hr(),


    #download button
    fluidPage(downloadButton('down')),

    # Input: Select what to display
    selectInput("dataset","Data:",
                choices =list(iris = "iris", mtcars = "mtcars",
                              uploaded_file = "inFile"), selected=NULL),
    selectInput("xaxis","X axis:", choices = NULL),
    selectInput("yaxis","Y axis:", choices = NULL),
    selectInput("fill","Fill:", choices = NULL),
    selectInput("group","Group:", choices = NULL),
    selectInput("plot.type","Plot Type:",
                list(boxplot = "boxplot", histogram = "histogram", density = "density", bar = "bar")
    ),
    checkboxInput("show.points", "show points", TRUE)
  ),

  # output
  mainPanel(
    h3(textOutput("caption")),
    #h3(htmlOutput("caption")),
    uiOutput("plot") # depends on input
  )
))


# shiny server side code for each call
server<-function(input, output, session){

  #update group and
  #variables based on the data
  observe({
    #browser()
    if(!exists(input$dataset)) return() #make sure upload exists
    var.opts<-colnames(get(input$dataset))
    updateSelectInput(session, "xaxis", choices = var.opts)
    updateSelectInput(session, "yaxis", choices = var.opts)
    updateSelectInput(session, "fill", choices = var.opts)
    updateSelectInput(session, "group", choices = var.opts)
  })

  output$caption<-renderText({
    switch(input$plot.type,
           "boxplot"    =   "Boxplot",
           "histogram" =    "Histogram",
           "density"    =   "Density plot",
           "bar"        =   "Bar graph")
  })


  output$plot <- renderUI({
    plotOutput("p")
  })

  #get data object
  get_data<-reactive({

    if(!exists(input$dataset)) return() # if no upload

    check<-function(x){is.null(x) || x==""}
    if(check(input$dataset)) return()

    obj<-list(data=get(input$dataset),
              yaxis=input$yaxis,
              xaxis=input$xaxis,
              fill=input$fill,
              group=input$group
    )

    #require all to be set to proceed
    if(any(sapply(obj,check))) return()
    #make sure choices had a chance to update
    check<-function(obj){
      !all(c(obj$yaxis,obj$xaxis, obj$fill,obj$group) %in% colnames(obj$data))
    }

    if(check(obj)) return()


    obj

  })

  p <- reactive({
    plot.obj<-get_data()

    #conditions for plotting
    if(is.null(plot.obj)) return()

    #make sure variable and group have loaded
    if(plot.obj$yaxis == "" | plot.obj$xaxis =="" | plot.obj$fill ==""| plot.obj$group =="") return()

    #plot types
    plot.type<-switch(input$plot.type,
                      "boxplot"     = geom_boxplot(),
                      "histogram" = geom_histogram(alpha=0.5,position="identity"),
                      "density"     =   geom_density(alpha=.75),
                      "bar"         =   geom_bar(position="dodge")
    )


    if(input$plot.type=="boxplot")  {       #control for 1D or 2D graphs
      p<-ggplot(plot.obj$data,
                aes_string(
                  x         = plot.obj$xaxis,
                  y         = plot.obj$yaxis,
                  fill  = plot.obj$fill,# let type determine plotting
                  group = plot.obj$group
                )
      ) + plot.type

      if(input$show.points==TRUE)
      {
        p<-p+ geom_point(color='black',alpha=0.5, position = 'jitter')
      }

    } else {

      p<-ggplot(plot.obj$data,
                aes_string(
                  x         = plot.obj$xaxis,
                  fill  = plot.obj$fill,
                  group     = plot.obj$group
                  #color    = as.factor(plot.obj$group)
                )
      ) + plot.type
    }

    p<-p+labs(
      fill  = input$fill,
      x         = "",
      y         = input$yaxis
    )  +
      .theme
    print(p)
  })

  #plotting function using ggplot2
  output$p <- renderPlot({
    p()
  })

  # set uploaded file
  upload_data<-reactive({

    inFile <- input$file1

    if (is.null(inFile))
      return(NULL)

    #could also store in a reactiveValues
    read_excel(inFile$datapath)
  })

  observeEvent(input$file1,{
    inFile<<-upload_data()
  })

  # downloadHandler contains 2 arguments as functions, namely filename, content
  output$down <- downloadHandler(
    filename =  function() {
      paste(input$dataset,"png" , sep=".")
    },
    # content is a function with argument file. content writes the plot to the device
    content = function(file) {
      ggsave(file, p())
    } 
  )

}

# Create Shiny app ----
shinyApp(ui, server)