Saving ggplot from Shiny gives blank png file - r

Question

I am trying to save a ggplot2 object made in a shiny app. Basically this code allows .xlsx files to be uploaded and plots created after selecting from some options. I have then included a download button so that the user may download the plot they have created. I am using downloadHandler() and grDevices::png(). Pressing the button does cause a .png file to be downloaded, but when I open it, it is just a blank, white square. I am so close! Any help would be much appreciated. Thank you.
#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

I responded as a comment, but I recognize it's a little hard to follow, so I'll post the full revised code to make it clearer.
I generally recommend to not do too much within render*() calls. Rather, set up the object you're looking to create in a separate reactive() object, and just refer to that in renderPlot(). In the code below, I moved all your code that creates the plot into a reactive object named p, and then I can refer to it in ggsave() for the downloading.
#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)