mirror of
https://github.com/agdamsbo/REDCapCAST.git
synced 2026-06-19 05:07:30 +02:00
added option to export "both" raw and label by labelling raw data to preserve as much information as possible
This commit is contained in:
parent
57f9f23ece
commit
2ba46e8e7a
11 changed files with 177 additions and 230 deletions
165
R/easy_redcap.R
165
R/easy_redcap.R
|
|
@ -31,6 +31,7 @@ easy_redcap <- function(project.name, widen.data = TRUE, uri, ...) {
|
|||
out <- read_redcap_tables(
|
||||
uri = uri,
|
||||
token = key,
|
||||
raw_or_label = "both",
|
||||
...
|
||||
)
|
||||
|
||||
|
|
@ -40,167 +41,3 @@ easy_redcap <- function(project.name, widen.data = TRUE, uri, ...) {
|
|||
|
||||
out
|
||||
}
|
||||
|
||||
|
||||
#' REDCap read function to preserve field labels and all factor levels
|
||||
#'
|
||||
#' @description
|
||||
#' This works very much as `read_redcap_tables()` and might end up there
|
||||
#'
|
||||
#'
|
||||
#' @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 split_forms Whether to split "repeating" or "all" forms, default is
|
||||
#' "all".
|
||||
#'
|
||||
#' @return data.frame or list
|
||||
#' @export
|
||||
#'
|
||||
read_redcap_labelled <- function(uri,
|
||||
token,
|
||||
records = NULL,
|
||||
fields = NULL,
|
||||
events = NULL,
|
||||
forms = NULL,
|
||||
split_forms = "all") {
|
||||
m <-
|
||||
REDCapR::redcap_metadata_read(redcap_uri = uri, token = token)[["data"]]
|
||||
|
||||
# Tests
|
||||
if (!is.null(fields)) {
|
||||
fields_test <- fields %in% c(m$field_name, paste0(unique(m$form_name), "_complete"))
|
||||
|
||||
if (any(!fields_test)) {
|
||||
print(paste0(
|
||||
"The following field names are invalid: ",
|
||||
paste(fields[!fields_test], collapse = ", "), "."
|
||||
))
|
||||
stop("Not all supplied field names are valid")
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
if (!is.null(forms)) {
|
||||
forms_test <- forms %in% unique(m$form_name)
|
||||
|
||||
if (any(!forms_test)) {
|
||||
print(paste0(
|
||||
"The following form names are invalid: ",
|
||||
paste(forms[!forms_test], collapse = ", "), "."
|
||||
))
|
||||
stop("Not all supplied form names are valid")
|
||||
}
|
||||
}
|
||||
|
||||
if (!is.null(events)) {
|
||||
arm_event_inst <- REDCapR::redcap_event_instruments(
|
||||
redcap_uri = uri,
|
||||
token = token
|
||||
)
|
||||
|
||||
event_test <- events %in% unique(arm_event_inst$data$unique_event_name)
|
||||
|
||||
if (any(!event_test)) {
|
||||
print(paste0(
|
||||
"The following event names are invalid: ",
|
||||
paste(events[!event_test], collapse = ", "), "."
|
||||
))
|
||||
stop("Not all supplied event names are valid")
|
||||
}
|
||||
}
|
||||
|
||||
# Getting dataset
|
||||
d <- REDCapR::redcap_read(
|
||||
redcap_uri = uri,
|
||||
token = token,
|
||||
fields = fields,
|
||||
events = events,
|
||||
forms = forms,
|
||||
records = records,
|
||||
raw_or_label = "raw"
|
||||
)[["data"]]
|
||||
|
||||
# Applying labels
|
||||
d <- purrr::imap(d, \(.x, .i){
|
||||
if (.i %in% m$field_name) {
|
||||
# Does not handle checkboxes
|
||||
out <- set_attr(.x,
|
||||
label = clean_field_label(m$field_label[m$field_name == .i]),
|
||||
attr = "label"
|
||||
)
|
||||
out
|
||||
} else {
|
||||
.x
|
||||
}
|
||||
}) |> dplyr::bind_cols()
|
||||
|
||||
d <- purrr::imap(d, \(.x, .i){
|
||||
if (any(c("radio", "dropdown") %in% m$field_type[m$field_name == .i])) {
|
||||
format_redcap_factor(.x, m$select_choices_or_calculations[m$field_name == .i])
|
||||
} else {
|
||||
.x
|
||||
}
|
||||
}) |> dplyr::bind_cols()
|
||||
|
||||
# Process repeat instrument naming
|
||||
# Removes any extra characters other than a-z, 0-9 and "_", to mimic raw
|
||||
# instrument names.
|
||||
if ("redcap_repeat_instrument" %in% names(d)) {
|
||||
d$redcap_repeat_instrument <- clean_redcap_name(d$redcap_repeat_instrument)
|
||||
}
|
||||
|
||||
# Processing metadata to reflect focused dataset
|
||||
m <- focused_metadata(m, names(d))
|
||||
|
||||
# Splitting
|
||||
out <- REDCap_split(d,
|
||||
m,
|
||||
forms = split_forms,
|
||||
primary_table_name = ""
|
||||
)
|
||||
|
||||
sanitize_split(out)
|
||||
}
|
||||
|
||||
|
||||
#' Very simple function to remove rich text formatting from field label
|
||||
#' and save the first paragraph ('<p>...</p>').
|
||||
#'
|
||||
#' @param data field label
|
||||
#'
|
||||
#' @return character vector
|
||||
#' @export
|
||||
#'
|
||||
#' @examples
|
||||
#' clean_field_label("<div class=\"rich-text-field-label\"><p>Fazekas score</p></div>")
|
||||
clean_field_label <- function(data) {
|
||||
out <- data |>
|
||||
lapply(\(.x){
|
||||
unlist(strsplit(.x, "</"))[1]
|
||||
}) |>
|
||||
lapply(\(.x){
|
||||
splt <- unlist(strsplit(.x, ">"))
|
||||
splt[length(splt)]
|
||||
})
|
||||
Reduce(c, out)
|
||||
}
|
||||
|
||||
|
||||
format_redcap_factor <- function(data, meta) {
|
||||
lvls <- strsplit(meta, " | ", fixed = TRUE) |>
|
||||
unlist() |>
|
||||
lapply(\(.x){
|
||||
splt <- unlist(strsplit(.x, ", "))
|
||||
stats::setNames(splt[1], nm = paste(splt[-1], collapse = ", "))
|
||||
}) |>
|
||||
(\(.x){
|
||||
Reduce(c, .x)
|
||||
})()
|
||||
set_attr(data, label = lvls, attr = "labels") |>
|
||||
set_attr(data, label = "labelled", attr = "class") |>
|
||||
as_factor()
|
||||
}
|
||||
|
|
|
|||
|
|
@ -11,7 +11,15 @@
|
|||
#' @param fields fields to download
|
||||
#' @param events events to download
|
||||
#' @param forms forms to download
|
||||
#' @param raw_or_label raw or label tags
|
||||
#' @param raw_or_label raw or label tags. Can be
|
||||
#'
|
||||
#' * "raw": Standard [REDCapR] method to get raw values.
|
||||
#' * "label": Standard [REDCapR] 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.
|
||||
#'
|
||||
#' @param split_forms Whether to split "repeating" or "all" forms, default is
|
||||
#' all.
|
||||
#'
|
||||
|
|
@ -70,6 +78,12 @@ read_redcap_tables <- function(uri,
|
|||
}
|
||||
}
|
||||
|
||||
if (raw_or_label=="both"){
|
||||
rorl <- "raw"
|
||||
} else {
|
||||
rorl <- raw_or_label
|
||||
}
|
||||
|
||||
# Getting dataset
|
||||
d <- REDCapR::redcap_read(
|
||||
redcap_uri = uri,
|
||||
|
|
@ -78,9 +92,16 @@ read_redcap_tables <- function(uri,
|
|||
events = events,
|
||||
forms = forms,
|
||||
records = records,
|
||||
raw_or_label = raw_or_label
|
||||
raw_or_label = rorl
|
||||
)[["data"]]
|
||||
|
||||
if (raw_or_label=="both"){
|
||||
d <- apply_field_label(data=d,meta=m)
|
||||
|
||||
d <- apply_factor_labels(data=d,meta=m)
|
||||
}
|
||||
|
||||
|
||||
# Process repeat instrument naming
|
||||
# Removes any extra characters other than a-z, 0-9 and "_", to mimic raw
|
||||
# instrument names.
|
||||
|
|
@ -101,3 +122,84 @@ read_redcap_tables <- function(uri,
|
|||
|
||||
sanitize_split(out)
|
||||
}
|
||||
|
||||
|
||||
#' Very simple function to remove rich text formatting from field label
|
||||
#' and save the first paragraph ('<p>...</p>').
|
||||
#'
|
||||
#' @param data field label
|
||||
#'
|
||||
#' @return character vector
|
||||
#' @export
|
||||
#'
|
||||
#' @examples
|
||||
#' clean_field_label("<div class=\"rich-text-field-label\"><p>Fazekas score</p></div>")
|
||||
clean_field_label <- function(data) {
|
||||
out <- data |>
|
||||
lapply(\(.x){
|
||||
unlist(strsplit(.x, "</"))[1]
|
||||
}) |>
|
||||
lapply(\(.x){
|
||||
splt <- unlist(strsplit(.x, ">"))
|
||||
splt[length(splt)]
|
||||
})
|
||||
Reduce(c, out)
|
||||
}
|
||||
|
||||
|
||||
format_redcap_factor <- function(data, meta) {
|
||||
lvls <- strsplit(meta, " | ", fixed = TRUE) |>
|
||||
unlist() |>
|
||||
lapply(\(.x){
|
||||
splt <- unlist(strsplit(.x, ", "))
|
||||
stats::setNames(splt[1], nm = paste(splt[-1], collapse = ", "))
|
||||
}) |>
|
||||
(\(.x){
|
||||
Reduce(c, .x)
|
||||
})()
|
||||
set_attr(data, label = lvls, attr = "labels") |>
|
||||
set_attr(data, label = "redcapcast_labelled", attr = "class")
|
||||
}
|
||||
|
||||
|
||||
|
||||
#' Apply REDCap filed labels to data frame
|
||||
#'
|
||||
#' @param data REDCap exported data set
|
||||
#' @param meta REDCap data dictionary
|
||||
#'
|
||||
#' @return data.frame
|
||||
#' @export
|
||||
#'
|
||||
apply_field_label <- function(data,meta){
|
||||
purrr::imap(data, \(.x, .i){
|
||||
if (.i %in% meta$field_name) {
|
||||
# Does not handle checkboxes
|
||||
out <- set_attr(.x,
|
||||
label = clean_field_label(meta$field_label[meta$field_name == .i]),
|
||||
attr = "label"
|
||||
)
|
||||
out
|
||||
} else {
|
||||
.x
|
||||
}
|
||||
}) |> dplyr::bind_cols()
|
||||
}
|
||||
|
||||
#' Preserve all factor levels from REDCap data dictionary in data export
|
||||
#'
|
||||
#' @param data REDCap exported data set
|
||||
#' @param meta REDCap data dictionary
|
||||
#'
|
||||
#' @return data.frame
|
||||
#' @export
|
||||
#'
|
||||
apply_factor_labels <- function(data,meta){
|
||||
purrr::imap(data, \(.x, .i){
|
||||
if (any(c("radio", "dropdown") %in% meta$field_type[meta$field_name == .i])) {
|
||||
format_redcap_factor(.x, meta$select_choices_or_calculations[meta$field_name == .i])
|
||||
} else {
|
||||
.x
|
||||
}
|
||||
}) |> dplyr::bind_cols()
|
||||
}
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue