andreas/REDCapCAST
1
0
Fork 0
mirror of https://github.com/agdamsbo/REDCapCAST.git synced 2024-11-22 05:20:23 +01:00
Code Issues Packages Projects Releases Wiki Activity

linting

Browse Source
This commit is contained in:
Andreas Gammelgaard Damsbo 2024-02-27 13:20:21 +01:00
parent a0730cb41c
commit 9e33057c06
32 changed files with 461 additions and 345 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

7
.lintr Normal file
View File

@ -0,0 +1,7 @@
linters: linters_with_defaults(
commented_code_linter = NULL
)
encoding: "UTF-8"
exclusions: list(
"drafting/"
)

93
R/REDCap_split.r
View File

@ -24,19 +24,19 @@
#' #'
#' # Get the records #' # Get the records
#' records <- postForm( #' records <- postForm(
#' uri = api_url, # Supply your site-specific URI #' uri = api_url, # Supply your site-specific URI
#' token = api_token, # Supply your own API token #' token = api_token, # Supply your own API token
#' content = 'record', #' content = "record",
#' format = 'json', #' format = "json",
#' returnFormat = 'json' #' returnFormat = "json"
#' ) #' )
#' #'
#' # Get the metadata #' # Get the metadata
#' metadata <- postForm( #' metadata <- postForm(
#' uri = api_url, # Supply your site-specific URI #' uri = api_url, # Supply your site-specific URI
#' token = api_token, # Supply your own API token #' token = api_token, # Supply your own API token
#' content = 'metadata', #' content = "metadata",
#' format = 'json' #' format = "json"
#' ) #' )
#' #'
#' # Convert exported JSON strings into a list of data.frames #' # Convert exported JSON strings into a list of data.frames
@ -49,7 +49,8 @@
#' #'
#' # Get the metadata #' # Get the metadata
#' metadata <- read.csv( #' metadata <- read.csv(
#' "/path/to/data/ExampleProject_DataDictionary_2018-06-03.csv") #' "/path/to/data/ExampleProject_DataDictionary_2018-06-03.csv"
#' )
#' #'
#' # Split the tables #' # Split the tables
#' REDCapRITS::REDCap_split(records, metadata) #' REDCapRITS::REDCap_split(records, metadata)
@ -86,9 +87,8 @@ REDCap_split <- function(records,
metadata, metadata,
primary_table_name = "", primary_table_name = "",
forms = c("repeating", "all")) { forms = c("repeating", "all")) {
# Process user input # Process user input
records <- process_user_input(records) records <- process_user_input(records)
metadata <- metadata <-
as.data.frame(process_user_input(metadata)) as.data.frame(process_user_input(metadata))
@ -96,26 +96,27 @@ REDCap_split <- function(records,
vars_in_data <- names(records) vars_in_data <- names(records)
# Process repeat instrument names to match the redcap naming # Process repeat instrument names to match the redcap naming
if (is_repeated_longitudinal(records)){ if (is_repeated_longitudinal(records)) {
records$redcap_repeat_instrument <- clean_redcap_name(records$redcap_repeat_instrument) records$redcap_repeat_instrument <-
clean_redcap_name(records$redcap_repeat_instrument)
# Match arg for forms # Match arg for forms
forms <- match.arg(forms, c("repeating", "all")) forms <- match.arg(forms, c("repeating", "all"))
# Check to see if there were any repeating instruments # Check to see if there were any repeating instruments
if (forms == "repeating" && if (forms == "repeating" &&
!"redcap_repeat_instrument" %in% vars_in_data) { !"redcap_repeat_instrument" %in% vars_in_data) {
stop("There are no repeating instruments in this dataset.") stop("There are no repeating instruments in this dataset.")
} }
# Remove NAs from `redcap_repeat_instrument` (see issue #12) # 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( records$redcap_repeat_instrument <- ifelse(
is.na(records$redcap_repeat_instrument), is.na(records$redcap_repeat_instrument),
"", "",
as.character(records$redcap_repeat_instrument) as.character(records$redcap_repeat_instrument)
) )
} }
} }
# Standardize variable names for metadata # Standardize variable names for metadata
@ -144,8 +145,9 @@ REDCap_split <- function(records,
if ("redcap_repeat_instrument" %in% vars_in_data) { if ("redcap_repeat_instrument" %in% vars_in_data) {
# Variables to be at the beginning of each repeating instrument # Variables to be at the beginning of each repeating instrument
repeat_instrument_fields <- grep("^redcap_repeat.*", repeat_instrument_fields <- grep("^redcap_repeat.*",
vars_in_data, vars_in_data,
value = TRUE) value = TRUE
)
# Identify the subtables in the data # Identify the subtables in the data
subtables <- unique(records$redcap_repeat_instrument) subtables <- unique(records$redcap_repeat_instrument)
@ -169,35 +171,36 @@ REDCap_split <- function(records,
# Delete the variables that are not relevant # Delete the variables that are not relevant
for (i in names(out)) { for (i in names(out)) {
if (i == primary_table_name) { if (i == primary_table_name) {
out_fields <- which(vars_in_data %in% c(universal_fields, out_fields <- which(vars_in_data %in% c(
fields[!fields[, 2] %in% universal_fields,
subtables, 1])) fields[!fields[, 2] %in%
subtables, 1]
))
out[[primary_table_index]] <- out[[primary_table_index]] <-
out[[primary_table_index]][out_fields] out[[primary_table_index]][out_fields]
} else { } else {
out_fields <- which(vars_in_data %in% c(universal_fields, out_fields <- which(vars_in_data %in% c(
repeat_instrument_fields, universal_fields,
fields[fields[, 2] == i, 1])) repeat_instrument_fields,
fields[fields[, 2] == i, 1]
))
out[[i]] <- out[[i]][out_fields] out[[i]] <- out[[i]][out_fields]
} }
} }
if (forms == "all") { if (forms == "all") {
out <- c(split_non_repeating_forms(out[[primary_table_index]], out <- c(
universal_fields, split_non_repeating_forms(
fields[!fields[, 2] %in% subtables, ]), out[[primary_table_index]],
out[-primary_table_index]) universal_fields,
fields[!fields[, 2] %in% subtables, ]
),
out[-primary_table_index]
)
} }
} else { } else {
out <- split_non_repeating_forms(records, universal_fields, fields) out <- split_non_repeating_forms(records, universal_fields, fields)
} }
out out
} }

6
R/ds2dd.R
View File

