fix: keeps labels modifying factors and creates new factors correctly

CITATION.cff

@@ -8,7 +8,7 @@ message: 'To cite package "FreesearchR" in publications use:'
 type: software
 license: AGPL-3.0-or-later
 title: 'FreesearchR: Easy data analysis for clinicians'
-version: 26.3.1
+version: 26.3.2
 doi: 10.5281/zenodo.14527429
 identifiers:
 - type: url

DESCRIPTION

@@ -1,6 +1,6 @@
 Package: FreesearchR
 Title: Easy data analysis for clinicians
-Version: 26.3.1
+Version: 26.3.2
 Authors@R: c(
     person("Andreas Gammelgaard", "Damsbo",email="agdamsbo@clin.au.dk", role = c("aut", "cre"),
            comment = c(ORCID = "0000-0002-7559-1154")),
@@ -139,6 +139,7 @@ Collate:
     'ui_elements.R'
     'update-factor-ext.R'
     'update-variables-ext.R'
+    'utils-labels.R'
     'validation.R'
     'visual_summary.R'
     'wide2long.R'

NAMESPACE

@@ -14,6 +14,7 @@ export(all_but)
 export(allowed_operations)
 export(append_column)
 export(append_list)
+export(apply_labels)
 export(argsstring2list)
 export(baseline_table)
 export(class_icons)
@@ -53,6 +54,7 @@ export(default_parsing)
 export(detect_delimiter)
 export(drop_empty_event)
 export(expression_string)
+export(extract_labels)
 export(factor_new_levels_labels)
 export(factorize)
 export(file_export)
@@ -85,6 +87,7 @@ export(is_identical_to_previous)
 export(is_splittable)
 export(is_valid_redcap_url)
 export(is_valid_token)
+export(label_report)
 export(launch_FreesearchR)
 export(limit_data_size)
 export(limit_log)
@@ -134,6 +137,7 @@ export(remove_empty_attr)
 export(remove_empty_cols)
 export(remove_nested_list)
 export(repeated_instruments)
+export(restore_labels)
 export(sankey_ready)
 export(selectInputIcon)
 export(separate_string)
@@ -167,6 +171,7 @@ export(visual_summary_ui)
 export(wide2long)
 export(winbox_create_column)
 export(winbox_update_factor)
+export(with_labels)
 export(wrap_plot_list)
 export(write_quarto)
 importFrom(classInt,classIntervals)

NEWS.md

@@ -1,3 +1,11 @@
+# FreesearchR 26.3.2
+
+*FIX* Updating factor levels always created new factor.
+
+*FIX* Label stripping behavior updating factors is fixed.
+
+*NEW* New with_labels() function (and helpers) added to allow easy preservation of labels.
+
 # FreesearchR 26.3.1
 
 *FIX* ~~Include font files for static loading without dependency on Google.~~ Kept webfonts from google as local fonts are not working for now.

R/app_version.R

@@ -1 +1 @@
-app_version <- function()'26.3.1'
+app_version <- function()'26.3.2'

R/hosted_version.R

@@ -1 +1 @@
-hosted_version <- function()'v26.3.1-260302'
+hosted_version <- function()'v26.3.2-260311'

R/missings-module.R

@@ -351,29 +351,17 @@ compare_missings <- function(data,
 #' ##   missings_logic_across() |>
 #' ##   gtsummary::tbl_summary()
 missings_logic_across <- function(data, exclude = NULL) {
-  # This function includes a approach way to preserve variable labels
+  # This function includes a way to preserve variable labels
+  with_labels(data,{
   names(data) |>
     lapply(\(.x) {
-      # browser()
-      # Saving original labels
-      lab <- REDCapCAST::get_attr(data[[.x]], attr = "label")
       if (!.x %in% exclude) {
-        out <- is.na(data[[.x]])
+        is.na(data[[.x]])
       } else {
-        out <- data[[.x]]
+        data[[.x]]
-      }
-      if (!is.na(lab)) {
-        # Restoring original labels, if not NA
-        REDCapCAST::set_attr(
-          data = out,
-          label = lab,
-          attr = "label",
-          overwrite = TRUE
-        )
-      } else {
-        out
       }
     }) |>
     dplyr::bind_cols(.name_repair = "unique_quiet") |>
     setNames(names(data))
+  })
 }

R/update-factor-ext.R

@@ -70,7 +70,7 @@ update_factor_ui <- function(id) {
       class = "float-end",
       shinyWidgets::prettyCheckbox(
         inputId = ns("new_var"),
-        label = i18n$t("Create a new variable (otherwise replaces the one selected)"),
+        label = i18n$t("Create a new variable; otherwise replaces (Updating labels always creates new variable)"),
         value = FALSE,
         status = "primary",
         outline = TRUE,
@@ -201,15 +201,18 @@ update_factor_server <- function(id, data_r = reactive(NULL)) {
       parameters <- list(
         variable = variable,
         new_variable = isTRUE(input$new_var) |
-          any(grid[["Var1_toset"]] == "New label"),
+          any(grid[["Var1_toset"]] != "New label"),
         new_levels = as.character(grid[["Var1"]]),
         new_labels = as.character(grid[["Var1_toset"]]),
         ignore = "New label"
       )
 
       data <- tryCatch({
+        with_labels(data,{
           rlang::exec(factor_new_levels_labels,
                       !!!modifyList(parameters, val = list(data = data)))
+        })
+
       }, error = function(err) {
         showNotification(paste(
           "We encountered the following error creating the new factor:",

R/utils-labels.R

@@ -0,0 +1,114 @@
+# =============================================================================
+# Column Label Utilities
+#
+# Coded with help from Claude to save time.
+# Could be seperated for its own package.
+# =============================================================================
+
+#' Extract column labels from a data frame
+#'
+#' @param df A data frame.
+#' @return A named character vector of label strings (only labelled columns included).
+#' @export
+extract_labels <- function(df) {
+  if (!is.data.frame(df)) stop("`df` must be a data frame.", call. = FALSE)
+
+  labels <- vapply(df, function(col) {
+    lbl <- attr(col, "label")
+    if (is.null(lbl)) NA_character_ else as.character(lbl)
+  }, FUN.VALUE = character(1))
+
+  labels[!is.na(labels)]
+}
+
+
+#' Apply a named label vector to a data frame
+#'
+#' @param df A data frame.
+#' @param labels A named character vector (names = column names, values = labels).
+#'   Typically the output of [extract_labels()]. Labels for absent columns are
+#'   silently ignored.
+#' @return `df` with `"label"` attributes set on matching columns.
+#' @export
+apply_labels <- function(df, labels) {
+  if (!is.data.frame(df)) stop("`df` must be a data frame.", call. = FALSE)
+  if (!is.character(labels) || is.null(names(labels))) {
+    stop("`labels` must be a named character vector.", call. = FALSE)
+  }
+
+  for (col in intersect(names(labels), names(df))) {
+    attr(df[[col]], "label") <- labels[[col]]
+  }
+
+  df
+}
+
+
+#' Restore column labels using a reference data frame
+#'
+#' Convenience wrapper around [extract_labels()] + [apply_labels()]. Labels are
+#' matched by column name; new columns in `df_modified` are left unchanged.
+#'
+#' @param df_modified A data frame whose columns should receive labels.
+#' @param df_reference A data frame carrying the authoritative `"label"` attributes.
+#' @return `df_modified` with labels restored on all columns present in `df_reference`.
+#' @export
+restore_labels <- function(df_modified, df_reference) {
+  if (!is.data.frame(df_modified))  stop("`df_modified` must be a data frame.",  call. = FALSE)
+  if (!is.data.frame(df_reference)) stop("`df_reference` must be a data frame.", call. = FALSE)
+
+  apply_labels(df_modified, extract_labels(df_reference))
+}
+
+
+#' Evaluate an expression while preserving column labels
+#'
+#' Snapshots labels from `df` before evaluating `expr`, then reapplies them to
+#' matching columns in the result. New columns created inside `expr` receive no
+#' label automatically.
+#'
+#' @param df A data frame carrying `"label"` attributes.
+#' @param expr An unquoted expression that transforms `df` and returns a data frame.
+#' @return The data frame produced by `expr`, with original labels restored.
+#' @export
+with_labels <- function(df, expr) {
+  if (!is.data.frame(df)) stop("`df` must be a data frame.", call. = FALSE)
+
+  labels <- extract_labels(df)
+  result <- eval(substitute(expr), parent.frame())
+
+  if (!is.data.frame(result)) {
+    stop("The expression passed to `with_labels()` must return a data frame.", call. = FALSE)
+  }
+
+  apply_labels(result, labels)
+}
+
+
+#' Print a tidy summary of column labels
+#'
+#' @param df A data frame.
+#' @param missing_marker String used when a column has no label. Default: `"(no label)"`.
+#' @return A `column / class / label` data frame, printed and returned invisibly.
+#' @export
+label_report <- function(df, missing_marker = "(no label)") {
+  if (!is.data.frame(df)) stop("`df` must be a data frame.", call. = FALSE)
+  if (!is.character(missing_marker) || length(missing_marker) != 1L) {
+    stop("`missing_marker` must be a single character string.", call. = FALSE)
+  }
+
+  labels <- vapply(df, function(col) {
+    lbl <- attr(col, "label")
+    if (is.null(lbl)) missing_marker else as.character(lbl)
+  }, FUN.VALUE = character(1))
+
+  report <- data.frame(
+    column = names(df),
+    class  = vapply(df, function(x) paste(class(x), collapse = "/"), character(1)),
+    label  = unname(labels),
+    stringsAsFactors = FALSE
+  )
+
+  print(report, row.names = FALSE)
+  invisible(report)
+}

SESSION.md

@@ -11,11 +11,11 @@
 |collate     |en_US.UTF-8                                |
 |ctype       |en_US.UTF-8                                |
 |tz          |Europe/Copenhagen                          |
-|date        |2026-03-02                                 |
+|date        |2026-03-11                                 |
 |rstudio     |2026.01.1+403 Apple Blossom (desktop)      |
 |pandoc      |3.6.4 @ /opt/homebrew/bin/ (via rmarkdown) |
 |quarto      |1.7.30 @ /usr/local/bin/quarto             |
-|FreesearchR |26.3.1.260302                              |
+|FreesearchR |26.3.2.260311                              |
                                                                                 
                                                                                 
 --------------------------------------------------------------------------------
@@ -26,6 +26,8 @@
 |apexcharter       |0.4.5         |2026-01-07 |CRAN (R 4.5.2) |
 |askpass           |1.2.1         |2024-10-04 |CRAN (R 4.5.0) |
 |assertthat        |0.2.1         |2019-03-21 |CRAN (R 4.5.0) |
+|attachment        |0.4.5         |2025-03-14 |CRAN (R 4.5.0) |
+|attempt           |0.3.1         |2020-05-03 |CRAN (R 4.5.0) |
 |backports         |1.5.0         |2024-05-23 |CRAN (R 4.5.0) |
 |base64enc         |0.1-6         |2026-02-02 |CRAN (R 4.5.2) |
 |bayestestR        |0.17.0        |2025-08-29 |CRAN (R 4.5.0) |
@@ -54,6 +56,7 @@
 |colorspace        |2.1-2         |2025-09-22 |CRAN (R 4.5.0) |
 |commonmark        |2.0.0         |2025-07-07 |CRAN (R 4.5.0) |
 |crayon            |1.5.3         |2024-06-20 |CRAN (R 4.5.0) |
+|credentials       |2.0.3         |2025-09-12 |CRAN (R 4.5.0) |
 |curl              |7.0.0         |2025-08-19 |CRAN (R 4.5.0) |
 |data.table        |1.18.2.1      |2026-01-27 |CRAN (R 4.5.2) |
 |datamods          |1.5.3         |2024-10-02 |CRAN (R 4.5.0) |
@@ -63,6 +66,7 @@
 |devtools          |2.4.6         |2025-10-03 |CRAN (R 4.5.0) |
 |DHARMa            |0.4.7         |2024-10-18 |CRAN (R 4.5.0) |
 |digest            |0.6.39        |2025-11-19 |CRAN (R 4.5.2) |
+|dockerfiler       |0.2.5         |2025-05-07 |CRAN (R 4.5.0) |
 |doParallel        |1.0.17        |2022-02-07 |CRAN (R 4.5.0) |
 |dplyr             |1.2.0         |2026-02-03 |CRAN (R 4.5.2) |
 |DT                |0.34.0        |2025-09-02 |CRAN (R 4.5.0) |
@@ -85,16 +89,19 @@
 |foreach           |1.5.2         |2022-02-02 |CRAN (R 4.5.0) |
 |foreign           |0.8-90        |2025-03-31 |CRAN (R 4.5.2) |
 |Formula           |1.2-5         |2023-02-24 |CRAN (R 4.5.0) |
-|FreesearchR       |26.3.1        |NA         |NA             |
+|FreesearchR       |26.3.2        |NA         |NA             |
 |fs                |1.6.6         |2025-04-12 |CRAN (R 4.5.0) |
 |gdtools           |0.5.0         |2026-02-09 |CRAN (R 4.5.2) |
 |generics          |0.1.4         |2025-05-09 |CRAN (R 4.5.0) |
+|gert              |2.3.1         |2026-01-11 |CRAN (R 4.5.2) |
 |ggalluvial        |0.12.5        |2023-02-22 |CRAN (R 4.5.0) |
 |ggcorrplot        |0.1.4.1       |2023-09-05 |CRAN (R 4.5.0) |
 |ggforce           |0.5.0         |2025-06-18 |CRAN (R 4.5.0) |
 |ggplot2           |4.0.2         |2026-02-03 |CRAN (R 4.5.2) |
 |ggridges          |0.5.7         |2025-08-27 |CRAN (R 4.5.0) |
 |ggstats           |0.12.0        |2025-12-22 |CRAN (R 4.5.2) |
+|gh                |1.5.0         |2025-05-26 |CRAN (R 4.5.0) |
+|gitcreds          |0.1.2         |2022-09-08 |CRAN (R 4.5.0) |
 |glue              |1.8.0         |2024-09-30 |CRAN (R 4.5.0) |
 |gridExtra         |2.3           |2017-09-09 |CRAN (R 4.5.0) |
 |gt                |1.3.0         |2026-01-22 |CRAN (R 4.5.2) |
@@ -108,6 +115,7 @@
 |htmltools         |0.5.9         |2025-12-04 |CRAN (R 4.5.2) |
 |htmlwidgets       |1.6.4         |2023-12-06 |CRAN (R 4.5.0) |
 |httpuv            |1.6.16        |2025-04-16 |CRAN (R 4.5.0) |
+|httr2             |1.2.2         |2025-12-08 |CRAN (R 4.5.2) |
 |IDEAFilter        |0.2.1         |2025-07-29 |CRAN (R 4.5.0) |
 |insight           |1.4.6         |2026-02-04 |CRAN (R 4.5.2) |
 |iterators         |1.0.14        |2022-02-05 |CRAN (R 4.5.0) |
@@ -120,9 +128,11 @@
 |later             |1.4.6         |2026-02-13 |CRAN (R 4.5.2) |
 |lattice           |0.22-7        |2025-04-02 |CRAN (R 4.5.2) |
 |lifecycle         |1.0.5         |2026-01-08 |CRAN (R 4.5.2) |
+|litedown          |0.9           |2025-12-18 |CRAN (R 4.5.2) |
 |lme4              |1.1-38        |2025-12-02 |CRAN (R 4.5.2) |
 |lubridate         |1.9.5         |2026-02-04 |CRAN (R 4.5.2) |
 |magrittr          |2.0.4         |2025-09-12 |CRAN (R 4.5.0) |
+|markdown          |2.0           |2025-03-23 |CRAN (R 4.5.0) |
 |MASS              |7.3-65        |2025-02-28 |CRAN (R 4.5.0) |
 |Matrix            |1.7-4         |2025-08-28 |CRAN (R 4.5.2) |
 |memoise           |2.0.1         |2021-11-26 |CRAN (R 4.5.0) |
@@ -138,6 +148,7 @@
 |openssl           |2.3.4         |2025-09-30 |CRAN (R 4.5.0) |
 |openxlsx2         |1.23.1        |2026-01-19 |CRAN (R 4.5.2) |
 |otel              |0.2.0         |2025-08-29 |CRAN (R 4.5.0) |
+|pak               |0.9.2         |2025-12-22 |CRAN (R 4.5.2) |
 |parameters        |0.28.3        |2025-11-25 |CRAN (R 4.5.2) |
 |patchwork         |1.3.2         |2025-08-25 |CRAN (R 4.5.0) |
 |pbmcapply         |1.5.1         |2022-04-28 |CRAN (R 4.5.0) |
@@ -194,6 +205,7 @@
 |sessioninfo       |1.2.3         |2025-02-05 |CRAN (R 4.5.0) |
 |shiny             |1.13.0        |2026-02-20 |CRAN (R 4.5.2) |
 |shiny.i18n        |0.3.0         |2023-01-16 |CRAN (R 4.5.0) |
+|shiny2docker      |0.0.3         |2025-06-28 |CRAN (R 4.5.0) |
 |shinybusy         |0.3.3         |2024-03-09 |CRAN (R 4.5.0) |
 |shinyjs           |2.1.1         |2026-01-15 |CRAN (R 4.5.2) |
 |shinyTime         |1.0.3         |2022-08-19 |CRAN (R 4.5.0) |
@@ -202,6 +214,7 @@
 |stringi           |1.8.7         |2025-03-27 |CRAN (R 4.5.0) |
 |stringr           |1.6.0         |2025-11-04 |CRAN (R 4.5.0) |
 |stRoke            |25.9.2        |2025-09-30 |CRAN (R 4.5.0) |
+|sys               |3.4.3         |2024-10-04 |CRAN (R 4.5.0) |
 |systemfonts       |1.3.1         |2025-10-01 |CRAN (R 4.5.0) |
 |testthat          |3.3.2         |2026-01-11 |CRAN (R 4.5.2) |
 |textshaping       |1.0.4         |2025-10-10 |CRAN (R 4.5.0) |
@@ -227,4 +240,5 @@
 |xml2              |1.5.2         |2026-01-17 |CRAN (R 4.5.2) |
 |xtable            |1.8-4         |2019-04-21 |CRAN (R 4.5.0) |
 |yaml              |2.3.12        |2025-12-10 |CRAN (R 4.5.2) |
+|yesno             |0.1.3         |2024-07-26 |CRAN (R 4.5.0) |
 |zip               |2.3.3         |2025-05-13 |CRAN (R 4.5.0) |

app_docker/app.R

@@ -1,7 +1,7 @@
 
 
 ########
-#### Current file: /var/folders/9l/xbc19wxx0g79jdd2sf_0v291mhwh7f/T//RtmpxB1KWR/file173c96fd4c8c9.R 
+#### Current file: /var/folders/9l/xbc19wxx0g79jdd2sf_0v291mhwh7f/T//RtmpsadCw0/file14b247eddca29.R 
 ########
 
 i18n_path <- here::here("translations")
@@ -75,7 +75,7 @@ if (!"global_freesearchR" %in% ls(name = globalenv())) {
 #### Current file: /Users/au301842/FreesearchR/R//app_version.R 
 ########
 
-app_version <- function()'26.3.1'
+app_version <- function()'26.3.2'
 
 
 ########
@@ -4527,7 +4527,7 @@ data_types <- function() {
 #### Current file: /Users/au301842/FreesearchR/R//hosted_version.R 
 ########
 
-hosted_version <- function()'v26.3.1-260302'
+hosted_version <- function()'v26.3.2-260311'
 
 
 ########
@@ -6367,31 +6367,19 @@ compare_missings <- function(data,
 #' ##   missings_logic_across() |>
 #' ##   gtsummary::tbl_summary()
 missings_logic_across <- function(data, exclude = NULL) {
-  # This function includes a approach way to preserve variable labels
+  # This function includes a way to preserve variable labels
+  with_labels(data,{
   names(data) |>
     lapply(\(.x) {
-      # browser()
-      # Saving original labels
-      lab <- REDCapCAST::get_attr(data[[.x]], attr = "label")
       if (!.x %in% exclude) {
-        out <- is.na(data[[.x]])
+        is.na(data[[.x]])
       } else {
-        out <- data[[.x]]
+        data[[.x]]
-      }
-      if (!is.na(lab)) {
-        # Restoring original labels, if not NA
-        REDCapCAST::set_attr(
-          data = out,
-          label = lab,
-          attr = "label",
-          overwrite = TRUE
-        )
-      } else {
-        out
       }
     }) |>
     dplyr::bind_cols(.name_repair = "unique_quiet") |>
     setNames(names(data))
+  })
 }
 
 
@@ -11435,7 +11423,7 @@ update_factor_ui <- function(id) {
       class = "float-end",
       shinyWidgets::prettyCheckbox(
         inputId = ns("new_var"),
-        label = i18n$t("Create a new variable (otherwise replaces the one selected)"),
+        label = i18n$t("Create a new variable; otherwise replaces (Updating labels always creates new variable)"),
         value = FALSE,
         status = "primary",
         outline = TRUE,
@@ -11566,15 +11554,18 @@ update_factor_server <- function(id, data_r = reactive(NULL)) {
       parameters <- list(
         variable = variable,
         new_variable = isTRUE(input$new_var) |
-          any(grid[["Var1_toset"]] == "New label"),
+          any(grid[["Var1_toset"]] != "New label"),
         new_levels = as.character(grid[["Var1"]]),
         new_labels = as.character(grid[["Var1_toset"]]),
         ignore = "New label"
       )
 
       data <- tryCatch({
+        with_labels(data,{
           rlang::exec(factor_new_levels_labels,
                       !!!modifyList(parameters, val = list(data = data)))
+        })
+
       }, error = function(err) {
         showNotification(paste(
           "We encountered the following error creating the new factor:",
@@ -12546,6 +12537,126 @@ clean_date <- function(data) {
 #
 
 
+########
+#### Current file: /Users/au301842/FreesearchR/R//utils-labels.R 
+########
+
+# =============================================================================
+# Column Label Utilities
+#
+# Coded with help from Claude to save time.
+# Could be seperated for its own package.
+# =============================================================================
+
+#' Extract column labels from a data frame
+#'
+#' @param df A data frame.
+#' @return A named character vector of label strings (only labelled columns included).
+#' @export
+extract_labels <- function(df) {
+  if (!is.data.frame(df)) stop("`df` must be a data frame.", call. = FALSE)
+
+  labels <- vapply(df, function(col) {
+    lbl <- attr(col, "label")
+    if (is.null(lbl)) NA_character_ else as.character(lbl)
+  }, FUN.VALUE = character(1))
+
+  labels[!is.na(labels)]
+}
+
+
+#' Apply a named label vector to a data frame
+#'
+#' @param df A data frame.
+#' @param labels A named character vector (names = column names, values = labels).
+#'   Typically the output of [extract_labels()]. Labels for absent columns are
+#'   silently ignored.
+#' @return `df` with `"label"` attributes set on matching columns.
+#' @export
+apply_labels <- function(df, labels) {
+  if (!is.data.frame(df)) stop("`df` must be a data frame.", call. = FALSE)
+  if (!is.character(labels) || is.null(names(labels))) {
+    stop("`labels` must be a named character vector.", call. = FALSE)
+  }
+
+  for (col in intersect(names(labels), names(df))) {
+    attr(df[[col]], "label") <- labels[[col]]
+  }
+
+  df
+}
+
+
+#' Restore column labels using a reference data frame
+#'
+#' Convenience wrapper around [extract_labels()] + [apply_labels()]. Labels are
+#' matched by column name; new columns in `df_modified` are left unchanged.
+#'
+#' @param df_modified A data frame whose columns should receive labels.
+#' @param df_reference A data frame carrying the authoritative `"label"` attributes.
+#' @return `df_modified` with labels restored on all columns present in `df_reference`.
+#' @export
+restore_labels <- function(df_modified, df_reference) {
+  if (!is.data.frame(df_modified))  stop("`df_modified` must be a data frame.",  call. = FALSE)
+  if (!is.data.frame(df_reference)) stop("`df_reference` must be a data frame.", call. = FALSE)
+
+  apply_labels(df_modified, extract_labels(df_reference))
+}
+
+
+#' Evaluate an expression while preserving column labels
+#'
+#' Snapshots labels from `df` before evaluating `expr`, then reapplies them to
+#' matching columns in the result. New columns created inside `expr` receive no
+#' label automatically.
+#'
+#' @param df A data frame carrying `"label"` attributes.
+#' @param expr An unquoted expression that transforms `df` and returns a data frame.
+#' @return The data frame produced by `expr`, with original labels restored.
+#' @export
+with_labels <- function(df, expr) {
+  if (!is.data.frame(df)) stop("`df` must be a data frame.", call. = FALSE)
+
+  labels <- extract_labels(df)
+  result <- eval(substitute(expr), parent.frame())
+
+  if (!is.data.frame(result)) {
+    stop("The expression passed to `with_labels()` must return a data frame.", call. = FALSE)
+  }
+
+  apply_labels(result, labels)
+}
+
+
+#' Print a tidy summary of column labels
+#'
+#' @param df A data frame.
+#' @param missing_marker String used when a column has no label. Default: `"(no label)"`.
+#' @return A `column / class / label` data frame, printed and returned invisibly.
+#' @export
+label_report <- function(df, missing_marker = "(no label)") {
+  if (!is.data.frame(df)) stop("`df` must be a data frame.", call. = FALSE)
+  if (!is.character(missing_marker) || length(missing_marker) != 1L) {
+    stop("`missing_marker` must be a single character string.", call. = FALSE)
+  }
+
+  labels <- vapply(df, function(col) {
+    lbl <- attr(col, "label")
+    if (is.null(lbl)) missing_marker else as.character(lbl)
+  }, FUN.VALUE = character(1))
+
+  report <- data.frame(
+    column = names(df),
+    class  = vapply(df, function(x) paste(class(x), collapse = "/"), character(1)),
+    label  = unname(labels),
+    stringsAsFactors = FALSE
+  )
+
+  print(report, row.names = FALSE)
+  invisible(report)
+}
+
+
 ########
 #### Current file: /Users/au301842/FreesearchR/R//validation.R 
 ########

app_docker/translations/translation_da.csv

@@ -61,7 +61,6 @@
 "Factor variable to reorder:","Kategoriske variabel der skal ændres:"
 "Sort by levels","Sorter efter niveauer"
 "Sort by count","Sorter efter antal"
-"Create a new variable (otherwise replaces the one selected)","Opret en ny variabel (ellers erstattes den oprindelige)"
 "Update factor variable","Updater faktor-variabel"
 "Levels","Niveauer"
 "Count","Antal"
@@ -328,3 +327,4 @@
 "You have provided a complete dataset with no missing values.","Data er uden manglende observationer."
 "Start by loading data.","Start med at vælge data."
 "Sample data","Træningsdata"
+"Create a new variable; otherwise replaces (Updating labels always creates new variable)","Create a new variable; otherwise replaces (Updating labels always creates new variable)"

app_docker/translations/translation_sw.csv

@@ -61,7 +61,6 @@
 "Factor variable to reorder:","Kigezo cha vipengele ili kupanga upya:"
 "Sort by levels","Panga kwa viwango"
 "Sort by count","Panga kwa hesabu"
-"Create a new variable (otherwise replaces the one selected)","Unda kigezo kipya (vinginevyo kinachukua nafasi ya kile kilichochaguliwa)"
 "Update factor variable","Sasisha kigezo cha kipengele"
 "Levels","Viwango"
 "Count","Hesabu"
@@ -328,3 +327,4 @@
 "You have provided a complete dataset with no missing values.","You have provided a complete dataset with no missing values."
 "Start by loading data.","Start by loading data."
 "Sample data","Sample data"
+"Create a new variable; otherwise replaces (Updating labels always creates new variable)","Create a new variable; otherwise replaces (Updating labels always creates new variable)"

inst/apps/FreesearchR/app.R

@@ -1,7 +1,7 @@
 
 
 ########
-#### Current file: /var/folders/9l/xbc19wxx0g79jdd2sf_0v291mhwh7f/T//RtmpxB1KWR/file173c92887da27.R 
+#### Current file: /var/folders/9l/xbc19wxx0g79jdd2sf_0v291mhwh7f/T//RtmpxB1KWR/file173c978fea931.R 
 ########
 
 i18n_path <- system.file("translations", package = "FreesearchR")
@@ -75,7 +75,7 @@ if (!"global_freesearchR" %in% ls(name = globalenv())) {
 #### Current file: /Users/au301842/FreesearchR/R//app_version.R 
 ########
 
-app_version <- function()'26.3.1'
+app_version <- function()'26.3.2'
 
 
 ########
@@ -4527,7 +4527,7 @@ data_types <- function() {
 #### Current file: /Users/au301842/FreesearchR/R//hosted_version.R 
 ########
 
-hosted_version <- function()'v26.3.1-260302'
+hosted_version <- function()'v26.3.2-260311'
 
 
 ########
@@ -6367,31 +6367,19 @@ compare_missings <- function(data,
 #' ##   missings_logic_across() |>
 #' ##   gtsummary::tbl_summary()
 missings_logic_across <- function(data, exclude = NULL) {
-  # This function includes a approach way to preserve variable labels
+  # This function includes a way to preserve variable labels
+  with_labels(data,{
   names(data) |>
     lapply(\(.x) {
-      # browser()
-      # Saving original labels
-      lab <- REDCapCAST::get_attr(data[[.x]], attr = "label")
       if (!.x %in% exclude) {
-        out <- is.na(data[[.x]])
+        is.na(data[[.x]])
       } else {
-        out <- data[[.x]]
+        data[[.x]]
-      }
-      if (!is.na(lab)) {
-        # Restoring original labels, if not NA
-        REDCapCAST::set_attr(
-          data = out,
-          label = lab,
-          attr = "label",
-          overwrite = TRUE
-        )
-      } else {
-        out
       }
     }) |>
     dplyr::bind_cols(.name_repair = "unique_quiet") |>
     setNames(names(data))
+  })
 }
 
 
@@ -11435,7 +11423,7 @@ update_factor_ui <- function(id) {
       class = "float-end",
       shinyWidgets::prettyCheckbox(
         inputId = ns("new_var"),
-        label = i18n$t("Create a new variable (otherwise replaces the one selected)"),
+        label = i18n$t("Create a new variable; otherwise replaces (Updating labels always creates new variable)"),
         value = FALSE,
         status = "primary",
         outline = TRUE,
@@ -11566,15 +11554,18 @@ update_factor_server <- function(id, data_r = reactive(NULL)) {
       parameters <- list(
         variable = variable,
         new_variable = isTRUE(input$new_var) |
-          any(grid[["Var1_toset"]] == "New label"),
+          any(grid[["Var1_toset"]] != "New label"),
         new_levels = as.character(grid[["Var1"]]),
         new_labels = as.character(grid[["Var1_toset"]]),
         ignore = "New label"
       )
 
       data <- tryCatch({
+        with_labels(data,{
           rlang::exec(factor_new_levels_labels,
                       !!!modifyList(parameters, val = list(data = data)))
+        })
+
       }, error = function(err) {
         showNotification(paste(
           "We encountered the following error creating the new factor:",
@@ -12546,6 +12537,126 @@ clean_date <- function(data) {
 #
 
 
+########
+#### Current file: /Users/au301842/FreesearchR/R//utils-labels.R 
+########
+
+# =============================================================================
+# Column Label Utilities
+#
+# Coded with help from Claude to save time.
+# Could be seperated for its own package.
+# =============================================================================
+
+#' Extract column labels from a data frame
+#'
+#' @param df A data frame.
+#' @return A named character vector of label strings (only labelled columns included).
+#' @export
+extract_labels <- function(df) {
+  if (!is.data.frame(df)) stop("`df` must be a data frame.", call. = FALSE)
+
+  labels <- vapply(df, function(col) {
+    lbl <- attr(col, "label")
+    if (is.null(lbl)) NA_character_ else as.character(lbl)
+  }, FUN.VALUE = character(1))
+
+  labels[!is.na(labels)]
+}
+
+
+#' Apply a named label vector to a data frame
+#'
+#' @param df A data frame.
+#' @param labels A named character vector (names = column names, values = labels).
+#'   Typically the output of [extract_labels()]. Labels for absent columns are
+#'   silently ignored.
+#' @return `df` with `"label"` attributes set on matching columns.
+#' @export
+apply_labels <- function(df, labels) {
+  if (!is.data.frame(df)) stop("`df` must be a data frame.", call. = FALSE)
+  if (!is.character(labels) || is.null(names(labels))) {
+    stop("`labels` must be a named character vector.", call. = FALSE)
+  }
+
+  for (col in intersect(names(labels), names(df))) {
+    attr(df[[col]], "label") <- labels[[col]]
+  }
+
+  df
+}
+
+
+#' Restore column labels using a reference data frame
+#'
+#' Convenience wrapper around [extract_labels()] + [apply_labels()]. Labels are
+#' matched by column name; new columns in `df_modified` are left unchanged.
+#'
+#' @param df_modified A data frame whose columns should receive labels.
+#' @param df_reference A data frame carrying the authoritative `"label"` attributes.
+#' @return `df_modified` with labels restored on all columns present in `df_reference`.
+#' @export
+restore_labels <- function(df_modified, df_reference) {
+  if (!is.data.frame(df_modified))  stop("`df_modified` must be a data frame.",  call. = FALSE)
+  if (!is.data.frame(df_reference)) stop("`df_reference` must be a data frame.", call. = FALSE)
+
+  apply_labels(df_modified, extract_labels(df_reference))
+}
+
+
+#' Evaluate an expression while preserving column labels
+#'
+#' Snapshots labels from `df` before evaluating `expr`, then reapplies them to
+#' matching columns in the result. New columns created inside `expr` receive no
+#' label automatically.
+#'
+#' @param df A data frame carrying `"label"` attributes.
+#' @param expr An unquoted expression that transforms `df` and returns a data frame.
+#' @return The data frame produced by `expr`, with original labels restored.
+#' @export
+with_labels <- function(df, expr) {
+  if (!is.data.frame(df)) stop("`df` must be a data frame.", call. = FALSE)
+
+  labels <- extract_labels(df)
+  result <- eval(substitute(expr), parent.frame())
+
+  if (!is.data.frame(result)) {
+    stop("The expression passed to `with_labels()` must return a data frame.", call. = FALSE)
+  }
+
+  apply_labels(result, labels)
+}
+
+
+#' Print a tidy summary of column labels
+#'
+#' @param df A data frame.
+#' @param missing_marker String used when a column has no label. Default: `"(no label)"`.
+#' @return A `column / class / label` data frame, printed and returned invisibly.
+#' @export
+label_report <- function(df, missing_marker = "(no label)") {
+  if (!is.data.frame(df)) stop("`df` must be a data frame.", call. = FALSE)
+  if (!is.character(missing_marker) || length(missing_marker) != 1L) {
+    stop("`missing_marker` must be a single character string.", call. = FALSE)
+  }
+
+  labels <- vapply(df, function(col) {
+    lbl <- attr(col, "label")
+    if (is.null(lbl)) missing_marker else as.character(lbl)
+  }, FUN.VALUE = character(1))
+
+  report <- data.frame(
+    column = names(df),
+    class  = vapply(df, function(x) paste(class(x), collapse = "/"), character(1)),
+    label  = unname(labels),
+    stringsAsFactors = FALSE
+  )
+
+  print(report, row.names = FALSE)
+  invisible(report)
+}
+
+
 ########
 #### Current file: /Users/au301842/FreesearchR/R//validation.R 
 ########

inst/translations/translation_da.csv

@@ -61,7 +61,6 @@
 "Factor variable to reorder:","Kategoriske variabel der skal ændres:"
 "Sort by levels","Sorter efter niveauer"
 "Sort by count","Sorter efter antal"
-"Create a new variable (otherwise replaces the one selected)","Opret en ny variabel (ellers erstattes den oprindelige)"
 "Update factor variable","Updater faktor-variabel"
 "Levels","Niveauer"
 "Count","Antal"
@@ -328,3 +327,4 @@
 "You have provided a complete dataset with no missing values.","Data er uden manglende observationer."
 "Start by loading data.","Start med at vælge data."
 "Sample data","Træningsdata"
+"Create a new variable; otherwise replaces (Updating labels always creates new variable)","Create a new variable; otherwise replaces (Updating labels always creates new variable)"

inst/translations/translation_sw.csv

@@ -61,7 +61,6 @@
 "Factor variable to reorder:","Kigezo cha vipengele ili kupanga upya:"
 "Sort by levels","Panga kwa viwango"
 "Sort by count","Panga kwa hesabu"
-"Create a new variable (otherwise replaces the one selected)","Unda kigezo kipya (vinginevyo kinachukua nafasi ya kile kilichochaguliwa)"
 "Update factor variable","Sasisha kigezo cha kipengele"
 "Levels","Viwango"
 "Count","Hesabu"
@@ -328,3 +327,4 @@
 "You have provided a complete dataset with no missing values.","You have provided a complete dataset with no missing values."
 "Start by loading data.","Start by loading data."
 "Sample data","Sample data"
+"Create a new variable; otherwise replaces (Updating labels always creates new variable)","Create a new variable; otherwise replaces (Updating labels always creates new variable)"

man/apply_labels.Rd

@@ -0,0 +1,21 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/utils-labels.R
+\name{apply_labels}
+\alias{apply_labels}
+\title{Apply a named label vector to a data frame}
+\usage{
+apply_labels(df, labels)
+}
+\arguments{
+\item{df}{A data frame.}
+
+\item{labels}{A named character vector (names = column names, values = labels).
+Typically the output of \code{\link[=extract_labels]{extract_labels()}}. Labels for absent columns are
+silently ignored.}
+}
+\value{
+\code{df} with \code{"label"} attributes set on matching columns.
+}
+\description{
+Apply a named label vector to a data frame
+}

man/extract_labels.Rd

@@ -0,0 +1,17 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/utils-labels.R
+\name{extract_labels}
+\alias{extract_labels}
+\title{Extract column labels from a data frame}
+\usage{
+extract_labels(df)
+}
+\arguments{
+\item{df}{A data frame.}
+}
+\value{
+A named character vector of label strings (only labelled columns included).
+}
+\description{
+Extract column labels from a data frame
+}

man/label_report.Rd

@@ -0,0 +1,19 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/utils-labels.R
+\name{label_report}
+\alias{label_report}
+\title{Print a tidy summary of column labels}
+\usage{
+label_report(df, missing_marker = "(no label)")
+}
+\arguments{
+\item{df}{A data frame.}
+
+\item{missing_marker}{String used when a column has no label. Default: \code{"(no label)"}.}
+}
+\value{
+A \code{column / class / label} data frame, printed and returned invisibly.
+}
+\description{
+Print a tidy summary of column labels
+}

man/restore_labels.Rd

@@ -0,0 +1,20 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/utils-labels.R
+\name{restore_labels}
+\alias{restore_labels}
+\title{Restore column labels using a reference data frame}
+\usage{
+restore_labels(df_modified, df_reference)
+}
+\arguments{
+\item{df_modified}{A data frame whose columns should receive labels.}
+
+\item{df_reference}{A data frame carrying the authoritative \code{"label"} attributes.}
+}
+\value{
+\code{df_modified} with labels restored on all columns present in \code{df_reference}.
+}
+\description{
+Convenience wrapper around \code{\link[=extract_labels]{extract_labels()}} + \code{\link[=apply_labels]{apply_labels()}}. Labels are
+matched by column name; new columns in \code{df_modified} are left unchanged.
+}

man/with_labels.Rd

@@ -0,0 +1,21 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/utils-labels.R
+\name{with_labels}
+\alias{with_labels}
+\title{Evaluate an expression while preserving column labels}
+\usage{
+with_labels(df, expr)
+}
+\arguments{
+\item{df}{A data frame carrying \code{"label"} attributes.}
+
+\item{expr}{An unquoted expression that transforms \code{df} and returns a data frame.}
+}
+\value{
+The data frame produced by \code{expr}, with original labels restored.
+}
+\description{
+Snapshots labels from \code{df} before evaluating \code{expr}, then reapplies them to
+matching columns in the result. New columns created inside \code{expr} receive no
+label automatically.
+}

tests/testthat/test-utils-labels.R

@@ -0,0 +1,143 @@
+# Tests for column label utilities (extract_labels, apply_labels,
+# restore_labels, with_labels, label_report)
+
+# --- extract_labels ----------------------------------------------------------
+
+test_that("extract_labels returns named character vector of present labels", {
+  df <- data.frame(a = 1:3, b = 4:6, c = 7:9)
+  attr(df$a, "label") <- "Column A"
+  attr(df$b, "label") <- "Column B"
+
+  lbls <- extract_labels(df)
+
+  expect_type(lbls, "character")
+  expect_named(lbls, c("a", "b"))
+  expect_equal(lbls[["a"]], "Column A")
+  expect_equal(lbls[["b"]], "Column B")
+  expect_false("c" %in% names(lbls))
+})
+
+test_that("extract_labels returns zero-length vector when no labels present", {
+  expect_equal(length(extract_labels(data.frame(x = 1, y = 2))), 0L)
+})
+
+test_that("extract_labels errors on non-data-frame input", {
+  expect_error(extract_labels(list(a = 1)), "`df` must be a data frame")
+  expect_error(extract_labels(1:5),         "`df` must be a data frame")
+})
+
+
+# --- apply_labels ------------------------------------------------------------
+
+test_that("apply_labels sets label attributes on matching columns", {
+  df  <- data.frame(age = 1:3, income = c(10, 20, 30))
+  df2 <- apply_labels(df, c(age = "Age (years)", income = "Income (USD)"))
+
+  expect_equal(attr(df2$age,    "label"), "Age (years)")
+  expect_equal(attr(df2$income, "label"), "Income (USD)")
+})
+
+test_that("apply_labels silently ignores labels for absent columns", {
+  df <- data.frame(age = 1:3)
+  expect_no_error(apply_labels(df, c(age = "Age", income = "Income")))
+  expect_equal(attr(apply_labels(df, c(age = "Age", income = "Income"))$age, "label"), "Age")
+})
+
+test_that("apply_labels errors on bad inputs", {
+  expect_error(apply_labels(list(),       c(a = "A")), "`df` must be a data frame")
+  expect_error(apply_labels(data.frame(), c("A")),     "`labels` must be a named")
+  expect_error(apply_labels(data.frame(), 123),        "`labels` must be a named")
+})
+
+
+# --- restore_labels ----------------------------------------------------------
+
+test_that("restore_labels copies labels from reference to modified df", {
+  df <- data.frame(a = 1:5, b = letters[1:5], stringsAsFactors = FALSE)
+  attr(df$a, "label") <- "Variable A"
+  attr(df$b, "label") <- "Variable B"
+
+  df_mod <- df[df$a > 2, ]
+  attr(df_mod$a, "label") <- NULL
+  attr(df_mod$b, "label") <- NULL
+
+  df_restored <- restore_labels(df_mod, df)
+
+  expect_equal(attr(df_restored$a, "label"), "Variable A")
+  expect_equal(attr(df_restored$b, "label"), "Variable B")
+})
+
+test_that("restore_labels does not error when modified df has extra columns", {
+  df <- data.frame(x = 1:3)
+  attr(df$x, "label") <- "X"
+
+  df_mod <- df
+  df_mod$y <- df$x * 2
+
+  result <- restore_labels(df_mod, df)
+  expect_equal(attr(result$x, "label"), "X")
+  expect_null(attr(result$y, "label"))
+})
+
+test_that("restore_labels errors on non-data-frame inputs", {
+  df <- data.frame(x = 1)
+  expect_error(restore_labels(list(), df), "`df_modified` must be a data frame")
+  expect_error(restore_labels(df, list()), "`df_reference` must be a data frame")
+})
+
+
+# --- with_labels -------------------------------------------------------------
+
+test_that("with_labels preserves labels through a subsetting expression", {
+  df <- data.frame(id = 1:5, age = c(25, 34, 45, 29, 52))
+  attr(df$age, "label") <- "Age (years)"
+
+  result <- with_labels(df, df[df$age > 30, ])
+  expect_equal(attr(result$age, "label"), "Age (years)")
+})
+
+test_that("with_labels does not assign labels to new columns", {
+  df <- data.frame(x = 1:3, y = 4:6)
+  attr(df$x, "label") <- "X label"
+
+  result <- with_labels(df, { df$z <- df$x + df$y; df })
+
+  expect_equal(attr(result$x, "label"), "X label")
+  expect_null(attr(result$z, "label"))
+})
+
+test_that("with_labels errors when expression does not return a data frame", {
+  df <- data.frame(x = 1:3)
+  expect_error(with_labels(df, sum(df$x)), "must return a data frame")
+})
+
+test_that("with_labels errors on non-data-frame df argument", {
+  expect_error(with_labels(list(x = 1), list()), "`df` must be a data frame")
+})
+
+
+# --- label_report ------------------------------------------------------------
+
+test_that("label_report returns correct structure", {
+  df <- data.frame(a = 1L, b = "x", stringsAsFactors = FALSE)
+  attr(df$a, "label") <- "Alpha"
+
+  report <- label_report(df)
+
+  expect_s3_class(report, "data.frame")
+  expect_named(report, c("column", "class", "label"))
+  expect_equal(nrow(report), 2L)
+  expect_equal(report$label[report$column == "a"], "Alpha")
+  expect_equal(report$label[report$column == "b"], "(no label)")
+})
+
+test_that("label_report respects custom missing_marker", {
+  df     <- data.frame(x = 1)
+  report <- label_report(df, missing_marker = "N/A")
+  expect_equal(report$label[1], "N/A")
+})
+
+test_that("label_report errors on bad inputs", {
+  expect_error(label_report(list()),               "`df` must be a data frame")
+  expect_error(label_report(data.frame(), c("a", "b")), "`missing_marker`")
+})