I am trying to display multiple plots within multiple tabs. Within each tab, new variables can be selected which display new plots within the tab.This all works, except there is a memory leak. The "Display Current Memory Values" button needs to be clicked to update the memory used. I also used top to watch the system memory use. Both the internal ("Display Current Memory values") and system app (top) show the memory climbing with each new set of plots. I have 16 GB on my server and it got to the point where swap was being used.
I was able to find a workaround for a simpler version discussed at Using ggplot2 grobs to display multiple plots. Is this causing a memory leak?. This required that the number of plot object to always remain the same, so some blank plot objects passed to the uiOutput on the mainPanel. This does not seem to work with this version.
Any help given will be appreciated.
Simple version:
rm(list = ls())
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("Memory Leak Test"),
sidebarLayout(
sidebarPanel(
actionButton("addTab", label = "Add Tab"),
actionButton(inputId = "updateMemory", label = "Display Current Memory Values" ),
verbatimTextOutput("memoryValue"),
actionButton("browser", label = "Enter Browser")
),
mainPanel(
tabsetPanel(id = "tabs")
)
)
)
server <- function(input, output, session) {
tabNumber <<- 0
maxTab <<- 0
env <<- new.env()
myg <<- 0
rv <- reactiveValues(
displayMemory = 0,
addTab = 0
)
output$memoryValue <- renderText ({
input$updateMemory
rv$displayMemory
gc(full = TRUE)
currentSize <- object_size(output)
diff <- currentSize - lastMemorySize
lastMemorySize <- currentSize
if(diff < 0) browser()
str <- HTML(paste("output object size (MB):", format(currentSize/ 1024 / 1024, format = "f", digits = 2),
"\ntotal memory (MB):",formatC(mem_used()/1024/1024, format = "f", digits = 2) ))
})
observeEvent(input$nplots, { rv$displayMemory <- rv$displayMemory + 1} )
observeEvent(input$ngroups, { rv$displayMemory <- rv$displayMemory + 1} )
observeEvent(input$tabs, { tabNumber <<- as.integer(input$tabs)} )
observeEvent(input$browser, { browser() } )
observeEvent(input$addTab, {
maxTab <<- maxTab + 1
tabNumber <<- maxTab
plt[[tabNumber]] <<- list()
pgrob[[tabNumber]] <<- list()
p1[[tabNumber]] <<- list()
thisTab <- paste(tabNumber)
appendTab (inputId = "tabs", tabPanel(thisTab, {
sidebarLayout(
fluid = TRUE,
sidebarPanel (
sliderInput(paste0("ngroups", tabNumber),
"Number of groups:",
min = 1,
max = 3,
value = 2),
sliderInput(paste0("nplots", tabNumber),
"Number of plots in each group:",
min = 1,
max = 50,
value = 2)
), # end sidebarPanel
mainPanel (
renderUI ( {
# cat (paste("tabNumber = ", tabNumber, "\n"))
assign("ngroups", input[[paste0("ngroups", tabNumber)]], envir = env)
assign("nplots", input[[paste0("nplots", tabNumber)]], envir = env)
local ( {
createPlots(ngroups = ngroups, nplots = nplots)
}, envir = env )
} ) # end renderUI
) # end mainPanel
) # end sidebarLayout
} ), select = TRUE) # end appendTab
updateTabsetPanel(session = session, inputId = "tabs", selected = thisTab )
Sys.sleep(1)
} )
createPlots <- function (ngroups, nplots) {
df <- list()
# cat (paste("createPlots", tabNumber, ngroups, nplots, "\n"), file = stderr())
myg <<- 0
for (g in 1:ngroups) {
p1[[g]] <<- list()
pgrob[[g]] <<- list()
for (i in 1:nplots) {
df[[i]] <- as.data.frame(matrix(rexp(20, rate=.1), ncol=2))
colnames(df[[i]]) <- c("x", "y")
p1[[g]][[i]] <<- qplot(x,y,data = df[[i]])
pgrob[[g]][[i]] <<- ggplotGrob(p1[[g]][[i]])
}
ncols = 3
if (nplots < 3) ncols <- nplots
plotname <- paste0("plot-", tabNumber, "-", g)
output[[plotname]] <- renderPlot ( {
myg <<- myg + 1
grid <- do.call("grid.arrange", c(pgrob[[myg]], top = paste("Group", myg, "with", nplots, "Images"), ncol = ncols))
grid
} )
nrows <- ceiling(nplots/ncols)
plt[[g]] <<- plotOutput(plotname, height = paste0(nrows * 100, "px"))
}
if (ngroups != 3) {
for (g in (ngroups + 1):3) {
df <- data.frame()
p1[[g]] <<- list()
p1[[g]][[1]] <<- ggplot(df) + theme(panel.background = element_rect(fill = "white")) # create blank plot
plotname <- paste0("plot-", tabNumber, "-", g)
output[[plotname]] <- renderPlot ( {
p1[[g]][[1]]
})
plt[[g]] <- plotOutput(plotname)
}
}
return (plt)
}
}
# Run the application
shinyApp(ui = ui, server = server)
The following code tries to NULL all output objects, plots, grobs, and the returned object for createPlots, and then run gc(). This also has a memory leak.
rm(list = ls())
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("Memory Leak Test"),
sidebarLayout(
sidebarPanel(
actionButton("addTab", label = "Add Tab"),
actionButton(inputId = "updateMemory", label = "Display Current Memory Values" ),
verbatimTextOutput("memoryValue"),
actionButton("browser", label = "Enter Browser")
),
mainPanel(
tabsetPanel(id = "tabs")
)
)
)
server <- function(input, output, session) {
tabNumber <<- 0
maxTab <<- 0
env <<- new.env()
myg <<- 0
plt <<- list()
pgrob <<- list()
p1 <<- list()
rv <- reactiveValues(
displayMemory = 0,
addTab = 0
)
output$memoryValue <- renderText ({
input$updateMemory
rv$displayMemory
gc(full = TRUE)
currentSize <- object_size(output)
diff <- currentSize - lastMemorySize
lastMemorySize <- currentSize
if(diff < 0) browser()
str <- HTML(paste("output object size (MB):", format(currentSize/ 1024 / 1024, format = "f", digits = 2),
"\ntotal memory (MB):",formatC(mem_used()/1024/1024, format = "f", digits = 2) ))
})
observeEvent(input$nplots, { rv$displayMemory <- rv$displayMemory + 1} )
observeEvent(input$ngroups, { rv$displayMemory <- rv$displayMemory + 1} )
observeEvent(input$tabs, { tabNumber <<- as.integer(input$tabs)} )
observeEvent(input$browser, { browser() } )
observeEvent(input$addTab, {
maxTab <<- maxTab + 1
tabNumber <<- maxTab
plt[[tabNumber]] <<- list()
pgrob[[tabNumber]] <<- list()
p1[[tabNumber]] <<- list()
thisTab <- paste(tabNumber)
appendTab (inputId = "tabs", tabPanel(thisTab, {
sidebarLayout(
fluid = TRUE,
sidebarPanel (
sliderInput(paste0("ngroups", tabNumber),
"Number of groups:",
min = 1,
max = 3,
value = 2),
sliderInput(paste0("nplots", tabNumber),
"Number of plots in each group:",
min = 1,
max = 50,
value = 2)
), # end sidebarPanel
mainPanel (
renderUI ( {#
# cat (paste("tabNumber = ", tabNumber, "\n"))
assign("ngroups", input[[paste0("ngroups", tabNumber)]], envir = env)
assign("nplots", input[[paste0("nplots", tabNumber)]], envir = env)
local ( {
createPlots(ngroups = ngroups, nplots = nplots)
}, envir = env )
} ) # end renderUI
) # end mainPanel
) # end sidebarLayout
} ), select = TRUE) # end appendTab
updateTabsetPanel(session = session, inputId = "tabs", selected = thisTab )
Sys.sleep(1)
} )
createPlots <- function (ngroups, nplots) {
# Try NULLing all pieces of the plot
if (length(plt[[tabNumber]]) > 0) {
for (g in length(plt[[tabNumber]]):1) {
output[[paste0("plot-", tabNumber, "-", g)]] <- NULL
plt[[tabNumber]][[g]] <<- NULL
}
}
if (length(pgrob[[tabNumber]]) > 0) {
for (g in length(pgrob[[tabNumber]]):1) {
for (i in length(pgrob[[tabNumber]][[g]]):1) {
pgrob[[tabNumber]][[g]][[i]] <<- NULL
}
pgrob[[tabNumber]][[g]] <<- NULL
}
}
if (length(p1[[tabNumber]]) > 0) {
for (g in length(p1[[tabNumber]]):1) {
for (i in length(p1[[tabNumber]][[g]]):1) {
p1[[tabNumber]][[g]][[i]] <<- NULL
}
p1[[tabNumber]][[g]] <<- NULL
}
}
gc(full = TRUE, verbose = TRUE)
df <- list()
# cat (paste("createPlots", tabNumber, ngroups, nplots, "\n"), file = stderr())
myg <<- 0
for (g in 1:ngroups) {
p1[[tabNumber]][[g]] <<- list()
pgrob[[tabNumber]][[g]] <<- list()
for (i in 1:nplots) {
df[[i]] <- as.data.frame(matrix(rexp(20, rate=.1), ncol=2))
colnames(df[[i]]) <- c("x", "y")
p1[[tabNumber]][[g]][[i]] <<- qplot(x,y,data = df[[i]])
pgrob[[tabNumber]][[g]][[i]] <<- ggplotGrob(p1[[tabNumber]][[g]][[i]])
}
ncols = 3
if (nplots < 3) ncols <- nplots
plotname <- paste0("plot-", tabNumber, "-", g)
output[[plotname]] <- renderPlot ( {
myg <<- myg + 1
grid <- do.call("grid.arrange", c(pgrob[[tabNumber]][[myg]], top = paste("Group", myg, "with", nplots, "Images"), ncol = ncols))
grid
} )
nrows <- ceiling(nplots/ncols)
plt[[tabNumber]][[g]] <<- plotOutput(plotname, height = paste0(nrows * 100, "px"))
}
if (ngroups != 3) {
for (g in (ngroups + 1):3) {
df <- data.frame()
p1[[tabNumber]][[g]] <<- list()
p1[[tabNumber]][[g]][[1]] <<- ggplot(df) + theme(panel.background = element_rect(fill = "white")) # create blank plot
plotname <- paste0("plot-", tabNumber, "-", g)
output[[plotname]] <- renderPlot ( {
p1[[tabNumber]][[g]][[1]]
})
plt[[tabNumber]][[g]] <- plotOutput(plotname)
}
}
return (plt[[tabNumber]])
}
}
# Run the application
shinyApp(ui = ui, server = server)