0

Following Jonas Hag's example for destroying observe events in order to recover memory during a session, I've added code to check memory usage using pryr.

Each time a module is removed, mem_change() is negative, which seems to indicate memory is recovered. However the overall memory using mem_used() keeps increasing.

Not recovering inputs or observers (by uncommenting the return statements below) shows the same overall memory increases.

Does the memory get recovered and pryr is inaccurate or is there something else needed to recover memory during a session?

It seems restarting the session recovers memory, however that seems a bad idea when a user is interacting with the app.

library(shiny)
library(ggplot2)
library(pryr)
library(gt)

graph_UI <- function(id) {
  ns <- NS(id)
  
  div(
    id = id,
    selectInput(
      inputId = ns("plottype"),
      label = "plot type",
      choices = c("boxplot", "histogram")
    ),
    actionButton(
      inputId = ns("change_colour"),
      label = "change colour"
    ),
    plotOutput(
      outputId = ns("plot_1")
    )
  )
}

graph_server <- function(id) {
  moduleServer(
    id,
    function(input, output, session) {
      plot_colour <- reactiveVal(value = "black")
      default_colours <- c("black", "red", "green", "blue")
      
      session$userData[[paste0(id, "_observer_", "1")]] <-
        observeEvent(input$change_colour, {
          colour_index <- input$change_colour %% 4 + 1
          new_colour <- default_colours[colour_index]
          plot_colour(new_colour)
        })
      
      output$plot_1 <- renderPlot({
        p <- ggplot(mtcars, aes(x = mpg))
        
        if (input$plottype == "boxplot") {
          p <- p + geom_boxplot(fill = plot_colour())
        } else {
          p <- p + geom_histogram(fill = plot_colour())
        }
        
        p
        
      })
    }
  )
}

remove_shiny_inputs <- function(id, .input) {
  # return() # Uncomment to test case when not removing
  invisible(
    memory_change <- mem_change(
      lapply(grep(id, names(.input), value = TRUE), function(i) {
        .subset2(.input, "impl")$.values$remove(i)
      })
    )
  )
  message("Remove inputs memory change: ", memory_change)
}

remove_observers <- function(id, .session) {
  # return() # Uncomment to test case when not removing
  invisible(
    memory_change <- mem_change(
      lapply(grep(paste0(id, "_observer"), names(.session$userData), value = TRUE),
           function(i) {
             .subset2(.session$userData, i)$destroy()
           })
    )
  )
  message("Remove observers memory change: ", memory_change)
}

ui <- fluidPage(
  actionButton(
    inputId = "add_module",
    label = "Add a module"
  )
  , actionButton(
    inputId = "remove_module",
    label = "Remove a module"
  )
  , gt_output("usage")
  , div(
    id = "add_here"
  )
)

server <- function(input, output, session) {
  
  active_modules <- reactiveVal(value = NULL)
  max_module_used <- reactiveVal(value = 0)
  
  observeEvent(input$add_module, {
    # update the number of currently shown modules
    max_module_used(max_module_used() + 1)
    active_modules(c(max_module_used(), active_modules()))
    current_id <- paste0("id_", max_module_used())
    
    graph_server(
      id = current_id
    )
    
    insertUI(
      selector = "#add_here",
      ui = graph_UI(id = current_id)
    )
  })
  
  observeEvent(input$remove_module, {
    
    # only remove a module if there is at least one module shown
    if (length(active_modules()) > 0) {
      current_id <- paste0("id_", active_modules()[1])
      removeUI(
        selector = paste0("#", current_id)
      )
      
      # remove the inputs
      remove_shiny_inputs(
        id = current_id,
        .input = input
      )
      
      # remove the observers
      remove_observers(
        id = current_id,
        .session = session
      )
      
      # update the number of currently shown modules
      active_modules(active_modules()[-1])
    }
  })
  
  output$usage <- render_gt({
    
    df <- data.table(
      "Memory usage (MB)" = mem_used()/1024/1024
      , "Added" = input$add_module
      , "Removed" = input$remove_module
    )
    
    df %>% gt()
    
  })
  
  
}

shinyApp(ui, server)
Vlad
  • 3,058
  • 4
  • 25
  • 53

0 Answers0