From 5926c12da63a94167e54b0713e5814f617e9cd51 Mon Sep 17 00:00:00 2001 From: Andreas Gammelgaard Damsbo Date: Thu, 28 Nov 2024 14:31:27 +0100 Subject: [PATCH] adjusted docs --- R/as_factor.R | 57 ++++++++++++++++++++++++------------------ R/easy_redcap.R | 23 +++++++++++++---- R/read_redcap_tables.R | 51 +++++++++++++++++++++++++++---------- 3 files changed, 88 insertions(+), 43 deletions(-) diff --git a/R/as_factor.R b/R/as_factor.R index c90917e..27e424a 100644 --- a/R/as_factor.R +++ b/R/as_factor.R @@ -1,6 +1,6 @@ #' Convert labelled vectors to factors while preserving attributes #' -#' This extends [forcats::as_factor()] as well as [haven::as_factor()], by appending +#' This extends \link[forcats]{as_factor} as well as \link[haven]{as_factor}, by appending #' original attributes except for "class" after converting to factor to avoid #' ta loss in case of rich formatted and labelled data. #' @@ -128,10 +128,6 @@ as_factor.haven_labelled <- function(x, levels = c("default", "labels", "values" #' @rdname as_factor as_factor.labelled <- as_factor.haven_labelled -#' @export -#' @rdname as_factor -as_factor.redcapcast_labelled <- as_factor.haven_labelled - #' @rdname as_factor #' @export as_factor.data.frame <- function(x, ..., only_labelled = TRUE) { @@ -158,7 +154,7 @@ as_factor.data.frame <- function(x, ..., only_labelled = TRUE) { #' labels = c(Unknown = 9, Refused = 10), #' class = "haven_labelled" #' ) |> is.labelled() -is.labelled <- function(x, classes = c("redcapcast_labelled", "haven_labelled", "labelled")) { +is.labelled <- function(x, classes = c("haven_labelled", "labelled")) { classes |> sapply(\(.class){ inherits(x, .class) @@ -166,7 +162,6 @@ is.labelled <- function(x, classes = c("redcapcast_labelled", "haven_labelled", any() } - replace_with <- function(x, from, to) { stopifnot(length(from) == length(to)) @@ -200,20 +195,25 @@ replace_with <- function(x, from, to) { #' @param na.label character string to refactor NA values. Default is NULL. #' @param na.value new value for NA strings. Ignored if na.label is NULL. #' Default is 99. +#' @param sort.numeric sort factor levels if levels are numeric. Default is TRUE #' #' @return named vector #' @export #' #' @examples -#' \dontrun{ #' structure(c(1, 2, 3, 2, 10, 9), #' labels = c(Unknown = 9, Refused = 10), #' class = "haven_labelled" #' ) |> #' as_factor() |> #' named_levels() -#' } -named_levels <- function(data, label = "labels", na.label = NULL, na.value = 99) { +#' structure(c(1, 2, 3, 2, 10, 9), +#' labels = c(Unknown = 9, Refused = 10), +#' class = "labelled" +#' ) |> +#' as_factor() |> +#' named_levels() +named_levels <- function(data, label = "labels", na.label = NULL, na.value = 99, sort.numeric=TRUE) { stopifnot(is.factor(data)) if (!is.null(na.label)) { attrs <- attributes(data) @@ -245,7 +245,6 @@ named_levels <- function(data, label = "labels", na.label = NULL, na.value = 99) ) } - # Handle empty factors if (all_na(data)) { d <- data.frame( @@ -280,7 +279,7 @@ named_levels <- function(data, label = "labels", na.label = NULL, na.value = 99) out <- stats::setNames(d$value, d$name) ## Sort if levels are numeric ## Else, they appear in order of appearance - if (possibly_numeric(levels(data))) { + if (possibly_numeric(levels(data)) && sort.numeric) { out <- out |> sort() } out @@ -334,19 +333,14 @@ possibly_roman <- function(data) { #' as_factor() |> #' fct2num() #' -#' # Outlier with labels, but no class of origin, handled like numeric vector -#' # structure(c(1, 2, 3, 2, 10, 9), -#' # labels = c(Unknown = 9, Refused = 10) -#' # ) |> -#' # as_factor() |> -#' # fct2num() -#' -#' v <- sample(6:19, 20, TRUE) |> factor() -#' dput(v) -#' named_levels(v) -#' fct2num(v) +#' structure(c(1, 2, 3, 2, 10, 9), +#' labels = c(Unknown = 9, Refused = 10) +#' ) |> +#' as_factor() |> +#' fct2num() fct2num <- function(data) { stopifnot(is.factor(data)) + if (is.character(named_levels(data))) { values <- as.numeric(named_levels(data)) } else { @@ -357,15 +351,28 @@ fct2num <- function(data) { ## If no NA on numeric coercion, of original names, then return ## original numeric names, else values - if (possibly_numeric(out)) { + if (possibly_numeric(names(out))) { out <- as.numeric(names(out)) } unname(out) } +#' Tests if vector can be interpreted as numeric without introducing NAs by +#' coercion +#' +#' @param data vector +#' +#' @return logical +#' @export +#' +#' @examples +#' c("1","5") |> possibly_numeric() +#' c("1","5","e") |> possibly_numeric() possibly_numeric <- function(data) { - length(stats::na.omit(suppressWarnings(as.numeric(names(data))))) == + suppressWarnings( + length(stats::na.omit(as.numeric(data))) == length(data) + ) } #' Extract attribute. Returns NA if none diff --git a/R/easy_redcap.R b/R/easy_redcap.R index 18c9c12..11b5cff 100644 --- a/R/easy_redcap.R +++ b/R/easy_redcap.R @@ -1,15 +1,22 @@ #' Retrieve project API key if stored, if not, set and retrieve #' +#' @description +#' Attempting to make secure API key storage so simple, that no other way makes +#' sense. Wrapping \link[keyring]{key_get} and \link[keyring]{key_set} using the +#' \link[keyring]{key_list} to check if key is in storage already. +#' +#' #' @param key.name character vector of key name +#' @param ... passed to \link[keyring]{key_set} #' #' @return character vector #' @importFrom keyring key_list key_get key_set #' @export -get_api_key <- function(key.name) { +get_api_key <- function(key.name, ...) { if (key.name %in% keyring::key_list()$service) { keyring::key_get(service = key.name) } else { - keyring::key_set(service = key.name, prompt = "Provide REDCap API key:") + keyring::key_set(service = key.name, ...) keyring::key_get(service = key.name) } } @@ -18,15 +25,21 @@ get_api_key <- function(key.name) { #' Secure API key storage and data acquisition in one #' #' @param project.name The name of the current project (for key storage with -#' `keyring::key_set()`, using the default keyring) +#' \link[keyring]{key_set}, using the default keyring) #' @param widen.data argument to widen the exported data #' @param uri REDCap database API uri -#' @param ... arguments passed on to `REDCapCAST::read_redcap_tables()` +#' @param ... arguments passed on to \link[REDCapCAST]{read_redcap_tables}. #' #' @return data.frame or list depending on widen.data #' @export +#' +#' @examples +#' \dontrun{ +#' easy_redcap("My_new_project",fields=c("record_id","age","hypertension")) +#' } easy_redcap <- function(project.name, widen.data = TRUE, uri, ...) { - key <- get_api_key(key.name = paste0(project.name, "_REDCAP_API")) + key <- get_api_key(key.name = paste0(project.name, "_REDCAP_API"), + prompt = "Provide REDCap API key:") out <- read_redcap_tables( uri = uri, diff --git a/R/read_redcap_tables.R b/R/read_redcap_tables.R index 5861296..79066cc 100644 --- a/R/read_redcap_tables.R +++ b/R/read_redcap_tables.R @@ -1,27 +1,33 @@ #' Download REDCap data #' -#' Implementation of REDCap_split with a focused data acquisition approach using -#' REDCapR::redcap_read and only downloading specified fields, forms and/or -#' events using the built-in focused_metadata including some clean-up. +#' @description +#' Implementation of passed on to \link[REDCapCAST]{REDCap_split} with a focused +#' data acquisition approach using passed on to \link[REDCapR]{redcap_read} and +#' only downloading specified fields, forms and/or events using the built-in +#' focused_metadata including some clean-up. #' Works with classical and longitudinal projects with or without repeating #' instruments. +#' Will preserve metadata in the data.frames as labels. +#' #' @param uri REDCap database API uri #' @param token API token #' @param records records to download #' @param fields fields to download #' @param events events to download #' @param forms forms to download -#' @param raw_or_label raw or label tags. Can be +#' @param raw_or_label raw or label tags. Can be "raw", "label" or "both". #' -#' * "raw": Standard [REDCapR] method to get raw values. -#' * "label": Standard [REDCapR] method to get label values. +#' * "raw": Standard \link[REDCapR]{redcap_read} method to get raw values. +#' * "label": Standard \link[REDCapR]{redcap_read} method to get label values. #' * "both": Get raw values with REDCap labels applied as labels. Use -#' [as_factor()] to format factors with original labels and use the -#' [gtsummary] package to easily get beautiful tables with original labels -#' from REDCap. Use [fct_drop()] to drop empty levels. +#' \link[REDCapCAST]{as_factor} to format factors with original labels and use +#' the `gtsummary` package functions like \link[gtsummary]{tbl_summary} to +#' easily get beautiful tables with original labels from REDCap. Use +#' \link[REDCapCAST]{fct_drop} to drop empty levels. #' #' @param split_forms Whether to split "repeating" or "all" forms, default is #' all. +#' @param ... passed on to \link[REDCapR]{redcap_read} #' #' @return list of instruments #' @importFrom REDCapR redcap_metadata_read redcap_read redcap_event_instruments @@ -36,8 +42,12 @@ read_redcap_tables <- function(uri, fields = NULL, events = NULL, forms = NULL, - raw_or_label = "label", - split_forms = "all") { + raw_or_label = c("raw","label","both"), + split_forms = "all", + ...) { + + raw_or_label <- match.arg(raw_or_label, c("raw","label","both")) + # Getting metadata m <- REDCapR::redcap_metadata_read(redcap_uri = uri, token = token)[["data"]] @@ -92,7 +102,8 @@ read_redcap_tables <- function(uri, events = events, forms = forms, records = records, - raw_or_label = rorl + raw_or_label = rorl, + ... )[["data"]] if (raw_or_label=="both"){ @@ -147,6 +158,20 @@ clean_field_label <- function(data) { } +#' Converts REDCap choices to factor levels and stores in labels attribute +#' +#' @description +#' Applying \link[REDCapCAST]{as_factor} to the data.frame or variable, will +#' coerce to a factor. +#' +#' @param data vector +#' @param meta vector of REDCap choices +#' +#' @return vector of class "labelled" with a "labels" attribute +#' @export +#' +#' @examples +#' format_redcap_factor(sample(1:3,20,TRUE),"1, First. | 2, second | 3, THIRD") format_redcap_factor <- function(data, meta) { lvls <- strsplit(meta, " | ", fixed = TRUE) |> unlist() |> @@ -158,7 +183,7 @@ format_redcap_factor <- function(data, meta) { Reduce(c, .x) })() set_attr(data, label = lvls, attr = "labels") |> - set_attr(data, label = "redcapcast_labelled", attr = "class") + set_attr(data, label = "labelled", attr = "class") }