@ -41,7 +41,7 @@ ds2dd <-
dd <- data.frame(matrix(ncol = length(metadata), nrow = ncol(ds))) dd <- data.frame(matrix(ncol = length(metadata), nrow = ncol(ds)))
colnames(dd) <- metadata colnames(dd) <- metadata
if (is.character(record.id) & !record.id %in% colnames(ds)) { if (is.character(record.id) && !record.id %in% colnames(ds)) {
stop("Provided record.id is not a variable name in provided data set.") stop("Provided record.id is not a variable name in provided data set.")
} }
@ -59,7 +59,7 @@ ds2dd <-
dd[, "field_name"] <- dd[, "field_name"] <-
c(field.name[colsel], field.name[!colsel]) c(field.name[colsel], field.name[!colsel])
if (length(form.name) > 1 & length(form.name) != ncol(ds)) { if (length(form.name) > 1 && length(form.name) != ncol(ds)) {
stop( stop(
"Provided form.name should be of length 1 (value is reused) or equal "Provided form.name should be of length 1 (value is reused) or equal
length as number of variables in data set." length as number of variables in data set."
@ -67,7 +67,7 @@ ds2dd <-
} }
dd[, "form_name"] <- form.name dd[, "form_name"] <- form.name
if (length(field.type) > 1 & length(field.type) != ncol(ds)) { if (length(field.type) > 1 && length(field.type) != ncol(ds)) {
stop( stop(
"Provided field.type should be of length 1 (value is reused) or equal "Provided field.type should be of length 1 (value is reused) or equal
length as number of variables in data set." length as number of variables in data set."

91
R/ds2dd_detailed.R
View File

@ -1,4 +1,9 @@
utils::globalVariables(c( "stats::setNames", "field_name", "field_type", "select_choices_or_calculations")) utils::globalVariables(c(
"stats::setNames",
"field_name",
"field_type",
"select_choices_or_calculations"
))
#' Try at determining which are true time only variables #' Try at determining which are true time only variables
#' #'
#' @description #' @description
@ -18,10 +23,15 @@ utils::globalVariables(c( "stats::setNames", "field_name", "field_type", "se
#' @examples #' @examples
#' data <- redcapcast_data #' data <- redcapcast_data
#' data |> guess_time_only_filter() #' data |> guess_time_only_filter()
#' data |> guess_time_only_filter(validate = TRUE) |> lapply(head) #' data |>
guess_time_only_filter <- function(data, validate = FALSE, sel.pos = "[Tt]i[d(me)]", sel.neg = "[Dd]at[eo]") { #' guess_time_only_filter(validate = TRUE) |>
#' lapply(head)
guess_time_only_filter <- function(data,
validate = FALSE,
sel.pos = "[Tt]i[d(me)]",
sel.neg = "[Dd]at[eo]") {
datetime_nms <- data |> datetime_nms <- data |>
lapply(\(x)any(c("POSIXct","hms") %in% class(x))) |> lapply(\(x) any(c("POSIXct", "hms") %in% class(x))) |>
(\(x) names(data)[do.call(c, x)])() (\(x) names(data)[do.call(c, x)])()
time_only_log <- datetime_nms |> (\(x) { time_only_log <- datetime_nms |> (\(x) {
@ -42,12 +52,8 @@ guess_time_only_filter <- function(data, validate = FALSE, sel.pos = "[Tt]i[d(me
} }
} }
#' Correction based on time_only_filter function. Introduces new class for easier #' Correction based on time_only_filter function
#' validation labelling.
#' #'
#' @description
#' Dependens on the data class "hms" introduced with
#' `guess_time_only_filter()` and converts these
#' #'
#' @param data data set #' @param data data set
#' @param ... arguments passed on to `guess_time_only_filter()` #' @param ... arguments passed on to `guess_time_only_filter()`
@ -119,8 +125,8 @@ hms2character <- function(data) {
#' data set (imported .dta file with `haven::read_dta()`. Default is "label" #' data set (imported .dta file with `haven::read_dta()`. Default is "label"
#' @param field.validation manually specify field validation(s). Vector of #' @param field.validation manually specify field validation(s). Vector of
#' length 1 or ncol(data). Default is NULL and `levels()` are used for factors #' length 1 or ncol(data). Default is NULL and `levels()` are used for factors
#' or attribute `factor.labels.attr` for haven_labelled data set (imported .dta file with #' or attribute `factor.labels.attr` for haven_labelled data set (imported .dta
#' `haven::read_dta()`). #' file with `haven::read_dta()`).
#' @param metadata redcap metadata headings. Default is #' @param metadata redcap metadata headings. Default is
#' REDCapCAST:::metadata_names. #' REDCapCAST:::metadata_names.
#' @param validate.time Flag to validate guessed time columns #' @param validate.time Flag to validate guessed time columns
@ -144,7 +150,7 @@ ds2dd_detailed <- function(data,
form.name = NULL, form.name = NULL,
field.type = NULL, field.type = NULL,
field.label = NULL, field.label = NULL,
field.label.attr ="label", field.label.attr = "label",
field.validation = NULL, field.validation = NULL,
metadata = metadata_names, metadata = metadata_names,
validate.time = FALSE, validate.time = FALSE,
@ -164,7 +170,8 @@ ds2dd_detailed <- function(data,
} }
if (lapply(data, haven::is.labelled) |> (\(x)do.call(c, x))() |> any()) { if (lapply(data, haven::is.labelled) |> (\(x)do.call(c, x))() |> any()) {
message("Data seems to be imported with haven from a Stata (.dta) file and will be treated as such.") message("Data seems to be imported with haven from a Stata (.dta) file and
will be treated as such.")
data.source <- "dta" data.source <- "dta"
} else { } else {
data.source <- "" data.source <- ""
@ -172,18 +179,25 @@ ds2dd_detailed <- function(data,
## data classes ## data classes
### Only keeps the first class, as time fields (POSIXct/POSIXt) has two classes ### Only keeps the first class, as time fields (POSIXct/POSIXt) has two
### classes
if (data.source == "dta") { if (data.source == "dta") {
data_classes <- data_classes <-
data |> data |>
haven::as_factor() |> haven::as_factor() |>
time_only_correction(sel.pos = time.var.sel.pos, sel.neg = time.var.sel.neg) |> time_only_correction(
sel.pos = time.var.sel.pos,
sel.neg = time.var.sel.neg
) |>
lapply(\(x)class(x)[1]) |> lapply(\(x)class(x)[1]) |>
(\(x)do.call(c, x))() (\(x)do.call(c, x))()
} else { } else {
data_classes <- data_classes <-
data |> data |>
time_only_correction(sel.pos = time.var.sel.pos, sel.neg = time.var.sel.neg) |> time_only_correction(
sel.pos = time.var.sel.pos,
sel.neg = time.var.sel.neg
) |>
lapply(\(x)class(x)[1]) |> lapply(\(x)class(x)[1]) |>
(\(x)do.call(c, x))() (\(x)do.call(c, x))()
} }
@ -204,7 +218,7 @@ ds2dd_detailed <- function(data,
if (is.null(form.name)) { if (is.null(form.name)) {
dd$form_name <- "data" dd$form_name <- "data"
} else { } else {
if (length(form.name) == 1 | length(form.name) == nrow(dd)) { if (length(form.name) == 1 || length(form.name) == nrow(dd)) {
dd$form_name <- form.name dd$form_name <- form.name
} else { } else {
stop("Length of supplied 'form.name' has to be one (1) or ncol(data).") stop("Length of supplied 'form.name' has to be one (1) or ncol(data).")
@ -229,9 +243,11 @@ ds2dd_detailed <- function(data,
} }
dd <- dd <-
dd |> dplyr::mutate(field_label = dplyr::if_else(is.na(label), field_name, label)) dd |> dplyr::mutate(field_label = dplyr::if_else(is.na(label),
field_name, label
))
} else { } else {
if (length(field.label) == 1 | length(field.label) == nrow(dd)) { if (length(field.label) == 1 || length(field.label) == nrow(dd)) {
dd$field_label <- field.label dd$field_label <- field.label
} else { } else {
stop("Length of supplied 'field.label' has to be one (1) or ncol(data).") stop("Length of supplied 'field.label' has to be one (1) or ncol(data).")
@ -245,9 +261,11 @@ ds2dd_detailed <- function(data,
dd$field_type <- "text" dd$field_type <- "text"
dd <- dd <-
dd |> dplyr::mutate(field_type = dplyr::if_else(data_classes == "factor", "radio", field_type)) dd |> dplyr::mutate(field_type = dplyr::if_else(data_classes == "factor",
"radio", field_type
))
} else { } else {
if (length(field.type) == 1 | length(field.type) == nrow(dd)) { if (length(field.type) == 1 || length(field.type) == nrow(dd)) {
dd$field_type <- field.type dd$field_type <- field.type
} else { } else {
stop("Length of supplied 'field.type' has to be one (1) or ncol(data).") stop("Length of supplied 'field.type' has to be one (1) or ncol(data).")
@ -271,10 +289,11 @@ ds2dd_detailed <- function(data,
) )
) )
} else { } else {
if (length(field.validation) == 1 | length(field.validation) == nrow(dd)) { if (length(field.validation) == 1 || length(field.validation) == nrow(dd)) {
dd$text_validation_type_or_show_slider_number <- field.validation dd$text_validation_type_or_show_slider_number <- field.validation
} else { } else {
stop("Length of supplied 'field.validation' has to be one (1) or ncol(data).") stop("Length of supplied 'field.validation'
has to be one (1) or ncol(data).")
} }
} }
@ -300,7 +319,13 @@ ds2dd_detailed <- function(data,
## Re-factors to avoid confusion with missing levels ## Re-factors to avoid confusion with missing levels
## Assumes alle relevant levels are represented in the data ## Assumes alle relevant levels are represented in the data
re_fac <- factor(x) re_fac <- factor(x)
paste(paste(unique(as.numeric(re_fac)), levels(re_fac), sep = ", "), collapse = " | ") paste(
paste(unique(as.numeric(re_fac)),
levels(re_fac),
sep = ", "
),
collapse = " | "
)
} else { } else {
NA NA
} }
@ -319,7 +344,10 @@ ds2dd_detailed <- function(data,
list( list(
data = data |> data = data |>
time_only_correction(sel.pos = time.var.sel.pos, sel.neg = time.var.sel.neg) |> time_only_correction(
sel.pos = time.var.sel.pos,
sel.neg = time.var.sel.neg
) |>
hms2character() |> hms2character() |>
(\(x)stats::setNames(x, tolower(names(x))))(), (\(x)stats::setNames(x, tolower(names(x))))(),
meta = dd meta = dd
@ -333,11 +361,16 @@ ds2dd_detailed <- function(data,
#' @param ls output list from `ds2dd_detailed()` #' @param ls output list from `ds2dd_detailed()`
#' #'
#' @return list with `REDCapR::redcap_write()` results #' @return list with `REDCapR::redcap_write()` results
mark_complete <- function(upload, ls){ mark_complete <- function(upload, ls) {
data <- ls$data data <- ls$data
meta <- ls$meta meta <- ls$meta
forms <- unique(meta$form_name) forms <- unique(meta$form_name)
cbind(data[[1]][data[[1]] %in% upload$affected_ids], cbind(
data.frame(matrix(2,ncol=length(forms),nrow=upload$records_affected_count))) |> data[[1]][data[[1]] %in% upload$affected_ids],
stats::setNames(c(names(data)[1],paste0(forms,"_complete"))) data.frame(matrix(2,
ncol = length(forms),
nrow = upload$records_affected_count
))
) |>
stats::setNames(c(names(data)[1], paste0(forms, "_complete")))
} }

5
R/easy_redcap.R
View File

@ -1,4 +1,3 @@
#' Retrieve project API key if stored, if not, set and retrieve #' Retrieve project API key if stored, if not, set and retrieve
#' #'
#' @param key.name character vector of key name #' @param key.name character vector of key name
@ -26,7 +25,7 @@ get_api_key <- function(key.name) {
#' #'
#' @return data.frame or list depending on widen.data #' @return data.frame or list depending on widen.data
#' @export #' @export
easy_redcap <- function(project.name, widen.data=TRUE, uri, ...) { 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"))
out <- read_redcap_tables( out <- read_redcap_tables(
@ -35,7 +34,7 @@ easy_redcap <- function(project.name, widen.data=TRUE, uri, ...) {
... ...
) )
if (widen.data){ if (widen.data) {
out <- out |> redcap_wider() out <- out |> redcap_wider()
} }

1
R/mtcars_redcap.R
View File

@ -20,4 +20,3 @@
#' } #' }
#' @usage data(mtcars_redcap) #' @usage data(mtcars_redcap)
"mtcars_redcap" "mtcars_redcap"

4
R/process_user_input.r
View File

@ -1,4 +1,4 @@
process_user_input <- function (x) { process_user_input <- function(x) {
UseMethod("process_user_input", x) UseMethod("process_user_input", x)
} }
@ -30,10 +30,8 @@ process_user_input.character <- function(x, ...) {
} }
jsonlite::fromJSON(x) jsonlite::fromJSON(x)
} }
process_user_input.response <- function(x, ...) { process_user_input.response <- function(x, ...) {
process_user_input(rawToChar(x$content)) process_user_input(rawToChar(x$content))
} }

16
R/read_redcap_instrument.R
View File

@ -1,20 +1,22 @@
#' Convenience function to download complete instrument, using token storage in keyring. #' Convenience function to download complete instrument, using token storage
#' in keyring.
#' #'
#' @param key key name in standard keyring for token retrieval. #' @param key key name in standard keyring for token retrieval.
#' @param uri REDCap database API uri #' @param uri REDCap database API uri
#' @param instrument instrument name #' @param instrument instrument name
#' @param raw_or_label raw or label passed to `REDCapR::redcap_read()` #' @param raw_or_label raw or label passed to `REDCapR::redcap_read()`
#' @param id_name id variable name. Default is "record_id". #' @param id_name id variable name. Default is "record_id".
#' @param records specify the records to download. Index numbers. Numeric vector. #' @param records specify the records to download. Index numbers.
#' Numeric vector.
#' #'
#' @return data.frame #' @return data.frame
#' @export #' @export
read_redcap_instrument <- function(key, read_redcap_instrument <- function(key,
uri, uri,
instrument, instrument,
raw_or_label = "raw", raw_or_label = "raw",
id_name = "record_id", id_name = "record_id",
records = NULL) { records = NULL) {
REDCapCAST::read_redcap_tables( REDCapCAST::read_redcap_tables(
records = records, records = records,
uri = uri, token = keyring::key_get(key), uri = uri, token = keyring::key_get(key),

26
R/read_redcap_tables.R
View File

@ -38,7 +38,8 @@ read_redcap_tables <- function(uri,
fields_test <- fields %in% unique(m$field_name) fields_test <- fields %in% unique(m$field_name)
if (any(!fields_test)) { if (any(!fields_test)) {
print(paste0("The following field names are invalid: ", paste(fields[!fields_test], collapse = ", "), ".")) print(paste0("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")
} }
} }
@ -48,7 +49,8 @@ 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: ", paste(forms[!forms_test], collapse = ", "), ".")) print(paste0("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")
} }
} }
@ -62,7 +64,8 @@ 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: ", paste(events[!event_test], collapse = ", "), ".")) print(paste0("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")
} }
} }
@ -89,15 +92,12 @@ read_redcap_tables <- function(uri,
m <- focused_metadata(m, names(d)) m <- focused_metadata(m, names(d))
# Splitting # Splitting
out <- REDCap_split(d, out <- REDCap_split(d,
m, m,
forms = split_forms, forms = split_forms,
primary_table_name = "" primary_table_name = ""
) )
sanitize_split(out)
sanitize_split(out)
} }

189
R/redcap_wider.R
View File

@ -1,6 +1,8 @@
utils::globalVariables(c("redcap_wider", utils::globalVariables(c(
"event.glue", "redcap_wider",
"inst.glue")) "event.glue",
"inst.glue"
))
#' @title Redcap Wider #' @title Redcap Wider
#' @description Converts a list of REDCap data frames from long to wide format. #' @description Converts a list of REDCap data frames from long to wide format.
@ -16,42 +18,65 @@ utils::globalVariables(c("redcap_wider",
#' #'
#' @examples #' @examples
#' # Longitudinal #' # Longitudinal
#' list1 <- list(data.frame(record_id = c(1,2,1,2), #' list1 <- list(
#' redcap_event_name = c("baseline", "baseline", "followup", "followup"), #' data.frame(
#' age = c(25,26,27,28)), #' record_id = c(1, 2, 1, 2),
#' data.frame(record_id = c(1,2), #' redcap_event_name = c("baseline", "baseline", "followup", "followup"),
#' redcap_event_name = c("baseline", "baseline"), #' age = c(25, 26, 27, 28)
#' gender = c("male", "female"))) #' ),
#' data.frame(
#' record_id = c(1, 2),
#' redcap_event_name = c("baseline", "baseline"),
#' gender = c("male", "female")
#' )
#' )
#' redcap_wider(list1) #' redcap_wider(list1)
#' # Simpel with two instruments #' # Simpel with two instruments
#' list2 <- list(data.frame(record_id = c(1,2), #' list2 <- list(
#' age = c(25,26)), #' data.frame(
#' data.frame(record_id = c(1,2), #' record_id = c(1, 2),
#' gender = c("male", "female"))) #' age = c(25, 26)
#' ),
#' data.frame(
#' record_id = c(1, 2),
#' gender = c("male", "female")
#' )
#' )
#' redcap_wider(list2) #' redcap_wider(list2)
#' # Simple with single instrument #' # Simple with single instrument
#' list3 <- list(data.frame(record_id = c(1,2), #' list3 <- list(data.frame(
#' age = c(25,26))) #' record_id = c(1, 2),
#' age = c(25, 26)
#' ))
#' redcap_wider(list3) #' redcap_wider(list3)
#' # Longitudinal with repeatable instruments #' # Longitudinal with repeatable instruments
#' list4 <- list(data.frame(record_id = c(1,2,1,2), #' list4 <- list(
#' redcap_event_name = c("baseline", "baseline", "followup", "followup"), #' data.frame(
#' age = c(25,26,27,28)), #' record_id = c(1, 2, 1, 2),
#' data.frame(record_id = c(1,1,1,1,2,2,2,2), #' redcap_event_name = c("baseline", "baseline", "followup", "followup"),
#' redcap_event_name = c("baseline", "baseline", "followup", "followup", #' age = c(25, 26, 27, 28)
#' "baseline", "baseline", "followup", "followup"), #' ),
#' redcap_repeat_instrument = "walk", #' data.frame(
#' redcap_repeat_instance=c(1,2,1,2,1,2,1,2), #' record_id = c(1, 1, 1, 1, 2, 2, 2, 2),
#' dist = c(40, 32, 25, 33, 28, 24, 23, 36)), #' redcap_event_name = c(
#' data.frame(record_id = c(1,2), #' "baseline", "baseline", "followup", "followup",
#' redcap_event_name = c("baseline", "baseline"), #' "baseline", "baseline", "followup", "followup"
#' gender = c("male", "female"))) #' ),
#'redcap_wider(list4) #' redcap_repeat_instrument = "walk",
#' redcap_repeat_instance = c(1, 2, 1, 2, 1, 2, 1, 2),
#' dist = c(40, 32, 25, 33, 28, 24, 23, 36)
#' ),
#' data.frame(
#' record_id = c(1, 2),
#' redcap_event_name = c("baseline", "baseline"),
#' gender = c("male", "female")
#' )
#' )
#' redcap_wider(list4)
redcap_wider <- redcap_wider <-
function(data, function(data,
event.glue = "{.value}_{redcap_event_name}", event.glue = "{.value}_{redcap_event_name}",
inst.glue = "{.value}_{redcap_repeat_instance}") { inst.glue = "{.value}_{redcap_repeat_instance}") {
if (!is_repeated_longitudinal(data)) { if (!is_repeated_longitudinal(data)) {
if (is.list(data)) { if (is.list(data)) {
if (length(data) == 1) { if (length(data) == 1) {
@ -59,69 +84,65 @@ redcap_wider <-
} else { } else {
out <- data |> purrr::reduce(dplyr::left_join) out <- data |> purrr::reduce(dplyr::left_join)
} }
} else if (is.data.frame(data)){ } else if (is.data.frame(data)) {
out <- data out <- data
} }
} else { } else {
id.name <- do.call(c, lapply(data, names))[[1]]
id.name <- do.call(c, lapply(data, names))[[1]] l <- lapply(data, function(i) {
rep_inst <- "redcap_repeat_instrument" %in% names(i)
l <- lapply(data, function(i) { if (rep_inst) {
rep_inst <- "redcap_repeat_instrument" %in% names(i) k <- lapply(split(i, f = i[[id.name]]), function(j) {
cname <- colnames(j)
if (rep_inst) { vals <-
k <- lapply(split(i, f = i[[id.name]]), function(j) { cname[!cname %in% c(
cname <- colnames(j) id.name,
vals <- "redcap_event_name",
cname[!cname %in% c( "redcap_repeat_instrument",
id.name, "redcap_repeat_instance"
"redcap_event_name", )]
"redcap_repeat_instrument", s <- tidyr::pivot_wider(
"redcap_repeat_instance" j,
)] names_from = "redcap_repeat_instance",
s <- tidyr::pivot_wider( values_from = all_of(vals),
j, names_glue = inst.glue
names_from = "redcap_repeat_instance", )
values_from = all_of(vals), s[!colnames(s) %in% c("redcap_repeat_instrument")]
names_glue = inst.glue })
) i <- Reduce(dplyr::bind_rows, k)
s[!colnames(s) %in% c("redcap_repeat_instrument")]
})
i <- Reduce(dplyr::bind_rows, k)
}
event <- "redcap_event_name" %in% names(i)
if (event) {
event.n <- length(unique(i[["redcap_event_name"]])) > 1
i[["redcap_event_name"]] <-
gsub(" ", "_", tolower(i[["redcap_event_name"]]))
if (event.n) {
cname <- colnames(i)
vals <- cname[!cname %in% c(id.name, "redcap_event_name")]
s <- tidyr::pivot_wider(
i,
names_from = "redcap_event_name",
values_from = all_of(vals),
names_glue = event.glue
)
s[colnames(s) != "redcap_event_name"]
} else {
i[colnames(i) != "redcap_event_name"]
}
} else {
i
} }
})
out <- data.frame(Reduce(f = dplyr::full_join, x = l)) event <- "redcap_event_name" %in% names(i)
if (event) {
event.n <- length(unique(i[["redcap_event_name"]])) > 1
i[["redcap_event_name"]] <-
gsub(" ", "_", tolower(i[["redcap_event_name"]]))
if (event.n) {
cname <- colnames(i)
vals <- cname[!cname %in% c(id.name, "redcap_event_name")]
s <- tidyr::pivot_wider(
i,
names_from = "redcap_event_name",
values_from = all_of(vals),
names_glue = event.glue
)
s[colnames(s) != "redcap_event_name"]
} else {
i[colnames(i) != "redcap_event_name"]
}
} else {
i
}
})
out <- data.frame(Reduce(f = dplyr::full_join, x = l))
} }
out out
} }

2
R/redcapcast_data.R
View File

@ -33,5 +33,3 @@
#' } #' }
#' @usage data(redcapcast_data) #' @usage data(redcapcast_data)
"redcapcast_data" "redcapcast_data"

8
R/redcapcast_meta.R
View File

@ -9,9 +9,11 @@
#' \item{section_header}{section_header, character} #' \item{section_header}{section_header, character}
#' \item{field_type}{field_type, character} #' \item{field_type}{field_type, character}
#' \item{field_label}{field_label, character} #' \item{field_label}{field_label, character}
#' \item{select_choices_or_calculations}{select_choices_or_calculations, character} #' \item{select_choices_or_calculations}
#' {select_choices_or_calculations, character}
#' \item{field_note}{field_note, character} #' \item{field_note}{field_note, character}
#' \item{text_validation_type_or_show_slider_number}{text_validation_type_or_show_slider_number, character} #' \item{text_validation_type_or_show_slider_number}
#' {text_validation_type_or_show_slider_number, character}
#' \item{text_validation_min}{text_validation_min, character} #' \item{text_validation_min}{text_validation_min, character}
#' \item{text_validation_max}{text_validation_max, character} #' \item{text_validation_max}{text_validation_max, character}
#' \item{identifier}{identifier, character} #' \item{identifier}{identifier, character}
@ -25,5 +27,3 @@
#' } #' }
#' @usage data(redcapcast_meta) #' @usage data(redcapcast_meta)
"redcapcast_meta" "redcapcast_meta"

7
R/shiny_cast.R
View File

@ -14,8 +14,7 @@ server_factory <- function() {
#' @export #' @export
ui_factory <- function() { ui_factory <- function() {
# require(ggplot2) # require(ggplot2)
source(here::here("app/ui.R")) source(here::here("app/ui.R"))
} }
#' Launch the included Shiny-app for database casting and upload #' Launch the included Shiny-app for database casting and upload
@ -46,7 +45,7 @@ shiny_cast <- function() {
#' @examples #' @examples
#' # deploy_shiny #' # deploy_shiny
#' #'
deploy_shiny <- function(path=here::here("app/"), name.app="shiny_cast"){ deploy_shiny <- function(path = here::here("app/"), name.app = "shiny_cast") {
# Connecting # Connecting
rsconnect::setAccountInfo( rsconnect::setAccountInfo(
name = "cognitiveindex", name = "cognitiveindex",
@ -55,5 +54,5 @@ deploy_shiny <- function(path=here::here("app/"), name.app="shiny_cast"){
) )
# Deploying # Deploying
rsconnect::deployApp(appDir = path,lint = TRUE,appName = name.app,) rsconnect::deployApp(appDir = path, lint = TRUE, appName = name.app, )
} }

25
R/utils.r
View File

@ -128,9 +128,11 @@ sanitize_split <- function(l,
"redcap_repeat_instrument", "redcap_repeat_instrument",
"redcap_repeat_instance" "redcap_repeat_instance"
)) { )) {
generic.names <- c(get_id_name(l), generic.names <- c(
generic.names, get_id_name(l),
paste0(names(l), "_complete")) generic.names,
paste0(names(l), "_complete")
)
lapply(l, function(i) { lapply(l, function(i) {
if (ncol(i) > 2) { if (ncol(i) > 2) {
@ -334,7 +336,8 @@ split_non_repeating_forms <-
#' @export #' @export
#' #'
#' @examples #' @examples
#' test <- c("12 months follow-up", "3 steps", "mRS 6 weeks", "Counting to 231 now") #' test <- c("12 months follow-up", "3 steps", "mRS 6 weeks",
#' "Counting to 231 now")
#' strsplitx(test, "[0-9]", type = "around") #' strsplitx(test, "[0-9]", type = "around")
strsplitx <- function(x, strsplitx <- function(x,
split, split,
@ -403,7 +406,8 @@ d2w <- function(x, lang = "en", neutrum = FALSE, everything = FALSE) {
# In Danish the written 1 depends on the counted word # In Danish the written 1 depends on the counted word
if (neutrum) nt <- "t" else nt <- "n" if (neutrum) nt <- "t" else nt <- "n"
# A sapply() call with nested lapply() to handle vectors, data.frames and lists # A sapply() call with nested lapply() to handle vectors, data.frames
# and lists
convert <- function(x, lang, neutrum) { convert <- function(x, lang, neutrum) {
zero_nine <- data.frame( zero_nine <- data.frame(
num = 0:9, num = 0:9,
@ -503,7 +507,9 @@ is_repeated_longitudinal <- function(data, generics = c(
#' @examples #' @examples
#' file_extension(list.files(here::here(""))[[2]])[[1]] #' file_extension(list.files(here::here(""))[[2]])[[1]]
file_extension <- function(filenames) { file_extension <- function(filenames) {
sub(pattern = "^(.*\\.|[^.]+)(?=[^.]*)", replacement = "", filenames, perl = TRUE) sub(pattern = "^(.*\\.|[^.]+)(?=[^.]*)", replacement = "",
filenames,
perl = TRUE)
} }
#' Flexible file import based on extension #' Flexible file import based on extension
@ -516,17 +522,16 @@ file_extension <- function(filenames) {
#' #'
#' @examples #' @examples
#' read_input("https://raw.githubusercontent.com/agdamsbo/cognitive.index.lookup/main/data/sample.csv") #' read_input("https://raw.githubusercontent.com/agdamsbo/cognitive.index.lookup/main/data/sample.csv")
read_input <- function(file, consider.na= c("NA", '""',"")){ read_input <- function(file, consider.na = c("NA", '""', "")) {
ext <- file_extension(file) ext <- file_extension(file)
tryCatch( tryCatch(
{ {
if (ext == "csv") { if (ext == "csv") {
df <- readr::read_csv(file = file,na = consider.na) df <- readr::read_csv(file = file, na = consider.na)
} else if (ext %in% c("xls", "xlsx")) { } else if (ext %in% c("xls", "xlsx")) {
df <- openxlsx2::read_xlsx(file = file, na.strings = consider.na) df <- openxlsx2::read_xlsx(file = file, na.strings = consider.na)
} else if (ext == "dta"){ } else if (ext == "dta") {
df <- haven::read_dta(file = file) df <- haven::read_dta(file = file)
} else { } else {
stop("Input file format has to be either '.csv', '.xls' or '.xlsx'") stop("Input file format has to be either '.csv', '.xls' or '.xlsx'")

12
data-raw/data-upload-examples.R
View File

@ -1,9 +1,11 @@
mtcars_redcap <- mtcars |> dplyr::mutate(record_id=seq_len(dplyr::n()), mtcars_redcap <- mtcars |>
name=rownames(mtcars) dplyr::mutate(
) |> record_id = seq_len(dplyr::n()),
dplyr::select(record_id,dplyr::everything()) name = rownames(mtcars)
) |>
dplyr::select(record_id, dplyr::everything())
mtcars_redcap |> mtcars_redcap |>
write.csv(here::here("data/mtcars_redcap.csv"),row.names = FALSE) write.csv(here::here("data/mtcars_redcap.csv"), row.names = FALSE)
usethis::use_data(mtcars_redcap, overwrite = TRUE) usethis::use_data(mtcars_redcap, overwrite = TRUE)

9
data-raw/metadata_names.R
View File

@ -3,12 +3,13 @@
# "field_label", "select_choices_or_calculations", "field_note", # "field_label", "select_choices_or_calculations", "field_note",
# "text_validation_type_or_show_slider_number", "text_validation_min", # "text_validation_type_or_show_slider_number", "text_validation_min",
# "text_validation_max", "identifier", "branching_logic", "required_field", # "text_validation_max", "identifier", "branching_logic", "required_field",
# "custom_alignment", "question_number", "matrix_group_name", "matrix_ranking", # "custom_alignment", "question_number", "matrix_group_name",
# "field_annotation" # "matrix_ranking", "field_annotation"
# ) # )
metadata_names <- REDCapR::redcap_metadata_read(redcap_uri = keyring::key_get("DB_URI"), metadata_names <- REDCapR::redcap_metadata_read(
token = keyring::key_get("cast_api") redcap_uri = keyring::key_get("DB_URI"),
token = keyring::key_get("cast_api")
)$data |> names() )$data |> names()
usethis::use_data(metadata_names, overwrite = TRUE, internal = TRUE) usethis::use_data(metadata_names, overwrite = TRUE, internal = TRUE)

9
data-raw/redcapcast_data.R
View File

@ -1,9 +1,10 @@
## code to prepare `redcapcast_data` dataset goes here ## code to prepare `redcapcast_data` dataset goes here
redcapcast_data <- REDCapR::redcap_read(redcap_uri = keyring::key_get("DB_URI"), redcapcast_data <- REDCapR::redcap_read(
token = keyring::key_get("cast_api"), redcap_uri = keyring::key_get("DB_URI"),
raw_or_label = "label" token = keyring::key_get("cast_api"),
)$data |> dplyr::tibble() raw_or_label = "label"
)$data |> dplyr::tibble()
# redcapcast_data <- easy_redcap(project.name = "redcapcast_pacakge", # redcapcast_data <- easy_redcap(project.name = "redcapcast_pacakge",
# uri = keyring::key_get("DB_URI"), # uri = keyring::key_get("DB_URI"),

7
data-raw/redcapcast_meta.R
View File

@ -1,6 +1,7 @@
## code to prepare `redcapcast_meta` dataset goes here ## code to prepare `redcapcast_meta` dataset goes here
redcapcast_meta <- REDCapR::redcap_metadata_read(redcap_uri = keyring::key_get("DB_URI"), redcapcast_meta <- REDCapR::redcap_metadata_read(
token = keyring::key_get("cast_api") redcap_uri = keyring::key_get("DB_URI"),
)$data token = keyring::key_get("cast_api")
)$data
usethis::use_data(redcapcast_meta, overwrite = TRUE) usethis::use_data(redcapcast_meta, overwrite = TRUE)

17
man/REDCap_split.Rd
View File

@ -50,19 +50,19 @@ library(RCurl)
# Get the records # Get the records
records <- postForm( records <- postForm(
uri = api_url, # Supply your site-specific URI uri = api_url, # Supply your site-specific URI
token = api_token, # Supply your own API token token = api_token, # Supply your own API token
content = 'record', content = "record",
format = 'json', format = "json",
returnFormat = 'json' returnFormat = "json"
) )
# Get the metadata # Get the metadata
metadata <- postForm( metadata <- postForm(
uri = api_url, # Supply your site-specific URI uri = api_url, # Supply your site-specific URI
token = api_token, # Supply your own API token token = api_token, # Supply your own API token
content = 'metadata', content = "metadata",
format = 'json' format = "json"
) )
# Convert exported JSON strings into a list of data.frames # Convert exported JSON strings into a list of data.frames
@ -75,7 +75,8 @@ records <- read.csv("/path/to/data/ExampleProject_DATA_2018-06-03_1700.csv")
# Get the metadata # Get the metadata
metadata <- read.csv( metadata <- read.csv(
"/path/to/data/ExampleProject_DataDictionary_2018-06-03.csv") "/path/to/data/ExampleProject_DataDictionary_2018-06-03.csv"
)
# Split the tables # Split the tables
REDCapRITS::REDCap_split(records, metadata) REDCapRITS::REDCap_split(records, metadata)

4
man/ds2dd_detailed.Rd
View File

@ -44,8 +44,8 @@ data set (imported .dta file with `haven::read_dta()`. Default is "label"}
\item{field.validation}{manually specify field validation(s). Vector of \item{field.validation}{manually specify field validation(s). Vector of
length 1 or ncol(data). Default is NULL and `levels()` are used for factors length 1 or ncol(data). Default is NULL and `levels()` are used for factors
or attribute `factor.labels.attr` for haven_labelled data set (imported .dta file with or attribute `factor.labels.attr` for haven_labelled data set (imported .dta
`haven::read_dta()`).} file with `haven::read_dta()`).}
\item{metadata}{redcap metadata headings. Default is \item{metadata}{redcap metadata headings. Default is
REDCapCAST:::metadata_names.} REDCapCAST:::metadata_names.}

4
man/guess_time_only_filter.Rd
View File

@ -32,5 +32,7 @@ has to be converted to character class before REDCap upload.
\examples{ \examples{
data <- redcapcast_data data <- redcapcast_data
data |> guess_time_only_filter() data |> guess_time_only_filter()
data |> guess_time_only_filter(validate = TRUE) |> lapply(head) data |>
guess_time_only_filter(validate = TRUE) |>
lapply(head)
} }

9
man/read_redcap_instrument.Rd
View File

@ -2,7 +2,8 @@
% Please edit documentation in R/read_redcap_instrument.R % Please edit documentation in R/read_redcap_instrument.R
\name{read_redcap_instrument} \name{read_redcap_instrument}
\alias{read_redcap_instrument} \alias{read_redcap_instrument}
\title{Convenience function to download complete instrument, using token storage in keyring.} \title{Convenience function to download complete instrument, using token storage
in keyring.}
\usage{ \usage{
read_redcap_instrument( read_redcap_instrument(
key, key,
@ -24,11 +25,13 @@ read_redcap_instrument(
\item{id_name}{id variable name. Default is "record_id".} \item{id_name}{id variable name. Default is "record_id".}
\item{records}{specify the records to download. Index numbers. Numeric vector.} \item{records}{specify the records to download. Index numbers.
Numeric vector.}
} }
\value{ \value{
data.frame data.frame
} }
\description{ \description{
Convenience function to download complete instrument, using token storage in keyring. Convenience function to download complete instrument, using token storage
in keyring.
} }

72
man/redcap_wider.Rd
View File

@ -26,35 +26,59 @@ Handles longitudinal projects, but not yet repeated instruments.
} }
\examples{ \examples{
# Longitudinal # Longitudinal
list1 <- list(data.frame(record_id = c(1,2,1,2), list1 <- list(
redcap_event_name = c("baseline", "baseline", "followup", "followup"), data.frame(
age = c(25,26,27,28)), record_id = c(1, 2, 1, 2),
data.frame(record_id = c(1,2), redcap_event_name = c("baseline", "baseline", "followup", "followup"),
redcap_event_name = c("baseline", "baseline"), age = c(25, 26, 27, 28)
gender = c("male", "female"))) ),
data.frame(
record_id = c(1, 2),
redcap_event_name = c("baseline", "baseline"),
gender = c("male", "female")
)
)
redcap_wider(list1) redcap_wider(list1)
# Simpel with two instruments # Simpel with two instruments
list2 <- list(data.frame(record_id = c(1,2), list2 <- list(
age = c(25,26)), data.frame(
data.frame(record_id = c(1,2), record_id = c(1, 2),
gender = c("male", "female"))) age = c(25, 26)
),
data.frame(
record_id = c(1, 2),
gender = c("male", "female")
)
)
redcap_wider(list2) redcap_wider(list2)
# Simple with single instrument # Simple with single instrument
list3 <- list(data.frame(record_id = c(1,2), list3 <- list(data.frame(
age = c(25,26))) record_id = c(1, 2),
age = c(25, 26)
))
redcap_wider(list3) redcap_wider(list3)
# Longitudinal with repeatable instruments # Longitudinal with repeatable instruments
list4 <- list(data.frame(record_id = c(1,2,1,2), list4 <- list(
redcap_event_name = c("baseline", "baseline", "followup", "followup"), data.frame(
age = c(25,26,27,28)), record_id = c(1, 2, 1, 2),
data.frame(record_id = c(1,1,1,1,2,2,2,2), redcap_event_name = c("baseline", "baseline", "followup", "followup"),
redcap_event_name = c("baseline", "baseline", "followup", "followup", age = c(25, 26, 27, 28)
"baseline", "baseline", "followup", "followup"), ),
redcap_repeat_instrument = "walk", data.frame(
redcap_repeat_instance=c(1,2,1,2,1,2,1,2), record_id = c(1, 1, 1, 1, 2, 2, 2, 2),
dist = c(40, 32, 25, 33, 28, 24, 23, 36)), redcap_event_name = c(
data.frame(record_id = c(1,2), "baseline", "baseline", "followup", "followup",
redcap_event_name = c("baseline", "baseline"), "baseline", "baseline", "followup", "followup"
gender = c("male", "female"))) ),
redcap_repeat_instrument = "walk",
redcap_repeat_instance = c(1, 2, 1, 2, 1, 2, 1, 2),
dist = c(40, 32, 25, 33, 28, 24, 23, 36)
),
data.frame(
record_id = c(1, 2),
redcap_event_name = c("baseline", "baseline"),
gender = c("male", "female")
)
)
redcap_wider(list4) redcap_wider(list4)
} }

6
man/redcapcast_meta.Rd
View File

@ -12,9 +12,11 @@ A data frame with 22 variables:
\item{section_header}{section_header, character} \item{section_header}{section_header, character}
\item{field_type}{field_type, character} \item{field_type}{field_type, character}
\item{field_label}{field_label, character} \item{field_label}{field_label, character}
\item{select_choices_or_calculations}{select_choices_or_calculations, character} \item{select_choices_or_calculations}
{select_choices_or_calculations, character}
\item{field_note}{field_note, character} \item{field_note}{field_note, character}
\item{text_validation_type_or_show_slider_number}{text_validation_type_or_show_slider_number, character} \item{text_validation_type_or_show_slider_number}
{text_validation_type_or_show_slider_number, character}
\item{text_validation_min}{text_validation_min, character} \item{text_validation_min}{text_validation_min, character}
\item{text_validation_max}{text_validation_max, character} \item{text_validation_max}{text_validation_max, character}
\item{identifier}{identifier, character} \item{identifier}{identifier, character}

3
man/strsplitx.Rd
View File

@ -25,6 +25,7 @@ Can be used as a substitute of the base function. Main claim to fame is
easing the split around the defined delimiter, see example. easing the split around the defined delimiter, see example.
} }
\examples{ \examples{
test <- c("12 months follow-up", "3 steps", "mRS 6 weeks", "Counting to 231 now") test <- c("12 months follow-up", "3 steps", "mRS 6 weeks",
"Counting to 231 now")
strsplitx(test, "[0-9]", type = "around") strsplitx(test, "[0-9]", type = "around")
} }

6
man/time_only_correction.Rd
View File

@ -2,8 +2,7 @@
% Please edit documentation in R/ds2dd_detailed.R % Please edit documentation in R/ds2dd_detailed.R
\name{time_only_correction} \name{time_only_correction}
\alias{time_only_correction} \alias{time_only_correction}
\title{Correction based on time_only_filter function. Introduces new class for easier \title{Correction based on time_only_filter function}
validation labelling.}
\usage{ \usage{
time_only_correction(data, ...) time_only_correction(data, ...)
} }
@ -16,8 +15,7 @@ time_only_correction(data, ...)
tibble tibble
} }
\description{ \description{
Dependens on the data class "hms" introduced with Correction based on time_only_filter function
`guess_time_only_filter()` and converts these
} }
\examples{ \examples{
data <- redcapcast_data data <- redcapcast_data

31
tests/testthat/data/create-ref-data.R
View File

@ -7,22 +7,23 @@ library(magrittr)
library(jsonlite) library(jsonlite)
ref_data_location <- function(x) file.path("tests","testthat","data", x) ref_data_location <- function(x) file.path("tests", "testthat", "data", x)
# RCurl ------------------------------------------------------------------- # RCurl -------------------------------------------------------------------
REDCap_split( REDCap_split(
ref_data_location("ExampleProject_records.json") %>% fromJSON, ref_data_location("ExampleProject_records.json") %>% fromJSON(),
ref_data_location("ExampleProject_metadata.json") %>% fromJSON ref_data_location("ExampleProject_metadata.json") %>% fromJSON()
) %>% digest ) %>% digest()
# Basic CSV --------------------------------------------------------------- # Basic CSV ---------------------------------------------------------------
REDCap_split( REDCap_split(
ref_data_location("ExampleProject_DATA_2018-06-07_1129.csv") %>% read.csv, ref_data_location("ExampleProject_DATA_2018-06-07_1129.csv") %>% read.csv(),
ref_data_location("ExampleProject_DataDictionary_2018-06-07.csv") %>% read.csv ref_data_location("ExampleProject_DataDictionary_2018-06-07.csv") %>%
) %>% digest read.csv()
) %>% digest()
# REDCap R Export --------------------------------------------------------- # REDCap R Export ---------------------------------------------------------
@ -30,10 +31,11 @@ source("tests/testthat/helper-ExampleProject_R_2018-06-07_1129.r")
REDCap_split( REDCap_split(
ref_data_location("ExampleProject_DATA_2018-06-07_1129.csv") %>% ref_data_location("ExampleProject_DATA_2018-06-07_1129.csv") %>%
read.csv %>% read.csv() %>%
REDCap_process_csv, REDCap_process_csv(),
ref_data_location("ExampleProject_DataDictionary_2018-06-07.csv") %>% read.csv ref_data_location("ExampleProject_DataDictionary_2018-06-07.csv") %>%
) %>% digest read.csv()
) %>% digest()
# Longitudinal data from @pbchase; Issue #7 ------------------------------- # Longitudinal data from @pbchase; Issue #7 -------------------------------
@ -41,9 +43,10 @@ file_paths <- vapply(
c( c(
records = "WARRIORtestForSoftwa_DATA_2018-06-21_1431.csv", records = "WARRIORtestForSoftwa_DATA_2018-06-21_1431.csv",
metadata = "WARRIORtestForSoftwareUpgrades_DataDictionary_2018-06-21.csv" metadata = "WARRIORtestForSoftwareUpgrades_DataDictionary_2018-06-21.csv"
), FUN.VALUE = "character", ref_data_location ),
FUN.VALUE = "character", ref_data_location
) )
redcap <- lapply(file_paths, read.csv, stringsAsFactors = FALSE) redcap <- lapply(file_paths, read.csv, stringsAsFactors = FALSE)
redcap[["metadata"]] <- with(redcap, metadata[metadata[,1] > "",]) redcap[["metadata"]] <- with(redcap, metadata[metadata[, 1] > "", ])
with(redcap, REDCap_split(records, metadata)) %>% digest with(redcap, REDCap_split(records, metadata)) %>% digest()

28
tests/testthat/helper-ExampleProject_R_2018-06-07_1129.r
View File

@ -1,5 +1,5 @@
REDCap_process_csv <- function(data) { REDCap_process_csv <- function(data) {
#Load Hmisc library # Load Hmisc library
if (!requireNamespace("Hmisc", quietly = TRUE)) { if (!requireNamespace("Hmisc", quietly = TRUE)) {
stop("This test requires the 'Hmisc' package") stop("This test requires the 'Hmisc' package")
} }
@ -36,13 +36,13 @@ REDCap_process_csv <- function(data) {
Hmisc::label(data$color) <- "Color" Hmisc::label(data$color) <- "Color"
Hmisc::label(data$customer) <- "Customer Name" Hmisc::label(data$customer) <- "Customer Name"
Hmisc::label(data$sale_complete) <- "Complete?" Hmisc::label(data$sale_complete) <- "Complete?"
#Setting Units # Setting Units
#Setting Factors(will create new variable for factors) # Setting Factors(will create new variable for factors)
data$redcap_repeat_instrument.factor <- data$redcap_repeat_instrument.factor <-
factor(data$redcap_repeat_instrument, levels <- factor(data$redcap_repeat_instrument, levels <-
c("sale")) c("sale"))
data$cyl.factor <- data$cyl.factor <-
factor(data$cyl, levels <- c("3", "4", "5", "6", "7", "8")) factor(data$cyl, levels <- c("3", "4", "5", "6", "7", "8"))
data$vs.factor <- factor(data$vs, levels <- c("1", "0")) data$vs.factor <- factor(data$vs, levels <- c("1", "0"))
@ -50,36 +50,36 @@ REDCap_process_csv <- function(data) {
data$gear.factor <- factor(data$gear, levels <- c("3", "4", "5")) data$gear.factor <- factor(data$gear, levels <- c("3", "4", "5"))
data$carb.factor <- data$carb.factor <-
factor(data$carb, levels <- factor(data$carb, levels <-
c("1", "2", "3", "4", "5", "6", "7", "8")) c("1", "2", "3", "4", "5", "6", "7", "8"))
data$color_available___red.factor <- data$color_available___red.factor <-
factor(data$color_available___red, levels <- factor(data$color_available___red, levels <-
c("0", "1")) c("0", "1"))
data$color_available___green.factor <- data$color_available___green.factor <-
factor(data$color_available___green, levels <- factor(data$color_available___green, levels <-
c("0", "1")) c("0", "1"))
data$color_available___blue.factor <- data$color_available___blue.factor <-
factor(data$color_available___blue, levels <- factor(data$color_available___blue, levels <-
c("0", "1")) c("0", "1"))
data$color_available___black.factor <- data$color_available___black.factor <-
factor(data$color_available___black, levels <- factor(data$color_available___black, levels <-
c("0", "1")) c("0", "1"))
data$motor_trend_cars_complete.factor <- data$motor_trend_cars_complete.factor <-
factor(data$motor_trend_cars_complete, levels <- factor(data$motor_trend_cars_complete, levels <-
c("0", "1", "2")) c("0", "1", "2"))
data$letter_group___a.factor <- data$letter_group___a.factor <-
factor(data$letter_group___a, levels <- factor(data$letter_group___a, levels <-
c("0", "1")) c("0", "1"))
data$letter_group___b.factor <- data$letter_group___b.factor <-
factor(data$letter_group___b, levels <- factor(data$letter_group___b, levels <-
c("0", "1")) c("0", "1"))
data$letter_group___c.factor <- data$letter_group___c.factor <-
factor(data$letter_group___c, levels <- factor(data$letter_group___c, levels <-
c("0", "1")) c("0", "1"))
data$choice.factor <- data$choice.factor <-
factor(data$choice, levels <- c("choice1", "choice2")) factor(data$choice, levels <- c("choice1", "choice2"))
data$grouping_complete.factor <- data$grouping_complete.factor <-
factor(data$grouping_complete, levels <- factor(data$grouping_complete, levels <-
c("0", "1", "2")) c("0", "1", "2"))
data$color.factor <- data$color.factor <-
factor(data$color, levels <- c("1", "2", "3", "4")) factor(data$color, levels <- c("1", "2", "3", "4"))
data$sale_complete.factor <- data$sale_complete.factor <-

61
tests/testthat/test-csv-exports.R
View File

@ -1,5 +1,3 @@
# Set up the path and data ------------------------------------------------- # Set up the path and data -------------------------------------------------
metadata <- read.csv( metadata <- read.csv(
get_data_location("ExampleProject_DataDictionary_2018-06-07.csv"), get_data_location("ExampleProject_DataDictionary_2018-06-07.csv"),
@ -8,7 +6,8 @@ metadata <- read.csv(
records <- records <-
read.csv(get_data_location("ExampleProject_DATA_2018-06-07_1129.csv"), read.csv(get_data_location("ExampleProject_DATA_2018-06-07_1129.csv"),
stringsAsFactors = TRUE) stringsAsFactors = TRUE
)
redcap_output_csv1 <- REDCap_split(records, metadata) redcap_output_csv1 <- REDCap_split(records, metadata)
@ -19,20 +18,21 @@ test_that("CSV export matches reference", {
# Test that REDCap_split can handle a focused dataset # Test that REDCap_split can handle a focused dataset
records_red <- records[!records$redcap_repeat_instrument == "sale", records_red <- records[
!names(records) %in% !records$redcap_repeat_instrument == "sale",
metadata$field_name[metadata$form_name == "sale"] & !names(records) %in%
!names(records) == "sale_complete"] metadata$field_name[metadata$form_name == "sale"] &
!names(records) == "sale_complete"
]
records_red$redcap_repeat_instrument <- records_red$redcap_repeat_instrument <-
as.character(records_red$redcap_repeat_instrument) as.character(records_red$redcap_repeat_instrument)
redcap_output_red <- REDCap_split(records_red, metadata) redcap_output_red <- REDCap_split(records_red, metadata)
test_that("REDCap_split handles subset dataset", test_that("REDCap_split handles subset dataset", {
{ testthat::expect_length(redcap_output_red, 1)
testthat::expect_length(redcap_output_red, 1) })
})
# Test that R code enhanced CSV export matches reference -------------------- # Test that R code enhanced CSV export matches reference --------------------
@ -47,35 +47,40 @@ if (requireNamespace("Hmisc", quietly = TRUE)) {
if (requireNamespace("readr", quietly = TRUE)) { if (requireNamespace("readr", quietly = TRUE)) {
metadata <- metadata <-
readr::read_csv(get_data_location( readr::read_csv(get_data_location(
"ExampleProject_DataDictionary_2018-06-07.csv")) "ExampleProject_DataDictionary_2018-06-07.csv"
))
records <- records <-
readr::read_csv(get_data_location( readr::read_csv(get_data_location(
"ExampleProject_DATA_2018-06-07_1129.csv")) "ExampleProject_DATA_2018-06-07_1129.csv"
))
redcap_output_readr <- REDCap_split(records, metadata) redcap_output_readr <- REDCap_split(records, metadata)
expect_matching_elements <- function(FUN) { expect_matching_elements <- function(FUN) {
FUN <- match.fun(FUN) FUN <- match.fun(FUN)
expect_identical(lapply(redcap_output_readr, FUN), expect_identical(
lapply(redcap_output_csv1, FUN)) lapply(redcap_output_readr, FUN),
lapply(redcap_output_csv1, FUN)
)
} }
test_that("Result of data read in with `readr` will test_that("Result of data read in with `readr` will
match result with `read.csv`", match result with `read.csv`", {
{ # The list itself
# The list itself expect_identical(
expect_identical(length(redcap_output_readr), length(redcap_output_readr),
length(redcap_output_csv1)) length(redcap_output_csv1)
expect_identical(names(redcap_output_readr), )
names(redcap_output_csv1)) expect_identical(
names(redcap_output_readr),
# Each element of the list names(redcap_output_csv1)
expect_matching_elements(names) )
expect_matching_elements(dim)
})
# Each element of the list
expect_matching_elements(names)
expect_matching_elements(dim)
})
} }

22
tests/testthat/test-utils.R
View File

@ -1,20 +1,22 @@
test_that("strsplitx works", { test_that("strsplitx works", {
expect_equal(2 * 2, 4) expect_equal(2 * 2, 4)
test <- c("12 months follow-up", "3 steps", "mRS 6 weeks", "Counting to 231 now") test <- c("12 months follow-up", "3 steps", "mRS 6 weeks",
expect_length(strsplitx(test,"[0-9]",type="around")[[1]],3) "Counting to 231 now")
expect_length(strsplitx(test, "[0-9]", type = "around")[[1]], 3)
expect_equal(strsplitx(test,"[0-9]",type="classic")[[2]][1],"") expect_equal(strsplitx(test, "[0-9]", type = "classic")[[2]][1], "")
expect_length(strsplitx(test,"[0-9]",type="classic")[[4]],4) expect_length(strsplitx(test, "[0-9]", type = "classic")[[4]], 4)
expect_length(strsplitx(test,"[0-9]",type="classic")[[4]],4) expect_length(strsplitx(test, "[0-9]", type = "classic")[[4]], 4)
}) })
test_that("d2w works", { test_that("d2w works", {
expect_length(d2w(c(2:8, 21)), 8)
expect_length(d2w(c(2:8,21)),8) expect_equal(d2w(data.frame(2:7, 3:8, 1),
lang = "da",
neutrum = TRUE
)[1, 3], "et")
expect_equal(d2w(data.frame(2:7,3:8,1),lang="da", expect_equal(d2w(list(2:8, c(2, 6, 4, 23), 2), everything = T)[[2]][4], "two three")
neutrum=TRUE)[1,3],"et")
expect_equal(d2w(list(2:8,c(2,6,4,23),2), everything=T)[[2]][4],"two three")
}) })

6
vignettes/Database-creation.Rmd
View File

@ -25,7 +25,8 @@ THe first iteration of a dataset to data dictionary function is the `ds2dd()`, w
```{r eval=FALSE} ```{r eval=FALSE}
mtcars |> mtcars |>
dplyr::mutate(record_id = seq_len(dplyr::n())) |> dplyr::mutate(record_id = seq_len(dplyr::n())) |>
ds2dd() |> str() ds2dd() |>
str()
``` ```
The more advanced `ds2dd_detailed()` is a natural development. It will try to apply the most common data classes for data validation and will assume that the first column is the id number. It outputs a list with the dataset with modified variable names to comply with REDCap naming conventions and a data dictionary. The more advanced `ds2dd_detailed()` is a natural development. It will try to apply the most common data classes for data validation and will assume that the first column is the id number. It outputs a list with the dataset with modified variable names to comply with REDCap naming conventions and a data dictionary.
@ -37,7 +38,8 @@ dd_ls <- mtcars |>
dplyr::mutate(record_id = seq_len(dplyr::n())) |> dplyr::mutate(record_id = seq_len(dplyr::n())) |>
dplyr::select(record_id, dplyr::everything()) |> dplyr::select(record_id, dplyr::everything()) |>
ds2dd_detailed() ds2dd_detailed()
dd_ls |> str() dd_ls |>
str()
``` ```
Additional specifications to the DataDictionary can be made manually, or it can be uploaded and modified manually in the graphical user interface on the web page. Additional specifications to the DataDictionary can be made manually, or it can be uploaded and modified manually in the graphical user interface on the web page.

20
vignettes/Introduction.Rmd
View File

@ -33,17 +33,23 @@ redcapcast_meta |> gt::gt()
``` ```
```{r} ```{r}
list <- list <-
REDCap_split(records = redcapcast_data, REDCap_split(
metadata = redcapcast_meta, records = redcapcast_data,
forms = "repeating")|> sanitize_split() metadata = redcapcast_meta,
forms = "repeating"
) |>
sanitize_split()
str(list) str(list)
``` ```
```{r} ```{r}
list <- list <-
REDCap_split(records = redcapcast_data, REDCap_split(
metadata = redcapcast_meta, records = redcapcast_data,
forms = "all") |> sanitize_split() metadata = redcapcast_meta,
forms = "all"
) |>
sanitize_split()
str(list) str(list)
``` ```
@ -62,5 +68,3 @@ The function works very similar to the `REDCapR::redcap_read()` in allowing to s
```{r} ```{r}
redcap_wider(list) |> str() redcap_wider(list) |> str()
``` ```