183 choicefs improve init (#194)

# Pull Request Fixes #[183](#183) --------- Signed-off-by: Marek Blazewicz <[email protected]> Co-authored-by: Mahmoud Hallal <[email protected]> Co-authored-by: Dawid Kałędkowski <[email protected]>
insightsengineering · Feb 15, 2023 · e9a9758 · e9a9758
1 parent 22a9dc4
commit e9a9758
Show file tree

Hide file tree

Showing 3 changed files with 102 additions and 50 deletions.
diff --git a/R/FilterState.R b/R/FilterState.R
@@ -308,12 +308,14 @@ FilterState <- R6::R6Class( # nolint
       value <- private$remove_out_of_bound_values(value)
       private$validate_selection(value)
       private$selected(value)
-      logger::log_trace(sprintf(
-        "%s$set_selected selection of variable %s set, dataname: %s",
-        class(self)[1],
-        private$varname,
-        private$dataname
-      ))
+      logger::log_trace(
+        sprintf(
+          "%s$set_selected selection of variable %s set, dataname: %s",
+          class(self)[1],
+          private$varname,
+          private$dataname
+        )
+      )
       invisible(NULL)
     },
 

diff --git a/R/FilterStateChoices.R b/R/FilterStateChoices.R
@@ -56,24 +56,18 @@ ChoicesFilterState <- R6::R6Class( # nolint
         length(unique(x[!is.na(x)])) < getOption("teal.threshold_slider_vs_checkboxgroup"),
         combine = "or"
       )
+      checkmate::assert_class(x_reactive, "reactive")
 
-      # validation on x_reactive here
       super$initialize(x, x_reactive, varname, varlabel, dataname, extract_type)
+
       if (!is.factor(x)) {
         x <- factor(x, levels = as.character(sort(unique(x))))
       }
-
       x <- droplevels(x)
-      tbl <- table(x)
-      choices <- names(tbl)
-      names(choices) <- tbl
-
-      private$set_choices(as.list(choices))
-      self$set_selected(unname(choices))
-      private$histogram_data <- data.frame(
-        x = levels(x),
-        y = tabulate(x)
-      )
+      choices <- table(x)
+      private$set_choices(names(choices))
+      self$set_selected(names(choices))
+      private$set_choices_counts(unname(choices))
 
       return(invisible(self))
     },
