diff --git a/R/FilterStateChoices.R b/R/FilterStateChoices.R index 450414fb5..ab710e413 100644 --- a/R/FilterStateChoices.R +++ b/R/FilterStateChoices.R @@ -1,5 +1,27 @@ # ChoicesFilterState ------ +#' Drop unused factor levels while preserving label attribute +#' +#' @description +#' Helper function to drop unused levels from a factor variable while preserving +#' the `label` attribute. The base R `droplevels()` function strips all attributes +#' except `levels` and `class`, which causes the loss of variable labels that are +#' commonly used in clinical trial datasets. +#' +#' @param x (`factor`) A factor variable, potentially with a `label` attribute. +#' +#' @return The input factor with unused levels dropped and the `label` attribute preserved. +#' +#' @keywords internal +.drop_levels_keep_label <- function(x) { + label_attr <- attr(x, "label", exact = TRUE) + x <- droplevels(x) + if (!is.null(label_attr)) { + attr(x, "label") <- label_attr + } + x +} + #' @name ChoicesFilterState #' @docType class #' @@ -158,7 +180,7 @@ ChoicesFilterState <- R6::R6Class( # nolint combine = "or" ) if (is.factor(x)) { - x <- droplevels(x) + x <- .drop_levels_keep_label(x) } super$initialize( x = x, diff --git a/man/dot-drop_levels_keep_label.Rd b/man/dot-drop_levels_keep_label.Rd new file mode 100644 index 000000000..80cbc55f2 --- /dev/null +++ b/man/dot-drop_levels_keep_label.Rd @@ -0,0 +1,21 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/FilterStateChoices.R +\name{.drop_levels_keep_label} +\alias{.drop_levels_keep_label} +\title{Drop unused factor levels while preserving label attribute} +\usage{ +.drop_levels_keep_label(x) +} +\arguments{ +\item{x}{(\code{factor}) A factor variable, potentially with a \code{label} attribute.} +} +\value{ +The input factor with unused levels dropped and the \code{label} attribute preserved. +} +\description{ +Helper function to drop unused levels from a factor variable while preserving +the \code{label} attribute. The base R \code{droplevels()} function strips all attributes +except \code{levels} and \code{class}, which causes the loss of variable labels that are +commonly used in clinical trial datasets. +} +\keyword{internal} diff --git a/tests/testthat/test-ChoicesFilterState.R b/tests/testthat/test-ChoicesFilterState.R index 119231a82..65310416a 100644 --- a/tests/testthat/test-ChoicesFilterState.R +++ b/tests/testthat/test-ChoicesFilterState.R @@ -706,3 +706,91 @@ testthat::test_that("get_call works for various combinations", { quote(!x %in% c("a", "b", "c", "d", "e", "f", "g", "h")) ) }) + +testthat::test_that("Factor with label attribute displays label in UI", { + factor_with_label <- factor(c("a", "b", "c", "a", "b")) + varlabel <- "Category Label" + varname <- "category" + attr(factor_with_label, "label") <- varlabel + filter_state <- init_filter_state( + factor_with_label, + slice = teal_slice( + dataname = "data", + varname = varname + ) + ) + ui_character <- as.character(filter_state$ui(id = "test")) + + testthat::expect_true(grepl(varlabel, ui_character)) +}) + +testthat::test_that("Factor without label attribute has empty varlabel in UI", { + factor_without_label <- factor(c("a", "b", "c", "a", "b")) + varlabel <- "Category Label" + varname <- "category" + filter_state <- init_filter_state( + factor_without_label, + slice = teal_slice( + dataname = "data", + varname = varname + ) + ) + ui_character <- as.character(filter_state$ui(id = "test")) + + testthat::expect_true(grepl("teal-slice filter-card-varlabel", ui_character)) # class is here + testthat::expect_false(grepl(varlabel, ui_character)) # with empty varlabel +}) + +testthat::test_that("Character variable with label attribute displays label in UI", { + char_with_label <- c("a", "b", "c", "a", "b") + varlabel <- "Character Label" + varname <- "my_character" + attr(char_with_label, "label") <- varlabel + + filter_state <- init_filter_state( + char_with_label, + slice = teal_slice( + dataname = "data", + varname = varname + ) + ) + ui_character <- as.character(filter_state$ui(id = "test")) + + testthat::expect_true(grepl(varlabel, ui_character)) +}) + +testthat::test_that("Factor with same label as varname has empty varlabel in UI", { + factor_same_label <- factor(c("a", "b", "c", "a", "b")) + varname <- "category" + varlabel <- varname + attr(factor_same_label, "label") <- varlabel + filter_state <- init_filter_state( + factor_same_label, + slice = teal_slice( + dataname = "data", + varname = varname + ) + ) + ui_character <- as.character(filter_state$ui(id = "test")) + + # class with empty varlabel + testthat::expect_true(grepl('class="teal-slice filter-card-varlabel">', ui_character)) +}) + +testthat::test_that("Numeric variable with label attribute displays label in UI", { + numeric_with_label <- c(1, 2, 3, 2, 1) + varlabel <- "Numeric Label" + varname <- "my_number" + attr(numeric_with_label, "label") <- varlabel + + filter_state <- init_filter_state( + numeric_with_label, + slice = teal_slice( + dataname = "data", + varname = varname + ) + ) + ui_character <- as.character(filter_state$ui(id = "test")) + + testthat::expect_true(grepl(varlabel, ui_character)) +})