From e9a9758fa8b576fdb0e6270053e7c53a269c1233 Mon Sep 17 00:00:00 2001 From: Marek Blazewicz <110387997+BLAZEWIM@users.noreply.github.com> Date: Wed, 15 Feb 2023 15:04:04 +0100 Subject: [PATCH] 183 choicefs improve init (#194) MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit # Pull Request Fixes #[183](https://github.com/insightsengineering/teal.slice/issues/183) --------- Signed-off-by: Marek Blazewicz <110387997+BLAZEWIM@users.noreply.github.com> Co-authored-by: Mahmoud Hallal <86970066+mhallal1@users.noreply.github.com> Co-authored-by: Dawid Kałędkowski <6959016+gogonzo@users.noreply.github.com> --- R/FilterState.R | 14 +++-- R/FilterStateChoices.R | 66 +++++++++++----------- tests/testthat/test-ChoicesFilterState.R | 72 ++++++++++++++++++++---- 3 files changed, 102 insertions(+), 50 deletions(-) diff --git a/R/FilterState.R b/R/FilterState.R index 079800838..be68a26be 100644 --- 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 index 80e5cffb6..1875a77f3 100644 --- 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 index c4bd6ba97..d84eac095 100644 --- 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)) + ) + } +)