My main concern is that the object_size(output) grows with every set of plots displays and never seems to be garbage collected.
I have noticed that if the plots that are use to create the grobs are deleted before the grobs are displayed, the plots are not displayed. I modified the code (below) to remove each component of the output, one layer at a time before the next set of plots are created. This zeros out the memory for all variables, but the output object. If I keep clicking the "Update Tab" button for tab 1, the output object just keeps growing in size. I have gotten to above 1 GB of memory and as the size of the output object grows, the application seems to slows down. Unless the garbage collection routine waits for the application to use and exorbitant amount of memory before collecting unused memory or I don't understand how the output object works, this seems like a memory leak.
library(shiny)
library(pryr)
library(ggplot2)
library(grid)
library(gridExtra)
totalTabs <<- 1
lastMemorySize <<- 0
# Define UI for application that draws a histogram
ui <- fluidPage(
# Application title
titlePanel("test"),
# Sidebar with a slider input for number of bins
sidebarLayout(
sidebarPanel(
sliderInput("tabNumber",
"Tab Number to use:",
min = 1,
max = totalTabs,
value = 1),
sliderInput("ngroups",
"Number of groups:",
min = 1,
max = 3,
value = 1),
sliderInput("nplots",
"Number of plots in each group:",
min = 1,
max = 50,
value = 20),
actionButton(inputId = "addTab", label = "Update Tab" ),
textOutput("memoryValue")
),
# Show a plot of the generated distribution
mainPanel(
uiOutput("distPlot")
)
)
)
# Define server logic required to draw a histogram
server <- function(input, output, session) {
rv <- reactiveValues(
plotList = list()
)
output$memoryValue <- renderText ({
input$tabNumber
input$ngroups
input$nplots
input$addTab
currentSize <- object_size(output)
diff <- currentSize - lastMemorySize
lastMemorySize <- currentSize
if(diff < 0) browser()
str <- paste("output object size (MB):", format(currentSize/ 1024 / 1024))
})
# clearPlots <- function () {
#
# if (length(rv$plotList) > 0){
# if (length(rv$plotList) >= input$tabNumber) {
# local({
# for (g in 1:local(ngroups, envir = rv$plotList[[input$tabNumber]]) ) {
# plotname <- paste0("plot-", tabNumber, "-", g)
#
# output[[plotname]] <- NULL
# }
# output <- NULL
# rm(list = ls())
# }, envir =rv$plotList[[input$tabNumber]])
# } else
# rv$plotList[[input$tabNumber]] <- new.env()
# }
# else
# rv$plotList <- list(new.env())
# }
observeEvent(input$addTab, {
addNewTab()
})
addNewTab <- function() {
if (input$tabNumber == totalTabs) {
totalTabs <<- totalTabs + 1
updateSliderInput(session, inputId = "tabNumber", label = "Tab Number to use:",
value = input$tabNumber, min = 1, max = totalTabs, step = 1)
}
if(length(rv$plotList) == 0) { rv$plotList <- list(new.env()) } else {
if (length(rv$plotList) < input$tabNumber) { rv$plotList[[input$tabNumber]] <- new.env() } else {
local ( {
# # cat("start of local\n", file = stderr())
# # gc(verbose = TRUE, full = TRUE)
# lnames <- c()
for (g in ngroups:1) {
output[[paste0("plot-", tabNumber, "-", g)]] <- NULL
}
}, envir = rv$plotList[[input$tabNumber]])
}
#browser()
}
assign("tabNumber", input$tabNumber, envir = rv$plotList[[input$tabNumber]])
assign("ngroups", input$ngroups, envir = rv$plotList[[input$tabNumber]])
assign("nplots", input$nplots, envir = rv$plotList[[input$tabNumber]])
local({
p <- list()
df <- list()
pgrob <- list()
plt <- list()
for (g in 1:ngroups) {
p[[g]] <- list()
pgrob[[g]] <- list()
for (i in 1:input$nplots) {
df[[i]] <- as.data.frame(matrix(rexp(20, rate=.1), ncol=2))
colnames(df[[i]]) <- c("x", "y")
p[[g]][[i]] <- qplot(x,y,data = df[[i]])
pgrob[[g]][[i]] <- ggplotGrob(p[[g]][[i]])
}
ncols = 3
if (input$nplots < 3) ncols <- input$inplots
output[[paste0("plot-", tabNumber, "-", g)]] <- renderPlot ( {
myg <<- myg + 1
if(myg > input$ngroups) myg <<- 1
do.call("grid.arrange", c(pgrob[[myg]], top = paste("Group", myg, "with", input$nplots, "Images"), ncol = ncols))
} )
}
}, envir = rv$plotList[[input$tabNumber]])
}
output$distPlot <- renderUI({
if (length(rv$plotList) == 0) return ()
if (length(rv$plotList) < input$tabNumber) return ()
assign("tabNumber", input$tabNumber, envir = rv$plotList[[input$tabNumber]])
assign("ngroups", input$ngroups, envir = rv$plotList[[input$tabNumber]])
local({
for(g in 1:ngroups) {
plotname <- paste0("plot-", tabNumber, "-", g)
myg <<- 0
plt[[g]] <- plotOutput(plotname)
# cat(paste("distPlot plt", g, object_size(plt[[g]]), "\n"), file = stderr())
}
# cat(paste("distPlot plt", object_size(plt), "\n"), file = stderr())
if (length(plt) == 0)
return (NULL)
else
return(plt)
}, envir = rv$plotList[[input$tabNumber]])
})
observeEvent(input$ngroups, {})
observeEvent(input$nplots, {})
observeEvent(input$tabNumber, {})
}
# Run the application
shinyApp(ui = ui, server = server)