fix: keeps labels modifying factors and creates new factors correctly

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)
+}