andreas/REDCapCAST
1
0
Fork 0
mirror of https://github.com/agdamsbo/REDCapCAST.git synced 2026-06-21 05:59:07 +02:00
Code Issues Projects Releases Packages Wiki Activity

working to submit to cran

Browse source
This commit is contained in:
AG Damsbo 2023-01-16 09:49:17 +01:00
commit be3969d007
11 changed files with 200 additions and 265 deletions
Download patch file Download diff file Expand all files Collapse all files

68
R/REDCap_split.r
View file

@ -82,12 +82,11 @@
REDCap_split <- function(records,
metadata,
primary_table_name = "",
forms = c("repeating", "all")
) {
forms = c("repeating", "all")) {
# Process user input
records <- process_user_input(records)
metadata <- as.data.frame(process_user_input(metadata)) # See issue #12
metadata <-
as.data.frame(process_user_input(metadata)) # See issue #12
# Get the variable names in the dataset
vars_in_data <- names(records)
@ -96,12 +95,13 @@ REDCap_split <- function(records,
forms <- match.arg(forms)
# Check to see if there were any repeating instruments
if (forms == "repeating" && !"redcap_repeat_instrument" %in% vars_in_data) {
if (forms == "repeating" &&
!"redcap_repeat_instrument" %in% vars_in_data) {
stop("There are no repeating instruments in this dataset.")
}
# Remove NAs from `redcap_repeat_instrument` (see issue #12)
if(any(is.na(records$redcap_repeat_instrument))) {
if (any(is.na(records$redcap_repeat_instrument))) {
records$redcap_repeat_instrument <- ifelse(
is.na(records$redcap_repeat_instrument),
"",
@ -113,7 +113,8 @@ REDCap_split <- function(records,
names(metadata) <- metadata_names
# Make sure that no metadata columns are factors
metadata <- rapply(metadata, as.character, classes = "factor", how = "replace")
metadata <-
rapply(metadata, as.character, classes = "factor", how = "replace")
# Find the fields and associated form
fields <- match_fields_to_form(metadata, vars_in_data)
@ -131,22 +132,23 @@ REDCap_split <- function(records,
if ("redcap_repeat_instrument" %in% vars_in_data) {
# Variables to be at the beginning of each repeating instrument
repeat_instrument_fields <- grep(
"^redcap_repeat.*",
vars_in_data,
value = TRUE
)
repeat_instrument_fields <- grep("^redcap_repeat.*",
vars_in_data,
value = TRUE)
# Identify the subtables in the data
subtables <- unique(records$redcap_repeat_instrument)
subtables <- subtables[subtables != ""]
# Split the table based on instrument
out <- split.data.frame(records, records$redcap_repeat_instrument)
out <-
split.data.frame(records, records$redcap_repeat_instrument)
primary_table_index <- which(names(out) == "")
if (forms == "repeating" && primary_table_name %in% subtables) {
warning("The label given to the primary table is already used by a repeating instrument. The primary table label will be left blank.")
warning(
"The label given to the primary table is already used by a repeating instrument. The primary table label will be left blank."
)
primary_table_name <- ""
} else if (primary_table_name > "") {
names(out)[[primary_table_index]] <- primary_table_name
@ -154,26 +156,16 @@ REDCap_split <- function(records,
# Delete the variables that are not relevant
for (i in names(out)) {
if (i == primary_table_name) {
out_fields <- which(
vars_in_data %in% c(
universal_fields,
fields[!fields[,2] %in% subtables, 1]
)
)
out[[primary_table_index]] <- out[[primary_table_index]][out_fields]
out_fields <- which(vars_in_data %in% c(universal_fields,
fields[!fields[, 2] %in% subtables, 1]))
out[[primary_table_index]] <-
out[[primary_table_index]][out_fields]
} else {
out_fields <- which(
vars_in_data %in% c(
universal_fields,
repeat_instrument_fields,
fields[fields[,2] == i, 1]
)
)
out_fields <- which(vars_in_data %in% c(universal_fields,
repeat_instrument_fields,
fields[fields[, 2] == i, 1]))
out[[i]] <- out[[i]][out_fields]
}
@ -181,20 +173,14 @@ REDCap_split <- function(records,
}
if (forms == "all") {
out <- c(
split_non_repeating_forms(
out[[primary_table_index]],
universal_fields,
fields[!fields[,2] %in% subtables,]
),
out[-primary_table_index]
)
out <- c(split_non_repeating_forms(out[[primary_table_index]],
universal_fields,
fields[!fields[, 2] %in% subtables, ]),
out[-primary_table_index])
}
} else {
out <- split_non_repeating_forms(records, universal_fields, fields)
}

2
R/process_user_input.r
View file

@ -17,7 +17,6 @@ process_user_input.data.frame <- function(x, ...) {
}
process_user_input.character <- function(x, ...) {
if (!requireNamespace("jsonlite", quietly = TRUE)) {
stop(
"The package 'jsonlite' is needed to convert ",
@ -35,7 +34,6 @@ process_user_input.character <- function(x, ...) {
}
process_user_input.response <- function(x, ...) {
process_user_input(rawToChar(x$content))
}

105
R/utils.r
View file

@ -1,9 +1,6 @@
match_fields_to_form <- function(metadata, vars_in_data) {
fields <- metadata[
!metadata$field_type %in% c("descriptive", "checkbox"),
c("field_name", "form_name")
]
fields <- metadata[!metadata$field_type %in% c("descriptive", "checkbox"),
c("field_name", "form_name")]
# Process instrument status fields
form_names <- unique(metadata$form_name)
@ -16,9 +13,9 @@ match_fields_to_form <- function(metadata, vars_in_data) {
fields <- rbind(fields, form_complete_fields)
# Process survey timestamps
timestamps <- intersect(vars_in_data, paste0(form_names, "_timestamp"))
timestamps <-
intersect(vars_in_data, paste0(form_names, "_timestamp"))
if (length(timestamps)) {
timestamp_fields <- data.frame(
field_name = timestamps,
form_name = sub("_timestamp$", "", timestamps),
@ -31,28 +28,21 @@ match_fields_to_form <- function(metadata, vars_in_data) {
# Process checkbox fields
if (any(metadata$field_type == "checkbox")) {
checkbox_basenames <- metadata[
metadata$field_type == "checkbox",
c("field_name", "form_name")
]
checkbox_basenames <- metadata[metadata$field_type == "checkbox",
c("field_name", "form_name")]
checkbox_fields <-
do.call(
"rbind",
apply(
checkbox_basenames,
1,
function(x, y)
data.frame(
field_name = y[grepl(paste0("^", x[1], "___((?!\\.factor).)+$"), y, perl = TRUE)],
form_name = x[2],
stringsAsFactors = FALSE,
row.names = NULL
),
y = vars_in_data
)
)
do.call("rbind",
apply(checkbox_basenames,
1,
function(x, y)
data.frame(
field_name = y[grepl(paste0("^", x[1], "___((?!\\.factor).)+$"), y, perl = TRUE)],
form_name = x[2],
stringsAsFactors = FALSE,
row.names = NULL
),
y = vars_in_data))
fields <- rbind(fields, checkbox_fields)
@ -60,26 +50,21 @@ match_fields_to_form <- function(metadata, vars_in_data) {
# Process ".*\\.factor" fields supplied by REDCap's export data R script
if (any(grepl("\\.factor$", vars_in_data))) {
factor_fields <-
do.call(
"rbind",
apply(
fields,
1,
function(x, y) {
field_indices <- grepl(paste0("^", x[1], "\\.factor$"), y)
if (any(field_indices))
data.frame(
field_name = y[field_indices],
form_name = x[2],
stringsAsFactors = FALSE,
row.names = NULL
)
},
y = vars_in_data
)
)
do.call("rbind",
apply(fields,
1,
function(x, y) {
field_indices <- grepl(paste0("^", x[1], "\\.factor$"), y)
if (any(field_indices))
data.frame(
field_name = y[field_indices],
form_name = x[2],
stringsAsFactors = FALSE,
row.names = NULL
)
},
y = vars_in_data))
fields <- rbind(fields, factor_fields)
@ -87,20 +72,18 @@ match_fields_to_form <- function(metadata, vars_in_data) {
fields
}
split_non_repeating_forms <- function(table, universal_fields, fields) {
forms <- unique(fields[[2]])
x <- lapply(
forms,
function (x) {
table[names(table) %in% union(universal_fields, fields[fields[,2] == x,1])]
})
structure(x, names = forms)
}
split_non_repeating_forms <-
function(table, universal_fields, fields) {
forms <- unique(fields[[2]])
x <- lapply(forms,
function (x) {
table[names(table) %in% union(universal_fields, fields[fields[, 2] == x, 1])]
})
structure(x, names = forms)
}