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..e47380cb 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,6 +1,6 @@ Package: FreesearchR Title: Easy data analysis for clinicians -Version: 26.3.1 +Version: 26.3.3 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..e5800992 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,3 +1,15 @@ +# FreesearchR 26.3.3 + +*NEW* option to pass global settings when running as docker or launching from R. Support for INCLUDE_GLOBALENV, DATA_LIMIT_DEFAULT, DATA_LIMIT_UPPER and DATA_LIMIT_LOWER. Docs are missing... + +# 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/launch_FreesearchR.R b/R/launch_FreesearchR.R index 504de474..469c443b 100644 --- a/R/launch_FreesearchR.R +++ b/R/launch_FreesearchR.R @@ -23,11 +23,11 @@ launch_FreesearchR <- function(inlcude_globalenv = TRUE, data_limit_upper = 100000, data_limit_lower = 1, ...) { - global_freesearchR <- list( - include_globalenv = include_globalenv, - data_limit_default = data_limit_default, - data_limit_upper = data_limit_upper, - data_limit_lower = data_limit_lower + Sys.setenv( + INCLUDE_GLOBALENV = include_globalenv, + DATA_LIMIT_DEFAULT = data_limit_default, + DATA_LIMIT_UPPER = data_limit_upper, + DATA_LIMIT_LOWER = data_limit_lower ) appDir <- system.file("apps", "FreesearchR", package = "FreesearchR") @@ -39,3 +39,21 @@ launch_FreesearchR <- function(inlcude_globalenv = TRUE, a <- shiny::runApp(appDir = paste0(appDir, "/app.R"), ...) return(invisible(a)) } + + +## Helper to set env variables +get_config <- function(var_name, default = NULL) { + # First check environment variables (set by Docker) + val <- Sys.getenv(var_name, unset = NA) + + if (!is.na(val) && nzchar(val)) { + return(val) + } + + # Fall back to default (can be overridden when launching from R) + if (!is.null(default)) { + return(default) + } + + stop(paste("Required config variable not set:", var_name)) +} 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..f20ba255 100644 Binary files a/R/sysdata.rda and b/R/sysdata.rda differ diff --git a/R/ui_elements.R b/R/ui_elements.R index 0aea99e8..cac844a0 100644 --- a/R/ui_elements.R +++ b/R/ui_elements.R @@ -83,9 +83,9 @@ ui_elements <- function(selection) { layout_params = "dropdown", # title = "Choose a datafile to upload", file_extensions = c(".csv", ".tsv", ".txt", ".xls", ".xlsx", ".rds", ".ods", ".dta"), - limit_default = global_freesearchR$data_limit_default, - limit_lower = global_freesearchR$data_limit_lower, - limit_upper = global_freesearchR$data_limit_upper + limit_default = DATA_LIMIT_DEFAULT, + limit_lower = DATA_LIMIT_LOWER, + limit_upper = DATA_LIMIT_UPPER ) ), @@ -107,7 +107,7 @@ ui_elements <- function(selection) { id = "env", title = NULL, packages = c("NHANES", "stRoke", "datasets", "MASS"), - globalenv = global_freesearchR$include_globalenv + globalenv = isTruthy(INCLUDE_GLOBALENV) ) ), # shiny::conditionalPanel( 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..1193d865 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 | -------------------------------------------------------------------------------- @@ -44,7 +44,6 @@ |cardx |0.3.2 |2026-02-05 |CRAN (R 4.5.2) | |caTools |1.18.3 |2024-09-04 |CRAN (R 4.5.0) | |cellranger |1.1.0 |2016-07-27 |CRAN (R 4.5.0) | -|cffr |1.2.1 |2026-01-12 |CRAN (R 4.5.2) | |checkmate |2.3.4 |2026-02-03 |CRAN (R 4.5.2) | |class |7.3-23 |2025-01-01 |CRAN (R 4.5.2) | |classInt |0.4-11 |2025-01-08 |CRAN (R 4.5.0) | @@ -54,7 +53,6 @@ |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) | -|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) | |datawizard |1.3.0 |2025-10-11 |CRAN (R 4.5.0) | @@ -85,7 +83,7 @@ |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) | @@ -113,7 +111,6 @@ |iterators |1.0.14 |2022-02-05 |CRAN (R 4.5.0) | |jquerylib |0.1.4 |2021-04-26 |CRAN (R 4.5.0) | |jsonlite |2.0.0 |2025-03-27 |CRAN (R 4.5.0) | -|jsonvalidate |1.5.0 |2025-02-07 |CRAN (R 4.5.0) | |KernSmooth |2.23-26 |2025-01-01 |CRAN (R 4.5.2) | |keyring |1.4.1 |2025-06-15 |CRAN (R 4.5.0) | |knitr |1.51 |2025-12-20 |CRAN (R 4.5.2) | @@ -161,7 +158,6 @@ |R6 |2.6.1 |2025-02-15 |CRAN (R 4.5.0) | |ragg |1.5.0 |2025-09-02 |CRAN (R 4.5.0) | |rankinPlot |1.1.0 |2023-01-30 |CRAN (R 4.5.0) | -|rappdirs |0.3.4 |2026-01-17 |CRAN (R 4.5.2) | |rbibutils |2.4.1 |2026-01-21 |CRAN (R 4.5.2) | |RColorBrewer |1.1-3 |2022-04-03 |CRAN (R 4.5.0) | |Rcpp |1.1.1 |2026-01-10 |CRAN (R 4.5.2) | @@ -216,7 +212,6 @@ |tzdb |0.5.0 |2025-03-15 |CRAN (R 4.5.0) | |usethis |3.2.1 |2025-09-06 |CRAN (R 4.5.0) | |uuid |1.2-2 |2026-01-23 |CRAN (R 4.5.2) | -|V8 |8.0.1 |2025-10-10 |CRAN (R 4.5.0) | |vctrs |0.7.1 |2026-01-23 |CRAN (R 4.5.2) | |viridis |0.6.5 |2024-01-29 |CRAN (R 4.5.0) | |viridisLite |0.4.3 |2026-02-04 |CRAN (R 4.5.2) | 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`") +})