From a561711e1b397f3676f52261f3c6c47f235c712c Mon Sep 17 00:00:00 2001 From: osenan Date: Mon, 23 Feb 2026 12:18:15 +0100 Subject: [PATCH 1/9] fix: keep label before we droplevels and remove label in factor --- R/FilterStateChoices.R | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/R/FilterStateChoices.R b/R/FilterStateChoices.R index 450414fb5..5a6bae12a 100644 --- a/R/FilterStateChoices.R +++ b/R/FilterStateChoices.R @@ -158,7 +158,12 @@ ChoicesFilterState <- R6::R6Class( # nolint combine = "or" ) if (is.factor(x)) { + # Preserve label attribute before droplevels (which strips all attributes except levels and class) + label_attr <- attr(x, "label", exact = TRUE) x <- droplevels(x) + if (!is.null(label_attr)) { + attr(x, "label") <- label_attr + } } super$initialize( x = x, From 4be320875af5fc2ac17284ea001503a378be5f00 Mon Sep 17 00:00:00 2001 From: osenan Date: Mon, 23 Feb 2026 12:18:59 +0100 Subject: [PATCH 2/9] tests: add test to verify varlabel is kept or is missing depending on column label attribute --- tests/testthat/test-ChoicesFilterState.R | 84 ++++++++++++++++++++++++ 1 file changed, 84 insertions(+) diff --git a/tests/testthat/test-ChoicesFilterState.R b/tests/testthat/test-ChoicesFilterState.R index 119231a82..bf97f0292 100644 --- a/tests/testthat/test-ChoicesFilterState.R +++ b/tests/testthat/test-ChoicesFilterState.R @@ -706,3 +706,87 @@ testthat::test_that("get_call works for various combinations", { quote(!x %in% c("a", "b", "c", "d", "e", "f", "g", "h")) ) }) + +# Helper function to check label in UI +check_label_in_ui <- function(x, varname, expected_label = NULL, label_should_appear = TRUE) { + filter_state <- init_filter_state( + x = x, + slice = teal_slice(dataname = "data", varname = varname) + ) + + ui_output <- as.character(filter_state$ui(id = "test")) + + if (label_should_appear && !is.null(expected_label)) { + testthat::expect_true( + grepl(expected_label, ui_output), + info = sprintf("Expected label '%s' to appear in UI", expected_label) + ) + testthat::expect_true( + grepl('class="teal-slice filter-card-varlabel"', ui_output), + info = "UI should contain varlabel div" + ) + } else { + # The varlabel div exists but should be empty + testthat::expect_true( + grepl('class="teal-slice filter-card-varlabel">', ui_output), + info = "Varlabel div should be empty" + ) + } +} + +testthat::test_that("Factor with label attribute displays label in UI", { + factor_with_label <- factor(c("a", "b", "c", "a", "b")) + attr(factor_with_label, "label") <- "Category Label" + + check_label_in_ui( + x = factor_with_label, + varname = "category", + expected_label = "Category Label", + label_should_appear = TRUE + ) +}) + +testthat::test_that("Factor without label attribute has empty varlabel in UI", { + factor_without_label <- factor(c("a", "b", "c", "a", "b")) + + check_label_in_ui( + x = factor_without_label, + varname = "category", + label_should_appear = FALSE + ) +}) + +testthat::test_that("Character variable with label attribute displays label in UI", { + char_with_label <- c("a", "b", "c", "a", "b") + attr(char_with_label, "label") <- "Character Label" + + check_label_in_ui( + x = char_with_label, + varname = "char_var", + expected_label = "Character Label", + label_should_appear = TRUE + ) +}) + +testthat::test_that("Factor with label same as varname has empty varlabel in UI", { + factor_same_label <- factor(c("a", "b", "c", "a", "b")) + attr(factor_same_label, "label") <- "category" + + check_label_in_ui( + x = factor_same_label, + varname = "category", + label_should_appear = FALSE + ) +}) + +testthat::test_that("Numeric variable with label attribute displays label in UI", { + numeric_with_label <- c(1, 2, 3, 2, 1) + attr(numeric_with_label, "label") <- "Numeric Label" + + check_label_in_ui( + x = numeric_with_label, + varname = "numeric_var", + expected_label = "Numeric Label", + label_should_appear = TRUE + ) +}) From 556eb87c1f98838215af8559ea1d17cdf49b4795 Mon Sep 17 00:00:00 2001 From: osenan Date: Mon, 23 Feb 2026 12:22:39 +0100 Subject: [PATCH 3/9] chore: check verifyied signature From 75b7d7f6bc881cf92c59e28194376dc1e8c47a3e Mon Sep 17 00:00:00 2001 From: osenan Date: Mon, 23 Feb 2026 12:23:54 +0100 Subject: [PATCH 4/9] chore: update email From 446930072d3a0831032caec0950bd4876b1d3f77 Mon Sep 17 00:00:00 2001 From: osenan Date: Mon, 23 Feb 2026 12:27:53 +0100 Subject: [PATCH 5/9] chore: remove comment --- R/FilterStateChoices.R | 1 - 1 file changed, 1 deletion(-) diff --git a/R/FilterStateChoices.R b/R/FilterStateChoices.R index 5a6bae12a..9e35b5cd6 100644 --- a/R/FilterStateChoices.R +++ b/R/FilterStateChoices.R @@ -158,7 +158,6 @@ ChoicesFilterState <- R6::R6Class( # nolint combine = "or" ) if (is.factor(x)) { - # Preserve label attribute before droplevels (which strips all attributes except levels and class) label_attr <- attr(x, "label", exact = TRUE) x <- droplevels(x) if (!is.null(label_attr)) { From 39d01ff89e5d633920321bb4bd1cb166d947fdc3 Mon Sep 17 00:00:00 2001 From: osenan Date: Mon, 23 Feb 2026 14:14:10 +0100 Subject: [PATCH 6/9] refactor: use method for better maintainability --- R/FilterStateChoices.R | 28 +++++++++++++++++++++++----- 1 file changed, 23 insertions(+), 5 deletions(-) diff --git a/R/FilterStateChoices.R b/R/FilterStateChoices.R index 9e35b5cd6..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,11 +180,7 @@ ChoicesFilterState <- R6::R6Class( # nolint combine = "or" ) if (is.factor(x)) { - label_attr <- attr(x, "label", exact = TRUE) - x <- droplevels(x) - if (!is.null(label_attr)) { - attr(x, "label") <- label_attr - } + x <- .drop_levels_keep_label(x) } super$initialize( x = x, From bbae528ec3160c5be050a206ce60b8657663068b Mon Sep 17 00:00:00 2001 From: github-actions <41898282+github-actions[bot]@users.noreply.github.com> Date: Mon, 23 Feb 2026 13:23:07 +0000 Subject: [PATCH 7/9] [skip roxygen] [skip vbump] Roxygen Man Pages Auto Update --- man/dot-drop_levels_keep_label.Rd | 21 +++++++++++++++++++++ 1 file changed, 21 insertions(+) create mode 100644 man/dot-drop_levels_keep_label.Rd 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} From cb6c6a9ee436af0a5451dd797441676c0a81e5e0 Mon Sep 17 00:00:00 2001 From: osenan Date: Tue, 24 Feb 2026 07:47:33 +0100 Subject: [PATCH 8/9] refactor: modify tests so they do not use wrapper functions --- tests/testthat/test-ChoicesFilterState.R | 93 ++++++++++++++++-------- 1 file changed, 62 insertions(+), 31 deletions(-) diff --git a/tests/testthat/test-ChoicesFilterState.R b/tests/testthat/test-ChoicesFilterState.R index bf97f0292..e48d4c1fc 100644 --- a/tests/testthat/test-ChoicesFilterState.R +++ b/tests/testthat/test-ChoicesFilterState.R @@ -736,57 +736,88 @@ check_label_in_ui <- function(x, varname, expected_label = NULL, label_should_ap testthat::test_that("Factor with label attribute displays label in UI", { factor_with_label <- factor(c("a", "b", "c", "a", "b")) - attr(factor_with_label, "label") <- "Category Label" - - check_label_in_ui( - x = factor_with_label, - varname = "category", - expected_label = "Category Label", - label_should_appear = TRUE + 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")) - - check_label_in_ui( - x = factor_without_label, - varname = "category", - label_should_appear = FALSE + 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") - attr(char_with_label, "label") <- "Character Label" + varlabel <- "Character Label" + varname <- "my_character" + attr(char_with_label, "label") <- varlabel - check_label_in_ui( - x = char_with_label, - varname = "char_var", - expected_label = "Character Label", - label_should_appear = TRUE + 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 label same as varname has empty varlabel in UI", { +testthat::test_that("Factor with same label as varname has empty varlabel in UI", { factor_same_label <- factor(c("a", "b", "c", "a", "b")) - attr(factor_same_label, "label") <- "category" - - check_label_in_ui( - x = factor_same_label, - varname = "category", - label_should_appear = FALSE + 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) - attr(numeric_with_label, "label") <- "Numeric Label" + varlabel <- "Numeric Label" + varname <- "my_number" + attr(numeric_with_label, "label") <- varlabel - check_label_in_ui( - x = numeric_with_label, - varname = "numeric_var", - expected_label = "Numeric Label", - label_should_appear = TRUE + 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)) }) From 1ef290d0848b7fe38d59718ce702a156bc5230a9 Mon Sep 17 00:00:00 2001 From: osenan Date: Tue, 24 Feb 2026 15:30:21 +0100 Subject: [PATCH 9/9] fix: remove unused function --- tests/testthat/test-ChoicesFilterState.R | 27 ------------------------ 1 file changed, 27 deletions(-) diff --git a/tests/testthat/test-ChoicesFilterState.R b/tests/testthat/test-ChoicesFilterState.R index e48d4c1fc..65310416a 100644 --- a/tests/testthat/test-ChoicesFilterState.R +++ b/tests/testthat/test-ChoicesFilterState.R @@ -707,33 +707,6 @@ testthat::test_that("get_call works for various combinations", { ) }) -# Helper function to check label in UI -check_label_in_ui <- function(x, varname, expected_label = NULL, label_should_appear = TRUE) { - filter_state <- init_filter_state( - x = x, - slice = teal_slice(dataname = "data", varname = varname) - ) - - ui_output <- as.character(filter_state$ui(id = "test")) - - if (label_should_appear && !is.null(expected_label)) { - testthat::expect_true( - grepl(expected_label, ui_output), - info = sprintf("Expected label '%s' to appear in UI", expected_label) - ) - testthat::expect_true( - grepl('class="teal-slice filter-card-varlabel"', ui_output), - info = "UI should contain varlabel div" - ) - } else { - # The varlabel div exists but should be empty - testthat::expect_true( - grepl('class="teal-slice filter-card-varlabel">', ui_output), - info = "Varlabel div should be empty" - ) - } -} - testthat::test_that("Factor with label attribute displays label in UI", { factor_with_label <- factor(c("a", "b", "c", "a", "b")) varlabel <- "Category Label"