mirror of
https://github.com/agdamsbo/REDCapCAST.git
synced 2025-01-18 21:16:34 +01:00
adjusted docs
This commit is contained in:
parent
ea26d18c43
commit
5926c12da6
@ -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
|
||||
|
||||
@ -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,
|
||||
|
||||
@ -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")
|
||||
}
|
||||
|
||||
|
||||
|
||||
Loading…
x
Reference in New Issue
Block a user