duplicated available slices

R/FilterState.R

@@ -205,7 +205,6 @@ FilterState <- R6::R6Class( # nolint
         id = id,
         function(input, output, session) {
           logger::log_trace("FilterState$server initializing module for slice: { private$get_id() } ")
-
           private$server_summary("summary")
           if (private$is_fixed()) {
             private$server_inputs_fixed("inputs")

R/FilterStates.R

@@ -201,14 +201,9 @@ FilterStates <- R6::R6Class( # nolint
     remove_filter_state = function(state) {
       shiny::isolate({
         checkmate::assert_class(state, "teal_slices")
-
-        lapply(state, function(x) {
-          state_id <- x$id
-          logger::log_trace("{ class(self)[1] }$remove_filter_state removing filter, state_id: { state_id }")
-          private$state_list_remove(state_id = state_id)
-          logger::log_trace("{ class(self)[1] }$remove_filter_state removed filter, state_id: { state_id }")
-        })
-
+        state_ids <- vapply(state, `[[`, character(1), "id")
+        logger::log_trace("{ class(self)[1] }$remove_filter_state removing filters, state_id: { toString(state_ids) }")
+        private$state_list_remove(state_ids)
         invisible(NULL)
       })
     },
@@ -345,47 +340,52 @@ FilterStates <- R6::R6Class( # nolint
         function(input, output, session) {
           logger::log_trace("FilterState$srv_active initializing, dataname: { private$dataname }")
           current_state <- reactive(private$state_list_get())
-          previous_state <- reactiveVal(character(0))
-          added_state_name <- reactiveVal(character(0))
+          previous_state <- reactiveVal(NULL) # FilterState list
+          added_states <- reactiveVal(NULL) # FilterState list
 
-          str_to_shiny_ns <- function(x) {
-            gsub("[^[:alnum:]]+", "_", x)
+          # gives a valid shiny ns based on a default slice id
+          fs_to_shiny_ns <- function(x) {
+            checkmate::assert_multi_class(x, c("FilterState", "FilterStateExpr"))
+            gsub("[^[:alnum:]]+", "_", get_default_slice_id(x$get_state()))
           }
 
           output$trigger_visible_state_change <- renderUI({
-            current_state <- current_state()
+            current_state()
             isolate({
               logger::log_trace("FilterStates$srv_active@1 determining added and removed filter states")
-              added_state_name(setdiff(names(current_state()), names(previous_state())))
+              # Be aware this returns a list because `current_state` is a list and not `teal_slices`.
+              added_states(setdiff_teal_slices(current_state(), previous_state()))
               previous_state(current_state())
               NULL
             })
           })
 
           output[["cards"]] <- shiny::renderUI({
-            fstates <- current_state() # rerenders when queue changes / not when the state changes
-            lapply(names(fstates), function(fname) {
-              shiny::isolate(
-                fstates[[fname]]$ui(id = session$ns(str_to_shiny_ns(fname)), parent_id = session$ns("cards"))
-              )
-            })
+            lapply(
+              current_state(), # observes only if added/removed
+              function(state) {
+                shiny::isolate( # isolates when existing state changes
+                  state$ui(id = session$ns(fs_to_shiny_ns(state)), parent_id = session$ns("cards"))
+                )
+              }
+            )
           })
 
           observeEvent(
-            added_state_name(), # we want to call FilterState module only once when it's added
+            added_states(), # we want to call FilterState module only once when it's added
             ignoreNULL = TRUE,
             {
-              logger::log_trace("FilterStates$srv_active@2 triggered by added states: { toString(added_state_name()) }")
-              fstates <- current_state()
-              lapply(added_state_name(), function(fname) {
-                fs_callback <- fstates[[fname]]$server(id = str_to_shiny_ns(fname))
+              added_state_names <- vapply(added_states(), function(x) x$get_state()$id, character(1L))
+              logger::log_trace("FilterStates$srv_active@2 triggered by added states: { toString(added_state_names) }")
+              lapply(added_states(), function(state) {
+                fs_callback <- state$server(id = fs_to_shiny_ns(state))
                 observeEvent(
                   eventExpr = fs_callback(), # when remove button is clicked in the FilterState ui
                   once = TRUE, # remove button can be called once, should be destroyed afterwards
-                  handlerExpr = private$state_list_remove(fname)
+                  handlerExpr = private$state_list_remove(state$get_state()$id)
                 )
               })
-              added_state_name(character(0))
+              added_states(NULL)
             }
           )
 
@@ -636,14 +636,21 @@ FilterStates <- R6::R6Class( # nolint
         logger::log_trace("{ class(self)[1] } removing a filter, state_id: { state_id }")
         checkmate::assert_character(state_id)
         new_state_list <- private$state_list()
-        if (is.element(state_id, names(new_state_list))) {
-          if (new_state_list[[state_id]]$get_state()$locked) {
-            return(invisible(NULL))
-          }
-          new_state_list[[state_id]]$destroy_observers()
-          new_state_list[[state_id]] <- NULL
+        current_state_ids <- vapply(private$state_list(), function(x) x$get_state()$id, character(1))
+        to_remove <- state_id %in% current_state_ids
+        if (any(to_remove)) {
+          new_state_list <- Filter(
+            function(state) {
+              if (state$get_state()$id %in% state_id && !state$get_state()$locked) {
+                state$destroy_observers()
+                FALSE
+              } else {
+                TRUE
+              }
+            },
+            private$state_list()
+          )
           private$state_list(new_state_list)
-          logger::log_trace("{ class(self)[1] } removed a filter, state_id: { state_id }")
         } else {
           warning(sprintf("\"%s\" not found in state list", state_id))
         }
@@ -661,13 +668,12 @@ FilterStates <- R6::R6Class( # nolint
         logger::log_trace(
           "{ class(self)[1] }$state_list_empty removing all non-locked filters for dataname: { private$dataname }"
         )
+
         state_list <- private$state_list()
-        for (state_id in names(state_list)) {
-          private$state_list_remove(state_id)
+        if (length(state_list)) {
+          state_list_ids <- vapply(state_list, function(x) x$get_state()$id, character(1))
+          private$state_list_remove(state_list_ids)
         }
-        logger::log_trace(
-          "{ class(self)[1] }$state_list_empty removed all non-locked filters for dataname: { private$dataname }"
-        )
         invisible(NULL)
       })
     },

R/FilteredData.R

@@ -475,14 +475,12 @@ FilteredData <- R6::R6Class( # nolint
         }
 
         checkmate::assert_class(state, "teal_slices")
-        datanames <- slices_field(state, "dataname")
-        checkmate::assert_subset(datanames, self$datanames())
         module_add <- attr(state, "module_add")
         if (!is.null(module_add)) {
           private$module_add <- module_add
         }
 
-        lapply(datanames, function(dataname) {
+        lapply(self$datanames(), function(dataname) {
           states <- Filter(function(x) identical(x$dataname, dataname), state)
           private$get_filtered_dataset(dataname)$set_filter_state(states)
         })
@@ -591,7 +589,10 @@ FilteredData <- R6::R6Class( # nolint
     #' @return invisible `NULL`
     set_available_teal_slices = function(x) {
       checkmate::assert_class(x, "reactive")
-      private$available_teal_slices <- x
+      private$available_teal_slices <- reactive({
+        # we want to limit the available filters to the ones that are relevant for this FilteredData
+        Filter(function(x) x$dataname %in% self$datanames(), x())
+      })
       invisible(NULL)
     },
 
@@ -1073,7 +1074,6 @@ FilteredData <- R6::R6Class( # nolint
     # appropriate filter (identified by it's id)
     srv_available_filters = function(id) {
       moduleServer(id, function(input, output, session) {
-        slices <- reactive(Filter(function(slice) !isTRUE(slice$locked), private$available_teal_slices()))
         slices_interactive <- reactive(
           Filter(
             function(slice) !isTRUE(slice$fixed) && !inherits(slice, "teal_slice_expr"),
@@ -1086,8 +1086,16 @@ FilteredData <- R6::R6Class( # nolint
             private$available_teal_slices()
           )
         )
-        available_slices_id <- reactive(vapply(slices(), `[[`, character(1), "id"))
+        available_slices_id <- reactive(vapply(private$available_teal_slices(), `[[`, character(1), "id"))
         active_slices_id <- reactive(vapply(self$get_filter_state(), `[[`, character(1), "id"))
+        duplicated_slice_references <- reactive({
+          # slice refers to a particular column
+          slice_reference <- vapply(private$available_teal_slices(), get_default_slice_id, character(1))
+          is_duplicated_reference <- duplicated(slice_reference) | duplicated(slice_reference, fromLast = TRUE)
+          is_active <- available_slices_id() %in% active_slices_id()
+          is_not_expr <- !vapply(private$available_teal_slices(), inherits, logical(1), "teal_slice_expr")
+          slice_reference[is_duplicated_reference & is_active & is_not_expr]
+        })
 
         checkbox_group_element <- function(name, value, label, checked, disabled = FALSE) {
           tags$div(
@@ -1113,45 +1121,36 @@ FilteredData <- R6::R6Class( # nolint
             selected = NULL
           )
           active_slices_ids <- active_slices_id()
+          duplicated_slice_refs <- duplicated_slice_references()
+
+          checkbox_group_slice <- function(slice) {
+            # we need to isolate changes in the fields of the slice (teal_slice)
+            shiny::isolate({
+              checkbox_group_element(
+                name = session$ns("available_slices_id"),
+                value = slice$id,
+                label = slice$id,
+                checked = if (slice$id %in% active_slices_ids) "checked",
+                disabled = slice$locked ||
+                  get_default_slice_id(slice) %in% duplicated_slice_refs &&
+                    !slice$id %in% active_slices_ids
+              )
+            })
+          }
 
-          shiny::isolate({
-            interactive_choice_mock <- lapply(
-              slices_interactive(),
-              function(slice) {
-                checkbox_group_element(
-                  name = session$ns("available_slices_id"),
-                  value = slice$id,
-                  label = slice$id,
-                  checked = if (slice$id %in% active_slices_ids) "checked",
-                  disabled = slice$locked
-                )
-              }
-            )
-
-            non_interactive_choice_mock <- lapply(
-              slices_fixed(),
-              function(slice) {
-                checkbox_group_element(
-                  name = session$ns("available_slices_id"),
-                  value = slice$id,
-                  label = slice$id,
-                  checked = if (slice$id %in% active_slices_ids) "checked",
-                  disabled = slice$locked
-                )
-              }
-            )
-
-            htmltools::tagInsertChildren(
-              checkbox,
-              br(),
-              tags$strong("Fixed filters"),
-              non_interactive_choice_mock,
-              tags$strong("Iteractive filters"),
-              interactive_choice_mock,
-              .cssSelector = "div.shiny-options-group",
-              after = 0
-            )
-          })
+          interactive_choice_mock <- lapply(slices_interactive(), checkbox_group_slice)
+          non_interactive_choice_mock <- lapply(slices_fixed(), checkbox_group_slice)
+
+          htmltools::tagInsertChildren(
+            checkbox,
+            br(),
+            tags$strong("Fixed filters"),
+            non_interactive_choice_mock,
+            tags$strong("Interactive filters"),
+            interactive_choice_mock,
+            .cssSelector = "div.shiny-options-group",
+            after = 0
+          )
         })
 
         observeEvent(input$available_slices_id, ignoreNULL = FALSE, ignoreInit = TRUE, {
@@ -1160,22 +1159,22 @@ FilteredData <- R6::R6Class( # nolint
           if (length(new_slices_id)) {
             new_teal_slices <- Filter(
               function(slice) slice$id %in% new_slices_id,
-              slices()
+              private$available_teal_slices()
             )
             self$set_filter_state(new_teal_slices)
           }
 
           if (length(removed_slices_id)) {
             removed_teal_slices <- Filter(
               function(slice) slice$id %in% removed_slices_id,
-              slices()
+              self$get_filter_state()
             )
             self$remove_filter_state(removed_teal_slices)
           }
         })
 
-        observeEvent(slices(), ignoreNULL = FALSE, {
-          if (length(slices())) {
+        observeEvent(private$available_teal_slices(), ignoreNULL = FALSE, {
+          if (length(private$available_teal_slices())) {
             shinyjs::show("available_menu")
           } else {
             shinyjs::hide("available_menu")

R/FilteredDatasetDefault.R

@@ -184,14 +184,10 @@ DefaultFilteredDataset <- R6::R6Class( # nolint
       shiny::isolate({
         logger::log_trace("{ class(self)[1] }$set_filter_state initializing, dataname: { private$dataname }")
         checkmate::assert_class(state, "teal_slices")
-        lapply(state, function(x) {
-          checkmate::assert_true(
-            shiny::isolate(x$dataname) == private$dataname,
-            .var.name = "dataname matches private$dataname"
-          )
-          private$get_filter_states()[[1L]]$set_filter_state(state = state)
-          logger::log_trace("{ class(self)[1] }$set_filter_state initialized, dataname: { private$dataname }")
+        lapply(state, function(slice) {
+          checkmate::assert_true(slice$dataname == private$dataname)
         })
+        private$get_filter_states()[[1L]]$set_filter_state(state = state)
         invisible(NULL)
       })
     },

R/teal_slice.R

@@ -150,10 +150,7 @@ teal_slice <- function(dataname,
     checkmate::assert_flag(keep_inf, null.ok = TRUE)
     checkmate::assert_flag(multiple)
     if (missing(id)) {
-      args$id <- paste(
-        Filter(length, args[c("dataname", "varname", "experiment", "arg")]),
-        collapse = " "
-      )
+      args$id <- get_default_slice_id(args)
     } else {
       checkmate::assert_string(id)
     }
@@ -318,3 +315,29 @@ trim_lines_json <- function(x) {
   substr(x_trim, trim_position - 2, trim_position) <- "..."
   x_trim
 }
+
+#' Default `teal_slice` id
+#'
+#' Function returns a default `id` for a `teal_slice` object which needs
+#' to be distinct from other `teal_slice` objects created for any
+#' `FilterStates` object. Returned `id` can be treated as a location of
+#' a vector on which `FilterState` is built:
+#' - for a `data.frame` `id` concatenates `dataname` and `varname`.
+#' - for a `MultiAssayExperiment` `id` concatenates `dataname`, `varname`,
+#' `experiment` and `arg`, so that one can add `teal_slice` for a `varname`
+#' which exists in multiple `SummarizedExperiment`s or exists in both `colData`
+#' and `rowData` of given experiment.
+#' @param x (`teal_slice` or `list`)
+#' @return (`character(1)`) `id` for a `teal_slice` object.
+#' @keywords internal
+get_default_slice_id <- function(x) {
+  shiny::isolate({
+    paste(
+      Filter(
+        length,
+        as.list(x)[c("dataname", "varname", "experiment", "arg")]
+      ),
+      collapse = " "
+    )
+  })
+}

R/teal_slices.R

@@ -211,9 +211,6 @@ as.teal_slices <- function(x) { # nolint
   y <- NextMethod("[")
   attrs <- attributes(x)
   attrs$names <- attrs$names[i]
-  datanames <- unique(unlist(vapply(y, function(ts) shiny::isolate(ts[["dataname"]]), character(1L))))
-  attrs[["exclude_varnames"]] <- Filter(Negate(is.null), attr(x, "exclude_varnames")[datanames])
-  attrs[["include_varnames"]] <- Filter(Negate(is.null), attr(x, "include_varnames")[datanames])
   attributes(y) <- attrs
   y
 }
@@ -303,3 +300,19 @@ slices_to_list <- function(tss) {
   tss_list <- list(slices = slices_list, attributes = attrs)
   Filter(Negate(is.null), tss_list) # drop attributes if empty
 }
+
+#' `setdiff` method for `teal_slices`
+#'
+#' Compare two teal slices objects and return `teal_slices` containing slices present in `x` but not in `y`.
+#' @param x,y `teal_slices` objects
+#' @return `teal_slices`
+#' @keywords internal
+#'
+setdiff_teal_slices <- function(x, y) {
+  Filter(
+    function(xx) {
+      !any(vapply(y, function(yy) identical(yy, xx), logical(1)))
+    },
+    x
+  )
+}