diff --git a/CITATION.cff b/CITATION.cff index aec07b9e..6d5ebe92 100644 --- a/CITATION.cff +++ b/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 diff --git a/DESCRIPTION b/DESCRIPTION index 1a810014..1c5d410d 100644 --- a/DESCRIPTION +++ b/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' diff --git a/NAMESPACE b/NAMESPACE index 420954d7..e7e642c1 100644 --- a/NAMESPACE +++ b/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) diff --git a/NEWS.md b/NEWS.md index e11b622b..6f50a612 100644 --- a/NEWS.md +++ b/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. diff --git a/R/app_version.R b/R/app_version.R index 1a1ca529..a87c4470 100644 --- a/R/app_version.R +++ b/R/app_version.R @@ -1 +1 @@ -app_version <- function()'26.3.1' +app_version <- function()'26.3.2' diff --git a/R/hosted_version.R b/R/hosted_version.R index b4e35b45..771bd124 100644 --- a/R/hosted_version.R +++ b/R/hosted_version.R @@ -1 +1 @@ -hosted_version <- function()'v26.3.1-260302' +hosted_version <- function()'v26.3.2-260311' diff --git a/R/missings-module.R b/R/missings-module.R index 25d250ee..8b9c1f50 100644 --- a/R/missings-module.R +++ b/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]] - } - if (!is.na(lab)) { - # Restoring original labels, if not NA - REDCapCAST::set_attr( - data = out, - label = lab, - attr = "label", - overwrite = TRUE - ) - } else { - out + data[[.x]] } }) |> dplyr::bind_cols(.name_repair = "unique_quiet") |> setNames(names(data)) + }) } diff --git a/R/sysdata.rda b/R/sysdata.rda index c3a99779..e7ce4106 100644 Binary files a/R/sysdata.rda and b/R/sysdata.rda differ diff --git a/R/update-factor-ext.R b/R/update-factor-ext.R index 19fb9c40..ad1b263c 100644 --- a/R/update-factor-ext.R +++ b/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({ - rlang::exec(factor_new_levels_labels, - !!!modifyList(parameters, val = list(data = data))) + 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:", diff --git a/R/utils-labels.R b/R/utils-labels.R new file mode 100644 index 00000000..a221777b --- /dev/null +++ b/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) +} diff --git a/SESSION.md b/SESSION.md index 60cce1f1..608dbe98 100644 --- a/SESSION.md +++ b/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) | diff --git a/app_docker/app.R b/app_docker/app.R index 9ef19d16..7f99dcd4 100644 --- a/app_docker/app.R +++ b/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]] - } - if (!is.na(lab)) { - # Restoring original labels, if not NA - REDCapCAST::set_attr( - data = out, - label = lab, - attr = "label", - overwrite = TRUE - ) - } else { - out + data[[.x]] } }) |> 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({ - rlang::exec(factor_new_levels_labels, - !!!modifyList(parameters, val = list(data = data))) + 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 ######## diff --git a/app_docker/translations/translation_da.csv b/app_docker/translations/translation_da.csv index fef64b5f..86a7f72b 100644 --- a/app_docker/translations/translation_da.csv +++ b/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)" diff --git a/app_docker/translations/translation_sw.csv b/app_docker/translations/translation_sw.csv index 300390ff..1193ea71 100644 --- a/app_docker/translations/translation_sw.csv +++ b/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)" diff --git a/inst/apps/FreesearchR/app.R b/inst/apps/FreesearchR/app.R index 9e885cb4..6007a903 100644 --- a/inst/apps/FreesearchR/app.R +++ b/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]] - } - if (!is.na(lab)) { - # Restoring original labels, if not NA - REDCapCAST::set_attr( - data = out, - label = lab, - attr = "label", - overwrite = TRUE - ) - } else { - out + data[[.x]] } }) |> 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({ - rlang::exec(factor_new_levels_labels, - !!!modifyList(parameters, val = list(data = data))) + 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 ######## diff --git a/inst/translations/translation_da.csv b/inst/translations/translation_da.csv index fef64b5f..86a7f72b 100644 --- a/inst/translations/translation_da.csv +++ b/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)" diff --git a/inst/translations/translation_sw.csv b/inst/translations/translation_sw.csv index 300390ff..1193ea71 100644 --- a/inst/translations/translation_sw.csv +++ b/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)" diff --git a/man/apply_labels.Rd b/man/apply_labels.Rd new file mode 100644 index 00000000..fa7237ec --- /dev/null +++ b/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 +} diff --git a/man/extract_labels.Rd b/man/extract_labels.Rd new file mode 100644 index 00000000..b851352e --- /dev/null +++ b/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 +} diff --git a/man/label_report.Rd b/man/label_report.Rd new file mode 100644 index 00000000..03578d10 --- /dev/null +++ b/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 +} diff --git a/man/restore_labels.Rd b/man/restore_labels.Rd new file mode 100644 index 00000000..91fdbd1d --- /dev/null +++ b/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. +} diff --git a/man/with_labels.Rd b/man/with_labels.Rd new file mode 100644 index 00000000..62b6a9e4 --- /dev/null +++ b/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. +} diff --git a/tests/testthat/test-utils-labels.R b/tests/testthat/test-utils-labels.R new file mode 100644 index 00000000..e2f467ce --- /dev/null +++ b/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`") +})