Adds finalize methods to R6 class (ghost issue) (#606)

WIP. Still testing with more filter option Companion of insightsengineering/teal#1275 #### Changes description - Removes all observeEvents generated from `FilterData` when `finalize` method is called. #### How to test - Override `observeEvent` in `{teal.slice}` in order to keep track of all that are created - Stores observers in `.tmp_list` on `.GlobalEnv` - Place `browser()` call somewhere with access to `FilterData` object - Run snippet at bottom that shows count of observers that have not been destroyed - These are shown in order of creation `<order>_<parent r6 class>_<memory address>` - Run `finalize()` - Run snippet again <details> <summary>Example teal app</summary> ```r .tmp_list <- rlang::new_environment() options( teal.log_level = "INFO", teal.show_js_log = TRUE, # teal.bs_theme = bslib::bs_theme(version = 5), shiny.bookmarkStore = "server" ) pkgload::load_all("../teal.slice") pkgload::load_all("../teal") data <- teal::teal_data_module( ui = function(id) { ns <- shiny::NS(id) shiny::tagList( shiny::checkboxGroupInput( ns("datasets"), "Datasets", choices = c("ADSL", "ADTTE", "iris", "CO2", "miniACC"), selected = c("ADSL", "ADTTE", "iris", "CO2") ), shiny::actionButton(ns("submit"), label = "Submit") ) }, server = function(id, ...) { shiny::moduleServer(id, function(input, output, session) { code <- list( ADSL = expression( ADSL <- teal.data::rADSL ), ADTTE = expression({ ADTTE <- teal.data::rADTTE ADTTE$CNSRL <- as.logical(ADTTE$CNSR) }), iris = expression( iris <- iris ), CO2 = expression({ CO2 <- CO2 factors <- names(Filter(isTRUE, vapply(CO2, is.factor, logical(1L)))) CO2[factors] <- lapply(CO2[factors], as.character) }), miniACC = expression({ data( "miniACC", package = "MultiAssayExperiment", envir = environment(), overwrite = TRUE ) miniACC <- miniACC }) ) datasets <- reactive(input$datasets) shiny::eventReactive(input$submit, { code_to_eval <- do.call(c, code[datasets()]) data <- teal.code::eval_code(teal.data::teal_data(), code_to_eval) join_keys(data) <- default_cdisc_join_keys[datasets()] teal.data::datanames(data) <- datasets() data }) }) }, once = FALSE ) teal::init( data = data, modules = teal::modules( teal::example_module(label = "A"), teal::example_module(label = "B") ), filter = teal::teal_slices( # FilterRange teal.slice::teal_slice("ADSL", "AGE", selected = c(18L, 65L)), # FilterExpr teal_slice( dataname = "ADSL", id = "Female adults", expr = "SEX == 'F' & AGE >= 18", title = "Female adults" ), # FilterDatetime teal_slice( dataname = "ADTTE", varname = "ADTM", id = "Analysis DTM", selected = c("2019-03-25 07:06:18", "2020-01-22 15:03:58"), title = "Female adults" ), # FilterDate with LSTALVDT teal_slice( dataname = "ADSL", varname = "LSTALVDT", id = "Last Alive Date", selected = c("2022-02-14", "2022-11-24"), title = "Last Alive Date" ), # FilterEmpty # FilterLogical with CNSRL teal_slice( dataname = "ADTTE", varname = "CNSRL", id = "Censored", selected = TRUE, title = "Censored" ), module_specific = TRUE, teal.slice::teal_slice("ADSL", "SEX") ), title = "yada" ) |> shiny::runApp() ``` </details> <details> <summary>"observeEvent" override</summary> ```r observeEvent = function(eventExpr, handlerExpr, ... ) { logger::log_info("yada") rlang::enquo(eventExpr) rlang::enquo(handlerExpr) obs <- do.call( shiny::observeEvent, list( eventExpr = rlang::enquo(eventExpr), handlerExpr = rlang::enquo(handlerExpr), ... ), envir = parent.frame() ) # Create a temporary list to store observers and parent objects if (is.null(.GlobalEnv$.tmp_list)) .GlobalEnv$.tmp_list <- rlang::new_environment() self <- parent.env(parent.env(parent.frame()))$self obj_addr <- rlang::obj_address(self) |> as.character() |> stringr::str_replace("0x", "") obj_addr <- paste0(class(self)[1], "_", obj_addr) .tmp_list[["objects"]] <- c( list(), .tmp_list[["objects"]], setNames(list(self), obj_addr) ) .tmp_list[[sprintf("%03d_%s", length(.tmp_list[["objects"]]), obj_addr)]] <- c( list(), .tmp_list[[obj_addr]], list(obs) ) obs } ``` </details> <details> <summary>Snippet to analyse ".tmp_list"</summary> ```r ls(.tmp_list) |> purrr::keep(~!grepl("^objects$", .x)) |> vapply( \(x) { sum( vapply( .tmp_list[[x]], \(.x) isFALSE(.x$.destroyed), integer(1L) ) ) }, integer(1L) ) |> as.list() |> jsonlite::toJSON(pretty = TRUE, auto_unbox = TRUE) ``` </details> ![text444](https://github.com/user-attachments/assets/95e29e4a-d2dd-4872-859c-9dbc70ec39a6) --------- Co-authored-by: go_gonzo <[email protected]>
insightsengineering · Aug 2, 2024 · 7765327 · 7765327
1 parent 0c90543
commit 7765327
Show file tree

Hide file tree

Showing 26 changed files with 266 additions and 144 deletions.
diff --git a/R/FilterState.R b/R/FilterState.R
@@ -107,8 +107,6 @@ FilterState <- R6::R6Class( # nolint
 
       private$state_history <- reactiveVal(list())
 
-      logger::log_debug("Instantiated FilterState object id: { private$get_id() }")
-
       invisible(self)
     },
 
@@ -386,9 +384,11 @@ FilterState <- R6::R6Class( # nolint
     #' @description
     #' Destroy observers stored in `private$observers`.
     #'
+    #' The `destroy_shiny` definition is set in the server method.
+    #'
     #' @return `NULL`, invisibly.
     #'
-    destroy_observers = function() {
+    finalize = function() {
       if (!is.null(private$destroy_shiny)) {
         private$destroy_shiny()
         private$destroy_shiny <- NULL

diff --git a/R/FilterStateExpr.R b/R/FilterStateExpr.R
@@ -145,7 +145,7 @@ FilterStateExpr <- R6::R6Class( # nolint
     #'
     #' @return `NULL`, invisibly.
     #'
-    destroy_observers = function() {
+    finalize = function() {
       lapply(private$observers, function(x) x$destroy())
 
       if (!is.null(private$destroy_shiny)) {
@@ -173,19 +173,19 @@ FilterStateExpr <- R6::R6Class( # nolint
         function(input, output, session) {
           private$server_summary("summary")
 
-          private$destroy_shiny <- function() {
-            logger::log_debug("Destroying FilterStateExpr inputs; id: { private$get_id() }")
-            # remove values from the input list
-            lapply(session$ns(names(input)), .subset2(input, "impl")$.values$remove)
-          }
-
           private$observers[[session$ns("remove")]] <- observeEvent(
             once = TRUE, # remove button can be called once, should be destroyed afterwards
             ignoreInit = TRUE, # ignoreInit: should not matter because we destroy the previous input set of the UI
             eventExpr = input$remove, # when remove button is clicked in the FilterState ui
             handlerExpr = remove_callback()
           )
 
+          private$destroy_shiny <- function() {
+            logger::log_debug("Destroying FilterStateExpr inputs; id: { private$get_id() }")
+            # remove values from the input list
+            lapply(session$ns(names(input)), .subset2(input, "impl")$.values$remove)
+          }
+
           NULL
         }
       )

diff --git a/R/FilterStateRange.R b/R/FilterStateRange.R
@@ -506,57 +506,55 @@ RangeFilterState <- R6::R6Class( # nolint
           })
 
           # Dragging shapes (lines) on plot updates selection.
-          private$observers[[session$ns("relayout")]] <-
-            observeEvent(
-              ignoreNULL = FALSE,
-              ignoreInit = TRUE,
-              eventExpr = relayout_data(),
-              handlerExpr = {
-                logger::log_debug("RangeFilterState$server@1 selection changed, id: { private$get_id() }")
-                event <- relayout_data()
-                if (any(grepl("shapes", names(event)))) {
-                  line_positions <- private$get_selected()
-                  if (any(grepl("shapes[0]", names(event), fixed = TRUE))) {
-                    line_positions[1] <- event[["shapes[0].x0"]]
-                  } else if (any(grepl("shapes[1]", names(event), fixed = TRUE))) {
-                    line_positions[2] <- event[["shapes[1].x0"]]
-                  }
-                  # If one line was dragged past the other, abort action and reset lines.
-                  if (line_positions[1] > line_positions[2]) {
-                    showNotification(
-                      "Numeric range start value must be less than end value.",
-                      type = "warning"
-                    )
-                    plotly::plotlyProxyInvoke(
-                      plotly::plotlyProxy("plot"),
-                      "relayout",
-                      shapes = private$get_shape_properties(private$get_selected())
-                    )
-                    return(NULL)
-                  }
-
-                  private$set_selected(signif(line_positions, digits = 4L))
+          private$observers[[session$ns("relayout")]] <- observeEvent(
+            ignoreNULL = FALSE,
+            ignoreInit = TRUE,
+            eventExpr = relayout_data(),
+            handlerExpr = {
+              logger::log_debug("RangeFilterState$server@1 selection changed, id: { private$get_id() }")
+              event <- relayout_data()
+              if (any(grepl("shapes", names(event)))) {
+                line_positions <- private$get_selected()
+                if (any(grepl("shapes[0]", names(event), fixed = TRUE))) {
+                  line_positions[1] <- event[["shapes[0].x0"]]
+                } else if (any(grepl("shapes[1]", names(event), fixed = TRUE))) {
+                  line_positions[2] <- event[["shapes[1].x0"]]
+                }
+                # If one line was dragged past the other, abort action and reset lines.
+                if (line_positions[1] > line_positions[2]) {
+                  showNotification(
+                    "Numeric range start value must be less than end value.",
+                    type = "warning"
+                  )
+                  plotly::plotlyProxyInvoke(
+                    plotly::plotlyProxy("plot"),
+                    "relayout",
+                    shapes = private$get_shape_properties(private$get_selected())
+                  )
+                  return(NULL)
                 }
+
+                private$set_selected(signif(line_positions, digits = 4L))
               }
-            )
+            }
+          )
 
           # Change in selection updates shapes (lines) on plot and numeric input.
-          private$observers[[session$ns("selection_api")]] <-
-            observeEvent(
-              ignoreNULL = FALSE,
-              ignoreInit = TRUE,
-              eventExpr = private$get_selected(),
-              handlerExpr = {
-                logger::log_debug("RangeFilterState$server@2 state changed, id: {private$get_id() }")
-                if (!isTRUE(all.equal(private$get_selected(), selection_manual()))) {
-                  shinyWidgets::updateNumericRangeInput(
-                    session = session,
-                    inputId = "selection_manual",
-                    value = private$get_selected()
-                  )
-                }
+          private$observers[[session$ns("selection_api")]] <- observeEvent(
+            ignoreNULL = FALSE,
+            ignoreInit = TRUE,
+            eventExpr = private$get_selected(),
+            handlerExpr = {
+              logger::log_debug("RangeFilterState$server@2 state changed, id: {private$get_id() }")
+              if (!isTRUE(all.equal(private$get_selected(), selection_manual()))) {
+                shinyWidgets::updateNumericRangeInput(
+                  session = session,
+                  inputId = "selection_manual",
+                  value = private$get_selected()
+                )
               }
-            )
+            }
+          )
 
           # Manual input updates selection.
           private$observers[[session$ns("selection_manual")]] <- observeEvent(

diff --git a/R/FilterStates.R b/R/FilterStates.R
@@ -61,8 +61,6 @@ FilterStates <- R6::R6Class( # nolint
       private$data <- data
       private$data_reactive <- data_reactive
       private$state_list <- reactiveVal()
-
-      logger::log_debug("Instantiated { class(self)[1] }, dataname: { private$dataname }")
       invisible(self)
     },
 
@@ -365,7 +363,7 @@ FilterStates <- R6::R6Class( # nolint
             )
           })
 
-          observeEvent(
+          private$observers[[session$ns("added_states")]] <- observeEvent(
             added_states(), # we want to call FilterState module only once when it's added
             ignoreNULL = TRUE,
             {
@@ -464,7 +462,7 @@ FilterStates <- R6::R6Class( # nolint
             }
           })
 
-          observeEvent(
+          private$observers[[session$ns("var_to_add")]] <- observeEvent(
             eventExpr = input$var_to_add,
             handlerExpr = {
               logger::log_debug(
@@ -492,6 +490,21 @@ FilterStates <- R6::R6Class( # nolint
           NULL
         }
       )
+    },
+
+    #' @description
+    #' Object cleanup.
+    #'
+    #' - Destroy observers stored in `private$observers`
+    #' - Clean `state_list`
+    #'
+    #' @return `NULL`, invisibly.
+    #'
+    finalize = function() {
+      .finalize_observers(self, private) # Remove all observers
+      private$state_list_empty(force = TRUE)
+      isolate(private$state_list(NULL))
+      invisible(NULL)
     }
   ),
   private = list(
@@ -638,11 +651,7 @@ FilterStates <- R6::R6Class( # nolint
                 if (state$get_state()$anchored && !force) {
                   return(TRUE)
                 } else {
-                  state$destroy_observers()
-                  lapply(
-                    Filter(function(x) grepl(state$get_state()$id, x, fixed = TRUE), names(private$observers)),
-                    function(x) private$observers[[x]]$destroy()
-                  )
+                  state$finalize()
                   FALSE
                 }
               } else {

diff --git a/R/FilterStatesSE.R b/R/FilterStatesSE.R
@@ -194,7 +194,7 @@ SEFilterStates <- R6::R6Class( # nolint
             )
           })
 
-          observeEvent(
+          private$observers[[session$ns("avail_row_data_choices")]] <- observeEvent(
             avail_row_data_choices(),
             ignoreNULL = TRUE,
             handlerExpr = {
@@ -219,7 +219,7 @@ SEFilterStates <- R6::R6Class( # nolint
             }
           )
 
-          observeEvent(
+          private$observers[[session$ns("avail_col_data_choices")]] <- observeEvent(
             avail_col_data_choices(),
             ignoreNULL = TRUE,
             handlerExpr = {
@@ -244,7 +244,7 @@ SEFilterStates <- R6::R6Class( # nolint
             }
           )
 
-          observeEvent(
+          private$observers[[session$ns("col_to_add")]] <- observeEvent(
             eventExpr = input$col_to_add,
             handlerExpr = {
               logger::log_debug(
@@ -270,7 +270,7 @@ SEFilterStates <- R6::R6Class( # nolint
           )
 
 
-          observeEvent(
+          private$observers[[session$ns("row_to_add")]] <- observeEvent(
             eventExpr = input$row_to_add,
             handlerExpr = {
               logger::log_debug(