From fe9918dc105c35fdd902a18b8a53b9706f1bd997 Mon Sep 17 00:00:00 2001 From: Andreas Gammelgaard Damsbo Date: Tue, 19 Nov 2024 12:54:26 +0100 Subject: [PATCH] implement support for variable attributes for field label incl conversion of logicals to factor --- NAMESPACE | 2 + R/ds2dd_detailed.R | 86 ++++++++++++++++++++++++++++++++++++----- man/ds2dd_detailed.Rd | 5 ++- man/get_attr.Rd | 27 +++++++++++++ man/haven_all_levels.Rd | 2 + man/set_attr.Rd | 21 ++++++++++ 6 files changed, 132 insertions(+), 11 deletions(-) create mode 100644 man/get_attr.Rd create mode 100644 man/set_attr.Rd diff --git a/NAMESPACE b/NAMESPACE index 3c05cc9..e96b293 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -21,6 +21,7 @@ export(file_extension) export(focused_metadata) export(format_subheader) export(get_api_key) +export(get_attr) export(guess_time_only) export(guess_time_only_filter) export(haven_all_levels) @@ -35,6 +36,7 @@ export(read_redcap_instrument) export(read_redcap_tables) export(redcap_wider) export(sanitize_split) +export(set_attr) export(shiny_cast) export(split_non_repeating_forms) export(strsplitx) diff --git a/R/ds2dd_detailed.R b/R/ds2dd_detailed.R index e47e415..fbb1f54 100644 --- a/R/ds2dd_detailed.R +++ b/R/ds2dd_detailed.R @@ -135,6 +135,7 @@ hms2character <- function(data) { #' file with `haven::read_dta()`). #' @param metadata redcap metadata headings. Default is #' REDCapCAST:::metadata_names. +#' @param convert.logicals convert logicals to factor. Default is TRUE. #' #' @return list of length 2 #' @export @@ -166,7 +167,28 @@ ds2dd_detailed <- function(data, field.label = NULL, field.label.attr = "label", field.validation = NULL, - metadata = names(REDCapCAST::redcapcast_meta)) { + metadata = names(REDCapCAST::redcapcast_meta), + convert.logicals = TRUE) { + + if (convert.logicals) { + # Labels/attributes are saved + labels <- lapply(data, \(.x){ + get_attr(.x, attr = NULL) + }) + + no_attr <- data |> + ## Converts logical to factor, which overwrites attributes + dplyr::mutate(dplyr::across(dplyr::where(is.logical), forcats::as_factor)) + + # Old attributes are appended + data <- purrr::imap(no_attr,\(.x,.i){ + attributes(.x) <- c(attributes(.x),labels[[.i]]) + .x + }) |> + dplyr::bind_cols() + + } + ## Handles the odd case of no id column present if (add.auto.id) { data <- dplyr::tibble( @@ -224,15 +246,9 @@ ds2dd_detailed <- function(data, if (is.null(field.label)) { dd$field_label <- data |> - lapply(function(x) { - if (haven::is.labelled(x)) { - att <- haven_all_levels(x) - names(att) - } else { - NA - } - }) |> - (\(x)do.call(c, x))() + sapply(function(x) { + get_attr(x, attr = field.label.attr) + }) dd <- dd |> dplyr::mutate(field_label = dplyr::if_else(is.na(field_label), @@ -353,6 +369,8 @@ ds2dd_detailed <- function(data, #' labels = c(Unknown = 9, Refused = 10), #' class = "haven_labelled" #' ) +#' labelled::is.labelled(ds) +#' attributes(ds) #' ds |> haven_all_levels() haven_all_levels <- function(data) { stopifnot(haven::is.labelled(data)) @@ -548,3 +566,51 @@ numchar2fct <- function(data, numeric.threshold = 6, character.throshold = 6) { ) ) } + +#' Extract attribute. Returns NA if none +#' +#' @param data vector +#' @param attr attribute name +#' +#' @return character vector +#' @export +#' +#' @examples +#' attr(mtcars$mpg, "label") <- "testing" +#' sapply(mtcars, get_attr) +#' lapply(mtcars, \(.x)get_attr(.x, NULL)) +#' mtcars |> +#' numchar2fct(numeric.threshold = 6) |> +#' ds2dd_detailed() +get_attr <- function(data, attr = NULL) { + if (is.null(attr)) { + attributes(data) + } else { + a <- attr(data, attr, exact = TRUE) + if (is.null(a)) { + NA + } else { + a + } + } +} + + +#' Set attributes for named attribute. Appends if attr is NULL +#' +#' @param data vector +#' @param label label +#' @param attr attribute name +#' +#' @return vector with attribute +#' @export +#' +set_attr <- function(data, label, attr = NULL) { + if (is.null(attr)) { + attributes(data) <- c(attributes(data),label) + } else { + attr(data, attr) <- label + } + data +} + diff --git a/man/ds2dd_detailed.Rd b/man/ds2dd_detailed.Rd index c7cbb2e..5053421 100644 --- a/man/ds2dd_detailed.Rd +++ b/man/ds2dd_detailed.Rd @@ -15,7 +15,8 @@ ds2dd_detailed( field.label = NULL, field.label.attr = "label", field.validation = NULL, - metadata = names(REDCapCAST::redcapcast_meta) + metadata = names(REDCapCAST::redcapcast_meta), + convert.logicals = TRUE ) } \arguments{ @@ -55,6 +56,8 @@ file with `haven::read_dta()`).} \item{metadata}{redcap metadata headings. Default is REDCapCAST:::metadata_names.} + +\item{convert.logicals}{convert logicals to factor. Default is TRUE.} } \value{ list of length 2 diff --git a/man/get_attr.Rd b/man/get_attr.Rd new file mode 100644 index 0000000..a0a5f5e --- /dev/null +++ b/man/get_attr.Rd @@ -0,0 +1,27 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/ds2dd_detailed.R +\name{get_attr} +\alias{get_attr} +\title{Extract attribute. Returns NA if none} +\usage{ +get_attr(data, attr = NULL) +} +\arguments{ +\item{data}{vector} + +\item{attr}{attribute name} +} +\value{ +character vector +} +\description{ +Extract attribute. Returns NA if none +} +\examples{ +attr(mtcars$mpg, "label") <- "testing" +sapply(mtcars, get_attr) +lapply(mtcars, \(.x)get_attr(.x, NULL)) +mtcars |> + numchar2fct(numeric.threshold = 6) |> + ds2dd_detailed() +} diff --git a/man/haven_all_levels.Rd b/man/haven_all_levels.Rd index f15ff23..376e92c 100644 --- a/man/haven_all_levels.Rd +++ b/man/haven_all_levels.Rd @@ -20,5 +20,7 @@ ds <- structure(c(1, 2, 3, 2, 10, 9), labels = c(Unknown = 9, Refused = 10), class = "haven_labelled" ) +labelled::is.labelled(ds) +attributes(ds) ds |> haven_all_levels() } diff --git a/man/set_attr.Rd b/man/set_attr.Rd new file mode 100644 index 0000000..8fcf43c --- /dev/null +++ b/man/set_attr.Rd @@ -0,0 +1,21 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/ds2dd_detailed.R +\name{set_attr} +\alias{set_attr} +\title{Set attributes for named attribute. Appends if attr is NULL} +\usage{ +set_attr(data, label, attr = NULL) +} +\arguments{ +\item{data}{vector} + +\item{label}{label} + +\item{attr}{attribute name} +} +\value{ +vector with attribute +} +\description{ +Set attributes for named attribute. Appends if attr is NULL +}