@@ -146,9 +140,19 @@ ChoicesFilterState <- R6::R6Class( # nolint
   # private members ----
 
   private = list(
-    histogram_data = data.frame(),
-
+    choices_counts = integer(0),
     # private methods ----
+    set_choices_counts = function(choices_counts) {
+      private$choices_counts <- choices_counts
+      invisible(NULL)
+    },
+    get_filtered_counts = function() {
+      if (!is.null(private$x_reactive)) {
+        table(factor(private$x_reactive(), levels = private$choices))
+      } else {
+        NULL
+      }
+    },
     validate_selection = function(value) {
       if (!is.character(value)) {
         stop(
@@ -191,49 +195,47 @@ ChoicesFilterState <- R6::R6Class( # nolint
     },
     get_choice_labels = function() {
       if (private$is_checkboxgroup()) {
-        l_counts <- as.numeric(names(private$choices))
-        is_na_l_counts <- is.na(l_counts)
-        if (any(is_na_l_counts)) l_counts[is_na_l_counts] <- 0
+        l_counts <- private$choices_counts
+        l_counts[is.na(l_counts)] <- 0
 
-        f_counts <- unname(table(factor(private$x_reactive(), levels = private$choices)))
+        f_counts <- private$get_filtered_counts()
         f_counts[is.na(f_counts)] <- 0
 
-        labels <- lapply(seq_along(private$choices), function(i) {
-          l_count <- l_counts[i]
-          f_count <- f_counts[i]
-          l_freq <- l_count / sum(l_counts)
-          f_freq <- f_count / sum(l_counts)
+        l_freqs <- l_counts / sum(l_counts)
+        f_freqs <- f_counts / sum(l_counts)
+
+        l_freqs[is.na(l_freqs) | is.nan(l_freqs)] <- 0
+        f_freqs[is.na(f_freqs) | is.nan(f_freqs)] <- 0
 
-          if (is.na(l_freq) || is.nan(l_freq)) l_freq <- 0
-          if (is.na(f_freq) || is.nan(f_freq)) f_freq <- 0
+        labels <- lapply(seq_along(private$choices), function(i) {
           tagList(
             div(
               class = "choices_state_label_unfiltered",
-              style = sprintf("width:%s%%", l_freq * 100)
+              style = sprintf("width:%s%%", l_freqs[i] * 100)
             ),
             if (!is.null(private$x_reactive())) {
               div(
                 class = "choices_state_label",
-                style = sprintf("width:%s%%", f_freq * 100)
+                style = sprintf("width:%s%%", f_freqs[i] * 100)
               )
             },
             div(
               class = "choices_state_label_text",
               sprintf(
                 "%s (%s%s)", private$choices[i],
-                if (is.null(private$x_reactive())) "" else sprintf("%s/", f_count),
-                l_count
+                if (is.null(private$x_reactive())) "" else sprintf("%s/", f_counts[i]),
+                l_counts[i]
               )
             )
           )
         })
       } else {
-        x <- if (is.null(private$x_reactive())) {
+        xslash <- if (is.null(private$x_reactive())) {
           ""
         } else {
-          sprintf("%s/", table(factor(private$x_reactive(), levels = private$choices)))
+          sprintf("%s/", private$get_filtered_counts())
         }
-        sprintf("%s (%s%s)", private$choices, x, names(private$choices))
+        sprintf("%s (%s%s)", private$choices, xslash, private$choices_counts)
       }
     },
 

diff --git a/tests/testthat/test-ChoicesFilterState.R b/tests/testthat/test-ChoicesFilterState.R
@@ -1,64 +1,71 @@
 testthat::test_that("The constructor accepts character or factor", {
-  testthat::expect_no_error(ChoicesFilterState$new("test", varname = "test"))
-  testthat::expect_no_error(ChoicesFilterState$new(as.factor("test"), varname = "test"))
+  testthat::expect_no_error(ChoicesFilterState$new("test", x_reactive = reactive(NULL), varname = "test"))
+  testthat::expect_no_error(ChoicesFilterState$new(as.factor("test"), reactive(NULL), varname = "test"))
 })
 
+testthat::test_that("The constructor accepts only reactive input for x_reactive", {
+  testthat::expect_no_error(ChoicesFilterState$new("test", x_reactive = reactive(NULL), varname = "test"))
+  testthat::expect_error(ChoicesFilterState$new("test", x_reactive = "test", varname = "test"))
+  testthat::expect_error(ChoicesFilterState$new(as.factor("test"), NULL, varname = "test"))
+})
+
+
 testthat::test_that("get_call returns a condition true for values passed in constructor", {
-  filter_state <- ChoicesFilterState$new("test", varname = "test")
+  filter_state <- ChoicesFilterState$new("test", x_reactive = reactive(NULL), varname = "test")
   test <- "test"
   testthat::expect_true(eval(shiny::isolate(filter_state$get_call())))
 
-  filter_state <- ChoicesFilterState$new(factor("test"), varname = "test")
+  filter_state <- ChoicesFilterState$new(factor("test"), x_reactive = reactive(NULL), varname = "test")
   test <- factor("test")
   testthat::expect_true(eval(shiny::isolate(filter_state$get_call())))
 })
 
 testthat::test_that("get_call returns a condition true for the values passed to set_selected", {
-  filter_state <- ChoicesFilterState$new(c(letters[1:7]), varname = "test")
+  filter_state <- ChoicesFilterState$new(c(letters[1:7]), x_reactive = reactive(NULL), varname = "test")
   filter_state$set_selected(letters[2:3])
   test <- letters[1:4]
   testthat::expect_equal(eval(shiny::isolate(filter_state$get_call())), c(FALSE, TRUE, TRUE, FALSE))
 })
 
 testthat::test_that("get_call returns a condition returning NA for NA values", {
-  filter_state <- ChoicesFilterState$new("test", varname = "test")
+  filter_state <- ChoicesFilterState$new("test", x_reactive = reactive(NULL), varname = "test")
   test <- NA
   testthat::expect_identical(eval(shiny::isolate(filter_state$get_call())), NA)
 })
 
 testthat::test_that("get_call returns a condition true for NA values", {
-  filter_state <- ChoicesFilterState$new("test", varname = "test")
+  filter_state <- ChoicesFilterState$new("test", x_reactive = reactive(NULL), varname = "test")
   filter_state$set_keep_na(TRUE)
   test <- NA
   testthat::expect_true(eval(shiny::isolate(filter_state$get_call())))
 })
 
 testthat::test_that("set_selected warns when selection not within allowed choices", {
-  filter_state <- ChoicesFilterState$new("test", varname = "test")
+  filter_state <- ChoicesFilterState$new("test", x_reactive = reactive(NULL), varname = "test")
   testthat::expect_warning(filter_state$set_selected(c("test", 7)), "not in choices")
 })
 
 testthat::test_that("set_selected sets the intersection of choices and the passed values", {
-  filter_state <- ChoicesFilterState$new(c("test1", "test2"), varname = "test")
+  filter_state <- ChoicesFilterState$new(c("test1", "test2"), x_reactive = reactive(NULL), varname = "test")
   suppressWarnings(filter_state$set_selected(c("test1", 7)))
   testthat::expect_equal(shiny::isolate(filter_state$get_selected()), "test1")
 })
 
 testthat::test_that("set_state needs a named list with selected and keep_na elements", {
-  filter_state <- ChoicesFilterState$new(x = c("a", "b", NA_character_), varname = "test")
+  filter_state <- ChoicesFilterState$new(x = c("a", "b", NA_character_), x_reactive = reactive(NULL), varname = "test")
   testthat::expect_no_error(filter_state$set_state(list(selected = "a", keep_na = TRUE)))
   testthat::expect_error(filter_state$set_state(list(selected = "a", unknown = TRUE)), "all\\(names\\(state\\)")
 })
 
 testthat::test_that("set_state sets values of selected and keep_na as provided in the list", {
-  filter_state <- ChoicesFilterState$new(x = c("a", "b", NA_character_), varname = "test")
+  filter_state <- ChoicesFilterState$new(x = c("a", "b", NA_character_), x_reactive = reactive(NULL), varname = "test")
   filter_state$set_state(list(selected = "a", keep_na = TRUE))
   testthat::expect_identical(shiny::isolate(filter_state$get_selected()), "a")
   testthat::expect_true(shiny::isolate(filter_state$get_keep_na()))
 })
 
 testthat::test_that("set_state overwrites fields included in the input only", {
-  filter_state <- ChoicesFilterState$new(x = c("a", "b", NA_character_), varname = "test")
+  filter_state <- ChoicesFilterState$new(x = c("a", "b", NA_character_), x_reactive = reactive(NULL), varname = "test")
   filter_state$set_state(list(selected = "a", keep_na = TRUE))
   testthat::expect_no_error(filter_state$set_state(list(selected = "b")))
   testthat::expect_identical(shiny::isolate(filter_state$get_selected()), "b")
@@ -70,6 +77,7 @@ testthat::test_that(
   code = {
     filter_state <- teal.slice:::ChoicesFilterState$new(
       c(LETTERS[1:2], NA),
+      x_reactive = reactive(NULL),
       varname = "x",
       dataname = "data",
       extract_type = character(0)
@@ -99,3 +107,43 @@ testthat::test_that(
     )
   }
 )
+
+testthat::test_that(
+  "ChoicesFilterState private methods return proper filtered counts and choice labels",
+  code = {
+    test <- R6::R6Class(
+      inherit = ChoicesFilterState,
+      public = list(
+        test_get_filter_counts = function() private$get_filtered_counts(),
+        test_get_choice_labels = function() private$get_choice_labels(),
+        test_choices_counts = function() private$choices_counts
+      )
+    )
+
+    x <- rep(c("A", "B", "C", "D", "E", "F"), times = 5)
+    xr <- c(rep(c("F", "A", "D"), times = 2), "D")
+
+    filter_state <- test$new(
+      x = x,
+      x_reactive = reactive(xr),
+      varname = "x",
+      dataname = "data",
+      extract_type = character(0)
+    )
+
+    testthat::expect_identical(
+      shiny::isolate(filter_state$test_get_filter_counts()),
+      table(factor(xr, levels = unique(x)))
+    )
+
+    testthat::expect_identical(
+      shiny::isolate(filter_state$test_get_choice_labels()),
+      c("A (2/5)", "B (0/5)", "C (0/5)", "D (3/5)", "E (0/5)", "F (2/5)")
+    )
+
+    testthat::expect_identical(
+      shiny::isolate(filter_state$test_choices_counts()),
+      unname(table(x))
+    )
+  }
+)