handle unused levels and "" choice (#587)

Fixes #586 1. As noted [here](#586 (comment)) having "" in the vector of names is problematic as `x[<choices>]` would return `NA` for this item. This is why I switched to `x[match(<choices>, names(x))]]` 2. `droplevels(x)` in the beginning of the constructor to not bother ChoicesFilterState with unused factor levels during a time when the class is working. It used to be this way so that zero-count-choices are never shown in the filter-state-card. --------- Co-authored-by: 27856297+dependabot-preview[bot]@users.noreply.github.com <27856297+dependabot-preview[bot]@users.noreply.github.com> Co-authored-by: vedhav <[email protected]>
insightsengineering · May 7, 2024 · 6d79ac6 · 6d79ac6
1 parent 4296c32
commit 6d79ac6
Show file tree

Hide file tree

Showing 6 changed files with 142 additions and 12 deletions.
diff --git a/NEWS.md b/NEWS.md
@@ -1,5 +1,8 @@
 # teal.slice 0.5.1.9000
 
+### Bug fixes
+* Fix error while creating the filter choices when the data has a factor with a level containing an empty string ("").
+
 # teal.slice 0.5.1
 
 ### Bug fixes

diff --git a/R/FilterStateChoices.R b/R/FilterStateChoices.R
@@ -155,6 +155,9 @@ ChoicesFilterState <- R6::R6Class( # nolint
           length(unique(x[!is.na(x)])) < getOption("teal.threshold_slider_vs_checkboxgroup"),
           combine = "or"
         )
+        if (is.factor(x)) {
+          x <- droplevels(x)
+        }
         super$initialize(
           x = x,
           x_reactive = x_reactive,
@@ -240,8 +243,8 @@ ChoicesFilterState <- R6::R6Class( # nolint
     # Checks validity of the choices, adjust if neccessary and sets the flag for the case where choices
     #  are limited by default from the start.
     set_choices = function(choices) {
-      ordered_counts <- .table(private$x)
-      possible_choices <- names(ordered_counts)
+      named_counts <- .table(private$x)
+      possible_choices <- names(named_counts)
       if (is.null(choices)) {
         choices <- possible_choices
       } else {
@@ -266,7 +269,9 @@ ChoicesFilterState <- R6::R6Class( # nolint
           choices <- possible_choices
         }
       }
-      private$set_choices_counts(unname(ordered_counts[choices]))
+      private$set_choices_counts(
+        pair_counts(choices, named_counts)
+      )
       private$set_is_choice_limited(possible_choices, choices)
       private$teal_slice$choices <- choices
       invisible(NULL)
@@ -331,12 +336,13 @@ ChoicesFilterState <- R6::R6Class( # nolint
     ui_inputs = function(id) {
       ns <- NS(id)
 
-      # we need to isolate UI to not rettrigger renderUI
+      # we need to isolate UI to not retrigger renderUI
       isolate({
         countsmax <- private$choices_counts
         countsnow <- if (!is.null(private$x_reactive())) {
-          unname(
-            .table(private$x_reactive())[private$get_choices()]
+          pair_counts(
+            private$get_choices(),
+            .table(private$x_reactive())
           )
         }
 
@@ -415,8 +421,9 @@ ChoicesFilterState <- R6::R6Class( # nolint
             logger::log_trace("ChoicesFilterState$server_inputs@1 updating count labels, id: { private$get_id() }")
 
             countsnow <- if (!is.null(private$x_reactive())) {
-              unname(
-                .table(non_missing_values())[private$get_choices()]
+              pair_counts(
+                private$get_choices(),
+                .table(non_missing_values())
               )
             }
 
@@ -542,8 +549,9 @@ ChoicesFilterState <- R6::R6Class( # nolint
 
           output$selection <- renderUI({
             countsnow <- if (!is.null(private$x_reactive())) {
-              unname(
-                .table(private$x_reactive())[private$get_choices()]
+              pair_counts(
+                private$get_choices(),
+                .table(private$x_reactive())
               )
             }
             countsmax <- private$choices_counts
@@ -602,11 +610,17 @@ ChoicesFilterState <- R6::R6Class( # nolint
 #'
 #' @keywords internal
 .table <- function(x) {
-  table(
+  tbl <- table(
     if (is.factor(x)) {
       x
     } else {
       as.character(x)
     }
   )
+  # tbl returns an array with dimnames instead of a simple vector
+  # we need to convert it to a vector so the object is simpler to handle
+  stats::setNames(
+    as.vector(tbl),
+    names(tbl)
+  )
 }
diff --git a/R/count_labels.R b/R/count_labels.R
@@ -230,3 +230,17 @@ make_count_text <- function(label, countmax, countnow = NULL) {
     countmax
   )
 }
+
+
+#' Adjust counts to match choices
+#'
+#' @param choices (`character`) Choices to match.
+#' @param counts (`named numeric`) Counts to adjust.
+#' @keywords internal
+pair_counts <- function(choices, counts) {
+  checkmate::assert_numeric(counts)
+  counts <- counts[match(choices, names(counts))]
+  counts[is.na(counts)] <- 0
+  names(counts) <- choices
+  counts
+}
diff --git a/man/pair_counts.Rd b/man/pair_counts.Rd
diff --git a/tests/testthat/test-ChoicesFilterState.R b/tests/testthat/test-ChoicesFilterState.R
@@ -70,6 +70,88 @@ testthat::test_that("constructor forces single selected when multiple is FALSE",
   )
 })
 
+testthat::test_that("constructor drops zero-count choices", {
+  test <- R6::R6Class("testChoicesFilterState", inherit = ChoicesFilterState, public = list(
+    get_choices_counts = function() {
+      private$choices_counts
+    }
+  ))
+  state <- test$new(
+    x = factor(
+      c("a", "b", "c", "c", "a", NA),
+      levels = c("a", "b", "c", "d", "") # "" instead of "e" to handle edge case with empty name
+    ),
+    slice = teal_slice(dataname = "data", varname = "var")
+  )
+
+  testthat::expect_identical(
+    shiny::isolate(state$get_state()$choices),
+    c("a", "b", "c")
+  )
+
+  testthat::expect_equal(
+    shiny::isolate(state$get_choices_counts()),
+    stats::setNames(
+      c(2L, 1L, 2L),
+      c("a", "b", "c")
+    )
+  )
+})
+
+testthat::test_that("constructor doesn't drop '' choice and includes it in a counts", {
+  test <- R6::R6Class("testChoicesFilterState", inherit = ChoicesFilterState, public = list(
+    get_choices_counts = function() {
+      private$choices_counts
+    }
+  ))
+  state <- test$new(
+    x = factor(
+      c("a", "b", "c", "c", "a", ""),
+      levels = c("a", "b", "c", "d", "")
+    ),
+    slice = teal_slice(dataname = "data", varname = "var")
+  )
+
+  testthat::expect_identical(
+    shiny::isolate(state$get_state()$choices),
+    c("a", "b", "c", "")
+  )
+
+  testthat::expect_equal(
+    shiny::isolate(state$get_choices_counts()),
+    stats::setNames(
+      c(2L, 1L, 2L, 1L),
+      c("a", "b", "c", "")
+    )
+  )
+})
+
+
+testthat::test_that("ui_input with filtered x_reactive outputs filtered counts", {
+  test <- R6::R6Class("testChoicesFilterState", inherit = ChoicesFilterState, public = list(
+    ui_inputs = function() {
+      private$ui_inputs("test")
+    }
+  ))
+
+  state <- test$new(
+    x = c("a", "b", "c", "c", "a", ""),
+    x_reactive = shiny::reactive(c("b", "a")),
+    slice = teal_slice(dataname = "data", varname = "var")
+  )
+
+  xx <- state$ui_inputs()
+  testthat::expect_identical(
+    gsub(
+      "^.+(\\(.+\\)).+(\\(.+\\)).+(\\(.+\\)).+$",
+      "\\1 \\2 \\3",
+      as.character(state$ui_inputs())
+    ),
+    "(1/2) (1/1) (0/2)"
+  )
+})
+
+
 # get_call ----
 testthat::test_that("method get_call of default ChoicesFilterState object returns NULL", {
   filter_state <- ChoicesFilterState$new(letters, slice = teal_slice(dataname = "data", varname = "var"))

diff --git a/tests/testthat/test-FilteredData.R b/tests/testthat/test-FilteredData.R
@@ -99,7 +99,7 @@ testthat::test_that("get_join_keys returns empty join_keys object", {
 testthat::test_that("get_keys returns keys of the dataset specified via join_keys", {
   jk <- teal.data::join_keys(teal.data::join_key("iris", "iris", "test"))
   filtered_data <- FilteredData$new(list(iris = head(iris)), join_keys = jk)
-  testthat::expect_identical(filtered_data$get_keys("iris"), setNames("test", "test"))
+  testthat::expect_identical(filtered_data$get_keys("iris"), stats::setNames("test", "test"))
 })
 
 testthat::test_that("get_join_keys returns join_keys object if it exists", {