mirror of
https://github.com/agdamsbo/REDCapCAST.git
synced 2024-11-25 06:21:53 +01:00
linting
This commit is contained in:
parent
a0730cb41c
commit
9e33057c06
7
.lintr
Normal file
7
.lintr
Normal file
@ -0,0 +1,7 @@
|
||||
linters: linters_with_defaults(
|
||||
commented_code_linter = NULL
|
||||
)
|
||||
encoding: "UTF-8"
|
||||
exclusions: list(
|
||||
"drafting/"
|
||||
)
|
||||
@ -24,19 +24,19 @@
|
||||
#'
|
||||
#' # Get the records
|
||||
#' 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
|
||||
#' content = 'record',
|
||||
#' format = 'json',
|
||||
#' returnFormat = 'json'
|
||||
#' content = "record",
|
||||
#' format = "json",
|
||||
#' returnFormat = "json"
|
||||
#' )
|
||||
#'
|
||||
#' # Get the metadata
|
||||
#' 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
|
||||
#' content = 'metadata',
|
||||
#' format = 'json'
|
||||
#' content = "metadata",
|
||||
#' format = "json"
|
||||
#' )
|
||||
#'
|
||||
#' # Convert exported JSON strings into a list of data.frames
|
||||
@ -49,7 +49,8 @@
|
||||
#'
|
||||
#' # Get the metadata
|
||||
#' metadata <- read.csv(
|
||||
#' "/path/to/data/ExampleProject_DataDictionary_2018-06-03.csv")
|
||||
#' "/path/to/data/ExampleProject_DataDictionary_2018-06-03.csv"
|
||||
#' )
|
||||
#'
|
||||
#' # Split the tables
|
||||
#' REDCapRITS::REDCap_split(records, metadata)
|
||||
@ -86,9 +87,8 @@ REDCap_split <- function(records,
|
||||
metadata,
|
||||
primary_table_name = "",
|
||||
forms = c("repeating", "all")) {
|
||||
|
||||
# Process user input
|
||||
records <- process_user_input(records)
|
||||
records <- process_user_input(records)
|
||||
metadata <-
|
||||
as.data.frame(process_user_input(metadata))
|
||||
|
||||
@ -96,26 +96,27 @@ REDCap_split <- function(records,
|
||||
vars_in_data <- names(records)
|
||||
|
||||
# Process repeat instrument names to match the redcap naming
|
||||
if (is_repeated_longitudinal(records)){
|
||||
records$redcap_repeat_instrument <- clean_redcap_name(records$redcap_repeat_instrument)
|
||||
if (is_repeated_longitudinal(records)) {
|
||||
records$redcap_repeat_instrument <-
|
||||
clean_redcap_name(records$redcap_repeat_instrument)
|
||||
|
||||
# Match arg for forms
|
||||
forms <- match.arg(forms, c("repeating", "all"))
|
||||
# Match arg for forms
|
||||
forms <- match.arg(forms, c("repeating", "all"))
|
||||
|
||||
# Check to see if there were any repeating instruments
|
||||
if (forms == "repeating" &&
|
||||
# Check to see if there were any repeating instruments
|
||||
if (forms == "repeating" &&
|
||||
!"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)
|
||||
if (any(is.na(records$redcap_repeat_instrument))) {
|
||||
records$redcap_repeat_instrument <- ifelse(
|
||||
is.na(records$redcap_repeat_instrument),
|
||||
"",
|
||||
as.character(records$redcap_repeat_instrument)
|
||||
)
|
||||
}
|
||||
# Remove NAs from `redcap_repeat_instrument` (see issue #12)
|
||||
if (any(is.na(records$redcap_repeat_instrument))) {
|
||||
records$redcap_repeat_instrument <- ifelse(
|
||||
is.na(records$redcap_repeat_instrument),
|
||||
"",
|
||||
as.character(records$redcap_repeat_instrument)
|
||||
)
|
||||
}
|
||||
}
|
||||
|
||||
# Standardize variable names for metadata
|
||||
@ -144,8 +145,9 @@ 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)
|
||||
vars_in_data,
|
||||
value = TRUE
|
||||
)
|
||||
|
||||
# Identify the subtables in the data
|
||||
subtables <- unique(records$redcap_repeat_instrument)
|
||||
@ -169,35 +171,36 @@ 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_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]
|
||||
|
||||
}
|
||||
|
||||
}
|
||||
|
||||
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)
|
||||
|
||||
}
|
||||
|
||||
out
|
||||
}
|
||||
|
||||
|
||||
@ -41,7 +41,7 @@ ds2dd <-
|
||||
dd <- data.frame(matrix(ncol = length(metadata), nrow = ncol(ds)))
|
||||
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.")
|
||||
}
|
||||
|
||||
@ -59,7 +59,7 @@ ds2dd <-
|
||||
dd[, "field_name"] <-
|
||||
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(
|
||||
"Provided form.name should be of length 1 (value is reused) or equal
|
||||
length as number of variables in data set."
|
||||
@ -67,7 +67,7 @@ ds2dd <-
|
||||
}
|
||||
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(
|
||||
"Provided field.type should be of length 1 (value is reused) or equal
|
||||
length as number of variables in data set."
|
||||
|
||||
@ -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
|
||||
#'
|
||||
#' @description
|
||||
@ -18,10 +23,15 @@ utils::globalVariables(c( "stats::setNames", "field_name", "field_type", "se
|
||||
#' @examples
|
||||
#' data <- redcapcast_data
|
||||
#' data |> guess_time_only_filter()
|
||||
#' data |> 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]") {
|
||||
#' data |>
|
||||
#' 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 |>
|
||||
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)])()
|
||||
|
||||
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
|
||||
#' validation labelling.
|
||||
#' Correction based on time_only_filter function
|
||||
#'
|
||||
#' @description
|
||||
#' Dependens on the data class "hms" introduced with
|
||||
#' `guess_time_only_filter()` and converts these
|
||||
#'
|
||||
#' @param data data set
|
||||
#' @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"
|
||||
#' @param field.validation manually specify field validation(s). Vector of
|
||||
#' 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
|
||||
#' `haven::read_dta()`).
|
||||
#' or attribute `factor.labels.attr` for haven_labelled data set (imported .dta
|
||||
#' file with `haven::read_dta()`).
|
||||
#' @param metadata redcap metadata headings. Default is
|
||||
#' REDCapCAST:::metadata_names.
|
||||
#' @param validate.time Flag to validate guessed time columns
|
||||
@ -144,7 +150,7 @@ ds2dd_detailed <- function(data,
|
||||
form.name = NULL,
|
||||
field.type = NULL,
|
||||
field.label = NULL,
|
||||
field.label.attr ="label",
|
||||
field.label.attr = "label",
|
||||
field.validation = NULL,
|
||||
metadata = metadata_names,
|
||||
validate.time = FALSE,
|
||||
@ -164,7 +170,8 @@ ds2dd_detailed <- function(data,
|
||||
}
|
||||
|
||||
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"
|
||||
} else {
|
||||
data.source <- ""
|
||||
@ -172,18 +179,25 @@ ds2dd_detailed <- function(data,
|
||||
|
||||
## 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") {
|
||||
data_classes <-
|
||||
data |>
|
||||
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]) |>
|
||||
(\(x)do.call(c, x))()
|
||||
} else {
|
||||
data_classes <-
|
||||
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]) |>
|
||||
(\(x)do.call(c, x))()
|
||||
}
|
||||
@ -204,7 +218,7 @@ ds2dd_detailed <- function(data,
|
||||
if (is.null(form.name)) {
|
||||
dd$form_name <- "data"
|
||||
} 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
|
||||
} else {
|
||||
stop("Length of supplied 'form.name' has to be one (1) or ncol(data).")
|
||||
@ -229,9 +243,11 @@ ds2dd_detailed <- function(data,
|
||||
}
|
||||
|
||||
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 {
|
||||
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
|
||||
} else {
|
||||
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 <-
|
||||
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 {
|
||||
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
|
||||
} else {
|
||||
stop("Length of supplied 'field.type' has to be one (1) or ncol(data).")
|
||||
@ -271,10 +289,11 @@ ds2dd_detailed <- function(data,
|
||||
)
|
||||
)
|
||||
} 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
|
||||
} 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
|
||||
## Assumes alle relevant levels are represented in the data
|
||||
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 {
|
||||
NA
|
||||
}
|
||||
@ -319,7 +344,10 @@ ds2dd_detailed <- function(data,
|
||||
|
||||
list(
|
||||
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() |>
|
||||
(\(x)stats::setNames(x, tolower(names(x))))(),
|
||||
meta = dd
|
||||
@ -333,11 +361,16 @@ ds2dd_detailed <- function(data,
|
||||
#' @param ls output list from `ds2dd_detailed()`
|
||||
#'
|
||||
#' @return list with `REDCapR::redcap_write()` results
|
||||
mark_complete <- function(upload, ls){
|
||||
mark_complete <- function(upload, ls) {
|
||||
data <- ls$data
|
||||
meta <- ls$meta
|
||||
forms <- unique(meta$form_name)
|
||||
cbind(data[[1]][data[[1]] %in% upload$affected_ids],
|
||||
data.frame(matrix(2,ncol=length(forms),nrow=upload$records_affected_count))) |>
|
||||
stats::setNames(c(names(data)[1],paste0(forms,"_complete")))
|
||||
cbind(
|
||||
data[[1]][data[[1]] %in% upload$affected_ids],
|
||||
data.frame(matrix(2,
|
||||
ncol = length(forms),
|
||||
nrow = upload$records_affected_count
|
||||
))
|
||||
) |>
|
||||
stats::setNames(c(names(data)[1], paste0(forms, "_complete")))
|
||||
}
|
||||
|
||||
@ -1,4 +1,3 @@
|
||||
|
||||
#' Retrieve project API key if stored, if not, set and retrieve
|
||||
#'
|
||||
#' @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
|
||||
#' @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"))
|
||||
|
||||
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()
|
||||
}
|
||||
|
||||
|
||||
@ -20,4 +20,3 @@
|
||||
#' }
|
||||
#' @usage data(mtcars_redcap)
|
||||
"mtcars_redcap"
|
||||
|
||||
|
||||
@ -1,4 +1,4 @@
|
||||
process_user_input <- function (x) {
|
||||
process_user_input <- function(x) {
|
||||
UseMethod("process_user_input", x)
|
||||
}
|
||||
|
||||
@ -30,10 +30,8 @@ process_user_input.character <- function(x, ...) {
|
||||
}
|
||||
|
||||
jsonlite::fromJSON(x)
|
||||
|
||||
}
|
||||
|
||||
process_user_input.response <- function(x, ...) {
|
||||
process_user_input(rawToChar(x$content))
|
||||
|
||||
}
|
||||
|
||||
@ -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 uri REDCap database API uri
|
||||
#' @param instrument instrument name
|
||||
#' @param raw_or_label raw or label passed to `REDCapR::redcap_read()`
|
||||
#' @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
|
||||
#' @export
|
||||
read_redcap_instrument <- function(key,
|
||||
uri,
|
||||
instrument,
|
||||
raw_or_label = "raw",
|
||||
id_name = "record_id",
|
||||
records = NULL) {
|
||||
uri,
|
||||
instrument,
|
||||
raw_or_label = "raw",
|
||||
id_name = "record_id",
|
||||
records = NULL) {
|
||||
REDCapCAST::read_redcap_tables(
|
||||
records = records,
|
||||
uri = uri, token = keyring::key_get(key),
|
||||
|
||||
@ -38,7 +38,8 @@ read_redcap_tables <- function(uri,
|
||||
fields_test <- fields %in% unique(m$field_name)
|
||||
|
||||
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")
|
||||
}
|
||||
}
|
||||
@ -48,7 +49,8 @@ read_redcap_tables <- function(uri,
|
||||
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 = ", "), "."))
|
||||
print(paste0("The following form names are invalid: ",
|
||||
paste(forms[!forms_test], collapse = ", "), "."))
|
||||
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)
|
||||
|
||||
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")
|
||||
}
|
||||
}
|
||||
@ -89,15 +92,12 @@ read_redcap_tables <- function(uri,
|
||||
m <- focused_metadata(m, names(d))
|
||||
|
||||
|
||||
# Splitting
|
||||
out <- REDCap_split(d,
|
||||
m,
|
||||
forms = split_forms,
|
||||
primary_table_name = ""
|
||||
)
|
||||
|
||||
sanitize_split(out)
|
||||
# Splitting
|
||||
out <- REDCap_split(d,
|
||||
m,
|
||||
forms = split_forms,
|
||||
primary_table_name = ""
|
||||
)
|
||||
|
||||
sanitize_split(out)
|
||||
}
|
||||
|
||||
|
||||
|
||||
189
R/redcap_wider.R
189
R/redcap_wider.R
@ -1,6 +1,8 @@
|
||||
utils::globalVariables(c("redcap_wider",
|
||||
"event.glue",
|
||||
"inst.glue"))
|
||||
utils::globalVariables(c(
|
||||
"redcap_wider",
|
||||
"event.glue",
|
||||
"inst.glue"
|
||||
))
|
||||
|
||||
#' @title Redcap Wider
|
||||
#' @description Converts a list of REDCap data frames from long to wide format.
|
||||
@ -16,42 +18,65 @@ utils::globalVariables(c("redcap_wider",
|
||||
#'
|
||||
#' @examples
|
||||
#' # Longitudinal
|
||||
#' list1 <- list(data.frame(record_id = c(1,2,1,2),
|
||||
#' redcap_event_name = c("baseline", "baseline", "followup", "followup"),
|
||||
#' age = c(25,26,27,28)),
|
||||
#' data.frame(record_id = c(1,2),
|
||||
#' redcap_event_name = c("baseline", "baseline"),
|
||||
#' gender = c("male", "female")))
|
||||
#' list1 <- list(
|
||||
#' data.frame(
|
||||
#' record_id = c(1, 2, 1, 2),
|
||||
#' redcap_event_name = c("baseline", "baseline", "followup", "followup"),
|
||||
#' age = c(25, 26, 27, 28)
|
||||
#' ),
|
||||
#' data.frame(
|
||||
#' record_id = c(1, 2),
|
||||
#' redcap_event_name = c("baseline", "baseline"),
|
||||
#' gender = c("male", "female")
|
||||
#' )
|
||||
#' )
|
||||
#' redcap_wider(list1)
|
||||
#' # Simpel with two instruments
|
||||
#' list2 <- list(data.frame(record_id = c(1,2),
|
||||
#' age = c(25,26)),
|
||||
#' data.frame(record_id = c(1,2),
|
||||
#' gender = c("male", "female")))
|
||||
#' list2 <- list(
|
||||
#' data.frame(
|
||||
#' record_id = c(1, 2),
|
||||
#' age = c(25, 26)
|
||||
#' ),
|
||||
#' data.frame(
|
||||
#' record_id = c(1, 2),
|
||||
#' gender = c("male", "female")
|
||||
#' )
|
||||
#' )
|
||||
#' redcap_wider(list2)
|
||||
#' # Simple with single instrument
|
||||
#' list3 <- list(data.frame(record_id = c(1,2),
|
||||
#' age = c(25,26)))
|
||||
#' list3 <- list(data.frame(
|
||||
#' record_id = c(1, 2),
|
||||
#' age = c(25, 26)
|
||||
#' ))
|
||||
#' redcap_wider(list3)
|
||||
#' # Longitudinal with repeatable instruments
|
||||
#' list4 <- list(data.frame(record_id = c(1,2,1,2),
|
||||
#' redcap_event_name = c("baseline", "baseline", "followup", "followup"),
|
||||
#' age = c(25,26,27,28)),
|
||||
#' data.frame(record_id = c(1,1,1,1,2,2,2,2),
|
||||
#' redcap_event_name = c("baseline", "baseline", "followup", "followup",
|
||||
#' "baseline", "baseline", "followup", "followup"),
|
||||
#' 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)
|
||||
#' list4 <- list(
|
||||
#' data.frame(
|
||||
#' record_id = c(1, 2, 1, 2),
|
||||
#' redcap_event_name = c("baseline", "baseline", "followup", "followup"),
|
||||
#' age = c(25, 26, 27, 28)
|
||||
#' ),
|
||||
#' data.frame(
|
||||
#' record_id = c(1, 1, 1, 1, 2, 2, 2, 2),
|
||||
#' redcap_event_name = c(
|
||||
#' "baseline", "baseline", "followup", "followup",
|
||||
#' "baseline", "baseline", "followup", "followup"
|
||||
#' ),
|
||||
#' 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 <-
|
||||
function(data,
|
||||
event.glue = "{.value}_{redcap_event_name}",
|
||||
inst.glue = "{.value}_{redcap_repeat_instance}") {
|
||||
|
||||
if (!is_repeated_longitudinal(data)) {
|
||||
if (is.list(data)) {
|
||||
if (length(data) == 1) {
|
||||
@ -59,69 +84,65 @@ redcap_wider <-
|
||||
} else {
|
||||
out <- data |> purrr::reduce(dplyr::left_join)
|
||||
}
|
||||
} else if (is.data.frame(data)){
|
||||
} else if (is.data.frame(data)) {
|
||||
out <- data
|
||||
}
|
||||
|
||||
|
||||
} 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) {
|
||||
rep_inst <- "redcap_repeat_instrument" %in% names(i)
|
||||
|
||||
if (rep_inst) {
|
||||
k <- lapply(split(i, f = i[[id.name]]), function(j) {
|
||||
cname <- colnames(j)
|
||||
vals <-
|
||||
cname[!cname %in% c(
|
||||
id.name,
|
||||
"redcap_event_name",
|
||||
"redcap_repeat_instrument",
|
||||
"redcap_repeat_instance"
|
||||
)]
|
||||
s <- tidyr::pivot_wider(
|
||||
j,
|
||||
names_from = "redcap_repeat_instance",
|
||||
values_from = all_of(vals),
|
||||
names_glue = inst.glue
|
||||
)
|
||||
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
|
||||
if (rep_inst) {
|
||||
k <- lapply(split(i, f = i[[id.name]]), function(j) {
|
||||
cname <- colnames(j)
|
||||
vals <-
|
||||
cname[!cname %in% c(
|
||||
id.name,
|
||||
"redcap_event_name",
|
||||
"redcap_repeat_instrument",
|
||||
"redcap_repeat_instance"
|
||||
)]
|
||||
s <- tidyr::pivot_wider(
|
||||
j,
|
||||
names_from = "redcap_repeat_instance",
|
||||
values_from = all_of(vals),
|
||||
names_glue = inst.glue
|
||||
)
|
||||
s[!colnames(s) %in% c("redcap_repeat_instrument")]
|
||||
})
|
||||
i <- Reduce(dplyr::bind_rows, k)
|
||||
}
|
||||
})
|
||||
|
||||
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
|
||||
}
|
||||
|
||||
|
||||
@ -33,5 +33,3 @@
|
||||
#' }
|
||||
#' @usage data(redcapcast_data)
|
||||
"redcapcast_data"
|
||||
|
||||
|
||||
|
||||
@ -9,9 +9,11 @@
|
||||
#' \item{section_header}{section_header, character}
|
||||
#' \item{field_type}{field_type, 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{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_max}{text_validation_max, character}
|
||||
#' \item{identifier}{identifier, character}
|
||||
@ -25,5 +27,3 @@
|
||||
#' }
|
||||
#' @usage data(redcapcast_meta)
|
||||
"redcapcast_meta"
|
||||
|
||||
|
||||
|
||||
@ -14,8 +14,7 @@ server_factory <- function() {
|
||||
#' @export
|
||||
ui_factory <- function() {
|
||||
# require(ggplot2)
|
||||
source(here::here("app/ui.R"))
|
||||
|
||||
source(here::here("app/ui.R"))
|
||||
}
|
||||
|
||||
#' Launch the included Shiny-app for database casting and upload
|
||||
@ -46,7 +45,7 @@ shiny_cast <- function() {
|
||||
#' @examples
|
||||
#' # 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
|
||||
rsconnect::setAccountInfo(
|
||||
name = "cognitiveindex",
|
||||
@ -55,5 +54,5 @@ deploy_shiny <- function(path=here::here("app/"), name.app="shiny_cast"){
|
||||
)
|
||||
|
||||
# Deploying
|
||||
rsconnect::deployApp(appDir = path,lint = TRUE,appName = name.app,)
|
||||
rsconnect::deployApp(appDir = path, lint = TRUE, appName = name.app, )
|
||||
}
|
||||
|
||||
25
R/utils.r
25
R/utils.r
@ -128,9 +128,11 @@ sanitize_split <- function(l,
|
||||
"redcap_repeat_instrument",
|
||||
"redcap_repeat_instance"
|
||||
)) {
|
||||
generic.names <- c(get_id_name(l),
|
||||
generic.names,
|
||||
paste0(names(l), "_complete"))
|
||||
generic.names <- c(
|
||||
get_id_name(l),
|
||||
generic.names,
|
||||
paste0(names(l), "_complete")
|
||||
)
|
||||
|
||||
lapply(l, function(i) {
|
||||
if (ncol(i) > 2) {
|
||||
@ -334,7 +336,8 @@ split_non_repeating_forms <-
|
||||
#' @export
|
||||
#'
|
||||
#' @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 <- function(x,
|
||||
split,
|
||||
@ -403,7 +406,8 @@ d2w <- function(x, lang = "en", neutrum = FALSE, everything = FALSE) {
|
||||
# In Danish the written 1 depends on the counted word
|
||||
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) {
|
||||
zero_nine <- data.frame(
|
||||
num = 0:9,
|
||||
@ -503,7 +507,9 @@ is_repeated_longitudinal <- function(data, generics = c(
|
||||
#' @examples
|
||||
#' file_extension(list.files(here::here(""))[[2]])[[1]]
|
||||
file_extension <- function(filenames) {
|
||||
sub(pattern = "^(.*\\.|[^.]+)(?=[^.]*)", replacement = "", filenames, perl = TRUE)
|
||||
sub(pattern = "^(.*\\.|[^.]+)(?=[^.]*)", replacement = "",
|
||||
filenames,
|
||||
perl = TRUE)
|
||||
}
|
||||
|
||||
#' Flexible file import based on extension
|
||||
@ -516,17 +522,16 @@ file_extension <- function(filenames) {
|
||||
#'
|
||||
#' @examples
|
||||
#' 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)
|
||||
|
||||
tryCatch(
|
||||
{
|
||||
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")) {
|
||||
df <- openxlsx2::read_xlsx(file = file, na.strings = consider.na)
|
||||
} else if (ext == "dta"){
|
||||
} else if (ext == "dta") {
|
||||
df <- haven::read_dta(file = file)
|
||||
} else {
|
||||
stop("Input file format has to be either '.csv', '.xls' or '.xlsx'")
|
||||
|
||||
@ -1,9 +1,11 @@
|
||||
mtcars_redcap <- mtcars |> dplyr::mutate(record_id=seq_len(dplyr::n()),
|
||||
name=rownames(mtcars)
|
||||
) |>
|
||||
dplyr::select(record_id,dplyr::everything())
|
||||
mtcars_redcap <- mtcars |>
|
||||
dplyr::mutate(
|
||||
record_id = seq_len(dplyr::n()),
|
||||
name = rownames(mtcars)
|
||||
) |>
|
||||
dplyr::select(record_id, dplyr::everything())
|
||||
|
||||
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)
|
||||
|
||||
@ -3,12 +3,13 @@
|
||||
# "field_label", "select_choices_or_calculations", "field_note",
|
||||
# "text_validation_type_or_show_slider_number", "text_validation_min",
|
||||
# "text_validation_max", "identifier", "branching_logic", "required_field",
|
||||
# "custom_alignment", "question_number", "matrix_group_name", "matrix_ranking",
|
||||
# "field_annotation"
|
||||
# "custom_alignment", "question_number", "matrix_group_name",
|
||||
# "matrix_ranking", "field_annotation"
|
||||
# )
|
||||
|
||||
metadata_names <- REDCapR::redcap_metadata_read(redcap_uri = keyring::key_get("DB_URI"),
|
||||
token = keyring::key_get("cast_api")
|
||||
metadata_names <- REDCapR::redcap_metadata_read(
|
||||
redcap_uri = keyring::key_get("DB_URI"),
|
||||
token = keyring::key_get("cast_api")
|
||||
)$data |> names()
|
||||
|
||||
usethis::use_data(metadata_names, overwrite = TRUE, internal = TRUE)
|
||||
|
||||
@ -1,9 +1,10 @@
|
||||
## code to prepare `redcapcast_data` dataset goes here
|
||||
|
||||
redcapcast_data <- REDCapR::redcap_read(redcap_uri = keyring::key_get("DB_URI"),
|
||||
token = keyring::key_get("cast_api"),
|
||||
raw_or_label = "label"
|
||||
)$data |> dplyr::tibble()
|
||||
redcapcast_data <- REDCapR::redcap_read(
|
||||
redcap_uri = keyring::key_get("DB_URI"),
|
||||
token = keyring::key_get("cast_api"),
|
||||
raw_or_label = "label"
|
||||
)$data |> dplyr::tibble()
|
||||
|
||||
# redcapcast_data <- easy_redcap(project.name = "redcapcast_pacakge",
|
||||
# uri = keyring::key_get("DB_URI"),
|
||||
|
||||
@ -1,6 +1,7 @@
|
||||
## code to prepare `redcapcast_meta` dataset goes here
|
||||
redcapcast_meta <- REDCapR::redcap_metadata_read(redcap_uri = keyring::key_get("DB_URI"),
|
||||
token = keyring::key_get("cast_api")
|
||||
)$data
|
||||
redcapcast_meta <- REDCapR::redcap_metadata_read(
|
||||
redcap_uri = keyring::key_get("DB_URI"),
|
||||
token = keyring::key_get("cast_api")
|
||||
)$data
|
||||
|
||||
usethis::use_data(redcapcast_meta, overwrite = TRUE)
|
||||
|
||||
@ -50,19 +50,19 @@ library(RCurl)
|
||||
|
||||
# Get the records
|
||||
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
|
||||
content = 'record',
|
||||
format = 'json',
|
||||
returnFormat = 'json'
|
||||
content = "record",
|
||||
format = "json",
|
||||
returnFormat = "json"
|
||||
)
|
||||
|
||||
# Get the metadata
|
||||
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
|
||||
content = 'metadata',
|
||||
format = 'json'
|
||||
content = "metadata",
|
||||
format = "json"
|
||||
)
|
||||
|
||||
# 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
|
||||
metadata <- read.csv(
|
||||
"/path/to/data/ExampleProject_DataDictionary_2018-06-03.csv")
|
||||
"/path/to/data/ExampleProject_DataDictionary_2018-06-03.csv"
|
||||
)
|
||||
|
||||
# Split the tables
|
||||
REDCapRITS::REDCap_split(records, metadata)
|
||||
|
||||
@ -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
|
||||
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
|
||||
`haven::read_dta()`).}
|
||||
or attribute `factor.labels.attr` for haven_labelled data set (imported .dta
|
||||
file with `haven::read_dta()`).}
|
||||
|
||||
\item{metadata}{redcap metadata headings. Default is
|
||||
REDCapCAST:::metadata_names.}
|
||||
|
||||
@ -32,5 +32,7 @@ has to be converted to character class before REDCap upload.
|
||||
\examples{
|
||||
data <- redcapcast_data
|
||||
data |> guess_time_only_filter()
|
||||
data |> guess_time_only_filter(validate = TRUE) |> lapply(head)
|
||||
data |>
|
||||
guess_time_only_filter(validate = TRUE) |>
|
||||
lapply(head)
|
||||
}
|
||||
|
||||
@ -2,7 +2,8 @@
|
||||
% Please edit documentation in R/read_redcap_instrument.R
|
||||
\name{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{
|
||||
read_redcap_instrument(
|
||||
key,
|
||||
@ -24,11 +25,13 @@ read_redcap_instrument(
|
||||
|
||||
\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{
|
||||
data.frame
|
||||
}
|
||||
\description{
|
||||
Convenience function to download complete instrument, using token storage in keyring.
|
||||
Convenience function to download complete instrument, using token storage
|
||||
in keyring.
|
||||
}
|
||||
|
||||
@ -26,35 +26,59 @@ Handles longitudinal projects, but not yet repeated instruments.
|
||||
}
|
||||
\examples{
|
||||
# Longitudinal
|
||||
list1 <- list(data.frame(record_id = c(1,2,1,2),
|
||||
redcap_event_name = c("baseline", "baseline", "followup", "followup"),
|
||||
age = c(25,26,27,28)),
|
||||
data.frame(record_id = c(1,2),
|
||||
redcap_event_name = c("baseline", "baseline"),
|
||||
gender = c("male", "female")))
|
||||
list1 <- list(
|
||||
data.frame(
|
||||
record_id = c(1, 2, 1, 2),
|
||||
redcap_event_name = c("baseline", "baseline", "followup", "followup"),
|
||||
age = c(25, 26, 27, 28)
|
||||
),
|
||||
data.frame(
|
||||
record_id = c(1, 2),
|
||||
redcap_event_name = c("baseline", "baseline"),
|
||||
gender = c("male", "female")
|
||||
)
|
||||
)
|
||||
redcap_wider(list1)
|
||||
# Simpel with two instruments
|
||||
list2 <- list(data.frame(record_id = c(1,2),
|
||||
age = c(25,26)),
|
||||
data.frame(record_id = c(1,2),
|
||||
gender = c("male", "female")))
|
||||
list2 <- list(
|
||||
data.frame(
|
||||
record_id = c(1, 2),
|
||||
age = c(25, 26)
|
||||
),
|
||||
data.frame(
|
||||
record_id = c(1, 2),
|
||||
gender = c("male", "female")
|
||||
)
|
||||
)
|
||||
redcap_wider(list2)
|
||||
# Simple with single instrument
|
||||
list3 <- list(data.frame(record_id = c(1,2),
|
||||
age = c(25,26)))
|
||||
list3 <- list(data.frame(
|
||||
record_id = c(1, 2),
|
||||
age = c(25, 26)
|
||||
))
|
||||
redcap_wider(list3)
|
||||
# Longitudinal with repeatable instruments
|
||||
list4 <- list(data.frame(record_id = c(1,2,1,2),
|
||||
redcap_event_name = c("baseline", "baseline", "followup", "followup"),
|
||||
age = c(25,26,27,28)),
|
||||
data.frame(record_id = c(1,1,1,1,2,2,2,2),
|
||||
redcap_event_name = c("baseline", "baseline", "followup", "followup",
|
||||
"baseline", "baseline", "followup", "followup"),
|
||||
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")))
|
||||
list4 <- list(
|
||||
data.frame(
|
||||
record_id = c(1, 2, 1, 2),
|
||||
redcap_event_name = c("baseline", "baseline", "followup", "followup"),
|
||||
age = c(25, 26, 27, 28)
|
||||
),
|
||||
data.frame(
|
||||
record_id = c(1, 1, 1, 1, 2, 2, 2, 2),
|
||||
redcap_event_name = c(
|
||||
"baseline", "baseline", "followup", "followup",
|
||||
"baseline", "baseline", "followup", "followup"
|
||||
),
|
||||
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)
|
||||
}
|
||||
|
||||
@ -12,9 +12,11 @@ A data frame with 22 variables:
|
||||
\item{section_header}{section_header, character}
|
||||
\item{field_type}{field_type, 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{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_max}{text_validation_max, character}
|
||||
\item{identifier}{identifier, character}
|
||||
|
||||
@ -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.
|
||||
}
|
||||
\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")
|
||||
}
|
||||
|
||||
@ -2,8 +2,7 @@
|
||||
% Please edit documentation in R/ds2dd_detailed.R
|
||||
\name{time_only_correction}
|
||||
\alias{time_only_correction}
|
||||
\title{Correction based on time_only_filter function. Introduces new class for easier
|
||||
validation labelling.}
|
||||
\title{Correction based on time_only_filter function}
|
||||
\usage{
|
||||
time_only_correction(data, ...)
|
||||
}
|
||||
@ -16,8 +15,7 @@ time_only_correction(data, ...)
|
||||
tibble
|
||||
}
|
||||
\description{
|
||||
Dependens on the data class "hms" introduced with
|
||||
`guess_time_only_filter()` and converts these
|
||||
Correction based on time_only_filter function
|
||||
}
|
||||
\examples{
|
||||
data <- redcapcast_data
|
||||
|
||||
@ -7,22 +7,23 @@ library(magrittr)
|
||||
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 -------------------------------------------------------------------
|
||||
|
||||
REDCap_split(
|
||||
ref_data_location("ExampleProject_records.json") %>% fromJSON,
|
||||
ref_data_location("ExampleProject_metadata.json") %>% fromJSON
|
||||
) %>% digest
|
||||
ref_data_location("ExampleProject_records.json") %>% fromJSON(),
|
||||
ref_data_location("ExampleProject_metadata.json") %>% fromJSON()
|
||||
) %>% digest()
|
||||
|
||||
|
||||
# Basic CSV ---------------------------------------------------------------
|
||||
|
||||
REDCap_split(
|
||||
ref_data_location("ExampleProject_DATA_2018-06-07_1129.csv") %>% read.csv,
|
||||
ref_data_location("ExampleProject_DataDictionary_2018-06-07.csv") %>% read.csv
|
||||
) %>% digest
|
||||
ref_data_location("ExampleProject_DATA_2018-06-07_1129.csv") %>% read.csv(),
|
||||
ref_data_location("ExampleProject_DataDictionary_2018-06-07.csv") %>%
|
||||
read.csv()
|
||||
) %>% digest()
|
||||
|
||||
# REDCap R Export ---------------------------------------------------------
|
||||
|
||||
@ -30,10 +31,11 @@ source("tests/testthat/helper-ExampleProject_R_2018-06-07_1129.r")
|
||||
|
||||
REDCap_split(
|
||||
ref_data_location("ExampleProject_DATA_2018-06-07_1129.csv") %>%
|
||||
read.csv %>%
|
||||
REDCap_process_csv,
|
||||
ref_data_location("ExampleProject_DataDictionary_2018-06-07.csv") %>% read.csv
|
||||
) %>% digest
|
||||
read.csv() %>%
|
||||
REDCap_process_csv(),
|
||||
ref_data_location("ExampleProject_DataDictionary_2018-06-07.csv") %>%
|
||||
read.csv()
|
||||
) %>% digest()
|
||||
|
||||
# Longitudinal data from @pbchase; Issue #7 -------------------------------
|
||||
|
||||
@ -41,9 +43,10 @@ file_paths <- vapply(
|
||||
c(
|
||||
records = "WARRIORtestForSoftwa_DATA_2018-06-21_1431.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[["metadata"]] <- with(redcap, metadata[metadata[,1] > "",])
|
||||
with(redcap, REDCap_split(records, metadata)) %>% digest
|
||||
redcap[["metadata"]] <- with(redcap, metadata[metadata[, 1] > "", ])
|
||||
with(redcap, REDCap_split(records, metadata)) %>% digest()
|
||||
|
||||
@ -1,5 +1,5 @@
|
||||
REDCap_process_csv <- function(data) {
|
||||
#Load Hmisc library
|
||||
# Load Hmisc library
|
||||
if (!requireNamespace("Hmisc", quietly = TRUE)) {
|
||||
stop("This test requires the 'Hmisc' package")
|
||||
}
|
||||
@ -36,13 +36,13 @@ REDCap_process_csv <- function(data) {
|
||||
Hmisc::label(data$color) <- "Color"
|
||||
Hmisc::label(data$customer) <- "Customer Name"
|
||||
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 <-
|
||||
factor(data$redcap_repeat_instrument, levels <-
|
||||
c("sale"))
|
||||
c("sale"))
|
||||
data$cyl.factor <-
|
||||
factor(data$cyl, levels <- c("3", "4", "5", "6", "7", "8"))
|
||||
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$carb.factor <-
|
||||
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 <-
|
||||
factor(data$color_available___red, levels <-
|
||||
c("0", "1"))
|
||||
c("0", "1"))
|
||||
data$color_available___green.factor <-
|
||||
factor(data$color_available___green, levels <-
|
||||
c("0", "1"))
|
||||
c("0", "1"))
|
||||
data$color_available___blue.factor <-
|
||||
factor(data$color_available___blue, levels <-
|
||||
c("0", "1"))
|
||||
c("0", "1"))
|
||||
data$color_available___black.factor <-
|
||||
factor(data$color_available___black, levels <-
|
||||
c("0", "1"))
|
||||
c("0", "1"))
|
||||
data$motor_trend_cars_complete.factor <-
|
||||
factor(data$motor_trend_cars_complete, levels <-
|
||||
c("0", "1", "2"))
|
||||
c("0", "1", "2"))
|
||||
data$letter_group___a.factor <-
|
||||
factor(data$letter_group___a, levels <-
|
||||
c("0", "1"))
|
||||
c("0", "1"))
|
||||
data$letter_group___b.factor <-
|
||||
factor(data$letter_group___b, levels <-
|
||||
c("0", "1"))
|
||||
c("0", "1"))
|
||||
data$letter_group___c.factor <-
|
||||
factor(data$letter_group___c, levels <-
|
||||
c("0", "1"))
|
||||
c("0", "1"))
|
||||
data$choice.factor <-
|
||||
factor(data$choice, levels <- c("choice1", "choice2"))
|
||||
data$grouping_complete.factor <-
|
||||
factor(data$grouping_complete, levels <-
|
||||
c("0", "1", "2"))
|
||||
c("0", "1", "2"))
|
||||
data$color.factor <-
|
||||
factor(data$color, levels <- c("1", "2", "3", "4"))
|
||||
data$sale_complete.factor <-
|
||||
|
||||
@ -1,5 +1,3 @@
|
||||
|
||||
|
||||
# Set up the path and data -------------------------------------------------
|
||||
metadata <- read.csv(
|
||||
get_data_location("ExampleProject_DataDictionary_2018-06-07.csv"),
|
||||
@ -8,7 +6,8 @@ metadata <- read.csv(
|
||||
|
||||
records <-
|
||||
read.csv(get_data_location("ExampleProject_DATA_2018-06-07_1129.csv"),
|
||||
stringsAsFactors = TRUE)
|
||||
stringsAsFactors = TRUE
|
||||
)
|
||||
|
||||
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
|
||||
|
||||
records_red <- records[!records$redcap_repeat_instrument == "sale",
|
||||
!names(records) %in%
|
||||
metadata$field_name[metadata$form_name == "sale"] &
|
||||
!names(records) == "sale_complete"]
|
||||
records_red <- records[
|
||||
!records$redcap_repeat_instrument == "sale",
|
||||
!names(records) %in%
|
||||
metadata$field_name[metadata$form_name == "sale"] &
|
||||
!names(records) == "sale_complete"
|
||||
]
|
||||
records_red$redcap_repeat_instrument <-
|
||||
as.character(records_red$redcap_repeat_instrument)
|
||||
|
||||
redcap_output_red <- REDCap_split(records_red, metadata)
|
||||
|
||||
|
||||
test_that("REDCap_split handles subset dataset",
|
||||
{
|
||||
testthat::expect_length(redcap_output_red, 1)
|
||||
})
|
||||
test_that("REDCap_split handles subset dataset", {
|
||||
testthat::expect_length(redcap_output_red, 1)
|
||||
})
|
||||
|
||||
|
||||
# Test that R code enhanced CSV export matches reference --------------------
|
||||
@ -47,35 +47,40 @@ if (requireNamespace("Hmisc", quietly = TRUE)) {
|
||||
|
||||
|
||||
if (requireNamespace("readr", quietly = TRUE)) {
|
||||
|
||||
metadata <-
|
||||
readr::read_csv(get_data_location(
|
||||
"ExampleProject_DataDictionary_2018-06-07.csv"))
|
||||
"ExampleProject_DataDictionary_2018-06-07.csv"
|
||||
))
|
||||
|
||||
records <-
|
||||
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)
|
||||
|
||||
expect_matching_elements <- function(FUN) {
|
||||
FUN <- match.fun(FUN)
|
||||
expect_identical(lapply(redcap_output_readr, FUN),
|
||||
lapply(redcap_output_csv1, FUN))
|
||||
expect_identical(
|
||||
lapply(redcap_output_readr, FUN),
|
||||
lapply(redcap_output_csv1, FUN)
|
||||
)
|
||||
}
|
||||
|
||||
test_that("Result of data read in with `readr` will
|
||||
match result with `read.csv`",
|
||||
{
|
||||
# The list itself
|
||||
expect_identical(length(redcap_output_readr),
|
||||
length(redcap_output_csv1))
|
||||
expect_identical(names(redcap_output_readr),
|
||||
names(redcap_output_csv1))
|
||||
|
||||
# Each element of the list
|
||||
expect_matching_elements(names)
|
||||
expect_matching_elements(dim)
|
||||
})
|
||||
match result with `read.csv`", {
|
||||
# The list itself
|
||||
expect_identical(
|
||||
length(redcap_output_readr),
|
||||
length(redcap_output_csv1)
|
||||
)
|
||||
expect_identical(
|
||||
names(redcap_output_readr),
|
||||
names(redcap_output_csv1)
|
||||
)
|
||||
|
||||
# Each element of the list
|
||||
expect_matching_elements(names)
|
||||
expect_matching_elements(dim)
|
||||
})
|
||||
}
|
||||
|
||||
@ -1,20 +1,22 @@
|
||||
test_that("strsplitx works", {
|
||||
expect_equal(2 * 2, 4)
|
||||
test <- c("12 months follow-up", "3 steps", "mRS 6 weeks", "Counting to 231 now")
|
||||
expect_length(strsplitx(test,"[0-9]",type="around")[[1]],3)
|
||||
test <- c("12 months follow-up", "3 steps", "mRS 6 weeks",
|
||||
"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_length(strsplitx(test,"[0-9]",type="classic")[[4]],4)
|
||||
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)
|
||||
})
|
||||
|
||||
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",
|
||||
neutrum=TRUE)[1,3],"et")
|
||||
|
||||
expect_equal(d2w(list(2:8,c(2,6,4,23),2), everything=T)[[2]][4],"two three")
|
||||
expect_equal(d2w(list(2:8, c(2, 6, 4, 23), 2), everything = T)[[2]][4], "two three")
|
||||
})
|
||||
|
||||
@ -25,7 +25,8 @@ THe first iteration of a dataset to data dictionary function is the `ds2dd()`, w
|
||||
```{r eval=FALSE}
|
||||
mtcars |>
|
||||
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.
|
||||
@ -37,7 +38,8 @@ dd_ls <- mtcars |>
|
||||
dplyr::mutate(record_id = seq_len(dplyr::n())) |>
|
||||
dplyr::select(record_id, dplyr::everything()) |>
|
||||
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.
|
||||
|
||||
@ -33,17 +33,23 @@ redcapcast_meta |> gt::gt()
|
||||
```
|
||||
```{r}
|
||||
list <-
|
||||
REDCap_split(records = redcapcast_data,
|
||||
metadata = redcapcast_meta,
|
||||
forms = "repeating")|> sanitize_split()
|
||||
REDCap_split(
|
||||
records = redcapcast_data,
|
||||
metadata = redcapcast_meta,
|
||||
forms = "repeating"
|
||||
) |>
|
||||
sanitize_split()
|
||||
str(list)
|
||||
```
|
||||
|
||||
```{r}
|
||||
list <-
|
||||
REDCap_split(records = redcapcast_data,
|
||||
metadata = redcapcast_meta,
|
||||
forms = "all") |> sanitize_split()
|
||||
REDCap_split(
|
||||
records = redcapcast_data,
|
||||
metadata = redcapcast_meta,
|
||||
forms = "all"
|
||||
) |>
|
||||
sanitize_split()
|
||||
str(list)
|
||||
```
|
||||
|
||||
@ -62,5 +68,3 @@ The function works very similar to the `REDCapR::redcap_read()` in allowing to s
|
||||
```{r}
|
||||
redcap_wider(list) |> str()
|
||||
```
|
||||
|
||||
|
||||
|
||||
Loading…
Reference in New Issue
Block a user