andreas/REDCapCAST
1
0
Fork 0
mirror of https://github.com/agdamsbo/REDCapCAST.git synced 2025-04-01 21:52:32 +02:00
Code Issues Packages Projects Releases Wiki Activity

allows not splitting data

Browse Source
This commit is contained in:
Andreas Gammelgaard Damsbo 2025-03-05 13:40:56 +01:00
parent 2e1e7822a4
commit 0b5319f647
No known key found for this signature in database
1 changed files with 37 additions and 32 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

69
R/read_redcap_tables.R
View File

@ -26,7 +26,7 @@
#' \link[REDCapCAST]{fct_drop} to drop empty levels. #' \link[REDCapCAST]{fct_drop} to drop empty levels.
#' #'
#' @param split_forms Whether to split "repeating" or "all" forms, default is #' @param split_forms Whether to split "repeating" or "all" forms, default is
#' all. #' all. Give "none" to export native semi-long REDCap format
#' @param ... passed on to \link[REDCapR]{redcap_read} #' @param ... passed on to \link[REDCapR]{redcap_read}
#' #'
#' @return list of instruments #' @return list of instruments
@ -42,22 +42,24 @@ read_redcap_tables <- function(uri,
fields = NULL, fields = NULL,
events = NULL, events = NULL,
forms = NULL, forms = NULL,
raw_or_label = c("raw","label","both"), raw_or_label = c("raw", "label", "both"),
split_forms = "all", split_forms = c("all", "repeating", "none"),
...) { ...) {
raw_or_label <- match.arg(raw_or_label, c("raw", "label", "both"))
raw_or_label <- match.arg(raw_or_label, c("raw","label","both")) split_forms <- match.arg(split_forms)
# Getting metadata # Getting metadata
m <- m <-
REDCapR::redcap_metadata_read(redcap_uri = uri, token = token)[["data"]] REDCapR::redcap_metadata_read(redcap_uri = uri, token = token)[["data"]]
if (!is.null(fields)) { if (!is.null(fields)) {
fields_test <- fields %in% c(m$field_name,paste0(unique(m$form_name),"_complete")) fields_test <- fields %in% c(m$field_name, paste0(unique(m$form_name), "_complete"))
if (any(!fields_test)) { if (any(!fields_test)) {
print(paste0("The following field names are invalid: ", print(paste0(
paste(fields[!fields_test], collapse = ", "), ".")) "The following field names are invalid: ",
paste(fields[!fields_test], collapse = ", "), "."
))
stop("Not all supplied field names are valid") stop("Not all supplied field names are valid")
} }
} }
@ -67,8 +69,10 @@ read_redcap_tables <- function(uri,
forms_test <- forms %in% unique(m$form_name) forms_test <- forms %in% unique(m$form_name)
if (any(!forms_test)) { if (any(!forms_test)) {
print(paste0("The following form names are invalid: ", print(paste0(
paste(forms[!forms_test], collapse = ", "), ".")) "The following form names are invalid: ",
paste(forms[!forms_test], collapse = ", "), "."
))
stop("Not all supplied form names are valid") stop("Not all supplied form names are valid")
} }
} }
@ -82,13 +86,15 @@ read_redcap_tables <- function(uri,
event_test <- events %in% unique(arm_event_inst$data$unique_event_name) event_test <- events %in% unique(arm_event_inst$data$unique_event_name)
if (any(!event_test)) { if (any(!event_test)) {
print(paste0("The following event names are invalid: ", print(paste0(
paste(events[!event_test], collapse = ", "), ".")) "The following event names are invalid: ",
paste(events[!event_test], collapse = ", "), "."
))
stop("Not all supplied event names are valid") stop("Not all supplied event names are valid")
} }
} }
if (raw_or_label=="both"){ if (raw_or_label == "both") {
rorl <- "raw" rorl <- "raw"
} else { } else {
rorl <- raw_or_label rorl <- raw_or_label
@ -106,10 +112,10 @@ read_redcap_tables <- function(uri,
... ...
)[["data"]] )[["data"]]
if (raw_or_label=="both"){ if (raw_or_label == "both") {
d <- apply_field_label(data=d,meta=m) d <- apply_field_label(data = d, meta = m)
d <- apply_factor_labels(data=d,meta=m) d <- apply_factor_labels(data = d, meta = m)
} }
@ -123,15 +129,16 @@ read_redcap_tables <- function(uri,
# Processing metadata to reflect focused dataset # Processing metadata to reflect focused dataset
m <- focused_metadata(m, names(d)) m <- focused_metadata(m, names(d))
# Splitting # Splitting
out <- REDCap_split(d, if (split_forms != "none") {
m, REDCap_split(d,
forms = split_forms, m,
primary_table_name = "" forms = split_forms,
) primary_table_name = ""
) |> sanitize_split()
sanitize_split(out) } else {
d
}
} }
@ -171,7 +178,7 @@ clean_field_label <- function(data) {
#' @export #' @export
#' #'
#' @examples #' @examples
#' format_redcap_factor(sample(1:3,20,TRUE),"1, First. | 2, second | 3, THIRD") #' format_redcap_factor(sample(1:3, 20, TRUE), "1, First. | 2, second | 3, THIRD")
format_redcap_factor <- function(data, meta) { format_redcap_factor <- function(data, meta) {
lvls <- strsplit(meta, " | ", fixed = TRUE) |> lvls <- strsplit(meta, " | ", fixed = TRUE) |>
unlist() |> unlist() |>
@ -196,13 +203,13 @@ format_redcap_factor <- function(data, meta) {
#' @return data.frame #' @return data.frame
#' @export #' @export
#' #'
apply_field_label <- function(data,meta){ apply_field_label <- function(data, meta) {
purrr::imap(data, \(.x, .i){ purrr::imap(data, \(.x, .i){
if (.i %in% meta$field_name) { if (.i %in% meta$field_name) {
# Does not handle checkboxes # Does not handle checkboxes
out <- set_attr(.x, out <- set_attr(.x,
label = clean_field_label(meta$field_label[meta$field_name == .i]), label = clean_field_label(meta$field_label[meta$field_name == .i]),
attr = "label" attr = "label"
) )
out out
} else { } else {
@ -219,8 +226,8 @@ apply_field_label <- function(data,meta){
#' @return data.frame #' @return data.frame
#' @export #' @export
#' #'
apply_factor_labels <- function(data,meta=NULL){ apply_factor_labels <- function(data, meta = NULL) {
if (is.list(data) && !is.data.frame(data)){ if (is.list(data) && !is.data.frame(data)) {
meta <- data$meta meta <- data$meta
data <- data$data data <- data$data
} else if (is.null(meta)) { } else if (is.null(meta)) {
@ -234,5 +241,3 @@ apply_factor_labels <- function(data,meta=NULL){
} }
}) |> dplyr::bind_cols() }) |> dplyr::bind_cols()
} }