From 9e33057c061f28c596eb22c8381bdd9721d4e2cc Mon Sep 17 00:00:00 2001 From: Andreas Gammelgaard Damsbo Date: Tue, 27 Feb 2024 13:20:21 +0100 Subject: [PATCH] linting --- .lintr | 7 + R/REDCap_split.r | 93 ++++----- R/ds2dd.R | 6 +- R/ds2dd_detailed.R | 91 ++++++--- R/easy_redcap.R | 5 +- R/mtcars_redcap.R | 1 - R/process_user_input.r | 4 +- R/read_redcap_instrument.R | 16 +- R/read_redcap_tables.R | 26 +-- R/redcap_wider.R | 189 ++++++++++-------- R/redcapcast_data.R | 2 - R/redcapcast_meta.R | 8 +- R/shiny_cast.R | 7 +- R/utils.r | 25 ++- data-raw/data-upload-examples.R | 12 +- data-raw/metadata_names.R | 9 +- data-raw/redcapcast_data.R | 9 +- data-raw/redcapcast_meta.R | 7 +- man/REDCap_split.Rd | 17 +- man/ds2dd_detailed.Rd | 4 +- man/guess_time_only_filter.Rd | 4 +- man/read_redcap_instrument.Rd | 9 +- man/redcap_wider.Rd | 72 ++++--- man/redcapcast_meta.Rd | 6 +- man/strsplitx.Rd | 3 +- man/time_only_correction.Rd | 6 +- tests/testthat/data/create-ref-data.R | 31 +-- .../helper-ExampleProject_R_2018-06-07_1129.r | 28 +-- tests/testthat/test-csv-exports.R | 61 +++--- tests/testthat/test-utils.R | 22 +- vignettes/Database-creation.Rmd | 6 +- vignettes/Introduction.Rmd | 20 +- 32 files changed, 461 insertions(+), 345 deletions(-) create mode 100644 .lintr diff --git a/.lintr b/.lintr new file mode 100644 index 0000000..f817c43 --- /dev/null +++ b/.lintr @@ -0,0 +1,7 @@ +linters: linters_with_defaults( + commented_code_linter = NULL + ) +encoding: "UTF-8" +exclusions: list( + "drafting/" + ) diff --git a/R/REDCap_split.r b/R/REDCap_split.r index 6f9e3c9..55af504 100644 --- a/R/REDCap_split.r +++ b/R/REDCap_split.r @@ -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 } - diff --git a/R/ds2dd.R b/R/ds2dd.R index 46bb052..e0deefd 100644 --- a/R/ds2dd.R +++ b/R/ds2dd.R @@ -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." diff --git a/R/ds2dd_detailed.R b/R/ds2dd_detailed.R index 909db62..429555e 100644 --- a/R/ds2dd_detailed.R +++ b/R/ds2dd_detailed.R @@ -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"))) } diff --git a/R/easy_redcap.R b/R/easy_redcap.R index 6ad8548..b3fd326 100644 --- a/R/easy_redcap.R +++ b/R/easy_redcap.R @@ -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() } diff --git a/R/mtcars_redcap.R b/R/mtcars_redcap.R index 4079bca..ae1826f 100644 --- a/R/mtcars_redcap.R +++ b/R/mtcars_redcap.R @@ -20,4 +20,3 @@ #' } #' @usage data(mtcars_redcap) "mtcars_redcap" - diff --git a/R/process_user_input.r b/R/process_user_input.r index 0ca2aae..ec61a1d 100644 --- a/R/process_user_input.r +++ b/R/process_user_input.r @@ -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)) - } diff --git a/R/read_redcap_instrument.R b/R/read_redcap_instrument.R index ed1e7fd..7fe817d 100644 --- a/R/read_redcap_instrument.R +++ b/R/read_redcap_instrument.R @@ -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), diff --git a/R/read_redcap_tables.R b/R/read_redcap_tables.R index b52ec10..d970bdc 100644 --- a/R/read_redcap_tables.R +++ b/R/read_redcap_tables.R @@ -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) } - - diff --git a/R/redcap_wider.R b/R/redcap_wider.R index 7f8fbbd..ecdb23d 100644 --- a/R/redcap_wider.R +++ b/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 } - diff --git a/R/redcapcast_data.R b/R/redcapcast_data.R index fb8e099..5f2d743 100644 --- a/R/redcapcast_data.R +++ b/R/redcapcast_data.R @@ -33,5 +33,3 @@ #' } #' @usage data(redcapcast_data) "redcapcast_data" - - diff --git a/R/redcapcast_meta.R b/R/redcapcast_meta.R index b35f9a9..33b00ba 100644 --- a/R/redcapcast_meta.R +++ b/R/redcapcast_meta.R @@ -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" - - diff --git a/R/shiny_cast.R b/R/shiny_cast.R index bb7d8e6..bc25fdd 100644 --- a/R/shiny_cast.R +++ b/R/shiny_cast.R @@ -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, ) } diff --git a/R/utils.r b/R/utils.r index 98edb75..8352939 100644 --- a/R/utils.r +++ b/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'") diff --git a/data-raw/data-upload-examples.R b/data-raw/data-upload-examples.R index 27d39fd..ecb8964 100644 --- a/data-raw/data-upload-examples.R +++ b/data-raw/data-upload-examples.R @@ -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) diff --git a/data-raw/metadata_names.R b/data-raw/metadata_names.R index b00ac13..bb83e19 100644 --- a/data-raw/metadata_names.R +++ b/data-raw/metadata_names.R @@ -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) diff --git a/data-raw/redcapcast_data.R b/data-raw/redcapcast_data.R index 0a155f9..f924df5 100644 --- a/data-raw/redcapcast_data.R +++ b/data-raw/redcapcast_data.R @@ -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"), diff --git a/data-raw/redcapcast_meta.R b/data-raw/redcapcast_meta.R index 23a7dba..dccaea4 100644 --- a/data-raw/redcapcast_meta.R +++ b/data-raw/redcapcast_meta.R @@ -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) diff --git a/man/REDCap_split.Rd b/man/REDCap_split.Rd index eac982b..f9dadb7 100644 --- a/man/REDCap_split.Rd +++ b/man/REDCap_split.Rd @@ -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) diff --git a/man/ds2dd_detailed.Rd b/man/ds2dd_detailed.Rd index 89cf42b..b94b25c 100644 --- a/man/ds2dd_detailed.Rd +++ b/man/ds2dd_detailed.Rd @@ -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.} diff --git a/man/guess_time_only_filter.Rd b/man/guess_time_only_filter.Rd index 58e6913..9341f24 100644 --- a/man/guess_time_only_filter.Rd +++ b/man/guess_time_only_filter.Rd @@ -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) } diff --git a/man/read_redcap_instrument.Rd b/man/read_redcap_instrument.Rd index 1736b94..62cf5d5 100644 --- a/man/read_redcap_instrument.Rd +++ b/man/read_redcap_instrument.Rd @@ -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. } diff --git a/man/redcap_wider.Rd b/man/redcap_wider.Rd index efe82ef..1c7be4a 100644 --- a/man/redcap_wider.Rd +++ b/man/redcap_wider.Rd @@ -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) } diff --git a/man/redcapcast_meta.Rd b/man/redcapcast_meta.Rd index e5cd8b2..8d41ff8 100644 --- a/man/redcapcast_meta.Rd +++ b/man/redcapcast_meta.Rd @@ -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} diff --git a/man/strsplitx.Rd b/man/strsplitx.Rd index de7dc9c..464c6a3 100644 --- a/man/strsplitx.Rd +++ b/man/strsplitx.Rd @@ -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") } diff --git a/man/time_only_correction.Rd b/man/time_only_correction.Rd index 75d3821..189cf5c 100644 --- a/man/time_only_correction.Rd +++ b/man/time_only_correction.Rd @@ -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 diff --git a/tests/testthat/data/create-ref-data.R b/tests/testthat/data/create-ref-data.R index ec82520..612eee3 100644 --- a/tests/testthat/data/create-ref-data.R +++ b/tests/testthat/data/create-ref-data.R @@ -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() diff --git a/tests/testthat/helper-ExampleProject_R_2018-06-07_1129.r b/tests/testthat/helper-ExampleProject_R_2018-06-07_1129.r index 5b81f41..ac471ec 100644 --- a/tests/testthat/helper-ExampleProject_R_2018-06-07_1129.r +++ b/tests/testthat/helper-ExampleProject_R_2018-06-07_1129.r @@ -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 <- diff --git a/tests/testthat/test-csv-exports.R b/tests/testthat/test-csv-exports.R index 5ca6bb0..d8e73ad 100644 --- a/tests/testthat/test-csv-exports.R +++ b/tests/testthat/test-csv-exports.R @@ -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) + }) } diff --git a/tests/testthat/test-utils.R b/tests/testthat/test-utils.R index e13ec83..4a273b0 100644 --- a/tests/testthat/test-utils.R +++ b/tests/testthat/test-utils.R @@ -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") }) diff --git a/vignettes/Database-creation.Rmd b/vignettes/Database-creation.Rmd index c226385..ae0f896 100644 --- a/vignettes/Database-creation.Rmd +++ b/vignettes/Database-creation.Rmd @@ -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. diff --git a/vignettes/Introduction.Rmd b/vignettes/Introduction.Rmd index dee8a4f..130a2f5 100644 --- a/vignettes/Introduction.Rmd +++ b/vignettes/Introduction.Rmd @@ -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() ``` - -