andreas/REDCapCAST
1
0
Fork 0
mirror of https://github.com/agdamsbo/REDCapCAST.git synced 2025-09-12 18:49:39 +02:00
Code Issues Projects Releases Packages Wiki Activity Actions

Compare commits

base: andreas:main
Branches Tags
andreas:main
andreas:gh-pages
andreas:agdamsbo-patch-1
andreas:docs
andreas:v25.3.2
andreas:v25.3.1
andreas:v25.1.1
andreas:v24.12.1
andreas:v24.11.3
andreas:v24.10.3
andreas:v24.6.1
andreas:v24.2.1
andreas:v24.1.1
andreas:v23.12.1
andreas:v23.6.2
andreas:v23.6.1
..
compare: andreas:v24.6.1
Branches Tags
andreas:gh-pages
andreas:main
andreas:agdamsbo-patch-1
andreas:docs
andreas:v25.3.2
andreas:v25.3.1
andreas:v25.1.1
andreas:v24.12.1
andreas:v24.11.3
andreas:v24.10.3
andreas:v24.6.1
andreas:v24.2.1
andreas:v24.1.1
andreas:v23.12.1
andreas:v23.6.2
andreas:v23.6.1

No commits in common. "main" and "v24.6.1" have entirely different histories.
main ... v24.6.1

103 changed files with 981 additions and 5735 deletions
Show stats Expand all files Collapse all files

4
.Rbuildignore
View file

@ -16,8 +16,6 @@
^cran-comments\.md$
^CRAN-SUBMISSION$
drafting
app
^\.lintr$
^CODE_OF_CONDUCT\.md$
^~/REDCapCAST/inst/shiny-examples/casting/rsconnect$
^inst/shiny-examples/casting/functions\.R$
^functions\.R$

3
.Renviron
View file

@ -1 +1,2 @@
_R_CHECK_SYSTEM_CLOCK_=0
_R_CHECK_FORCE_SUGGESTS_=FALSE

14
.Rprofile
View file

@ -1 +1,13 @@
source("renv/activate.R")
options(
renv.settings.snapshot.type = "explicit",
renv.config.auto.snapshot = TRUE,
renv.config.pak.enabled = TRUE,
rmarkdown.html_vignette.check_title = FALSE
)
# source("renv/activate.R")
if (interactive()) {
suppressMessages(require(usethis))
}

30
.github/workflows/test-coverage.yaml vendored
View file

@ -4,10 +4,9 @@ on:
push:
branches: [main, master]
pull_request:
branches: [main, master]
name: test-coverage.yaml
permissions: read-all
name: test-coverage
jobs:
test-coverage:
@ -16,47 +15,38 @@ jobs:
GITHUB_PAT: ${{ secrets.GITHUB_TOKEN }}
steps:
- uses: actions/checkout@v4
- uses: actions/checkout@v3
- uses: r-lib/actions/setup-r@v2
with:
use-public-rspm: true
# - uses: r-lib/actions/setup-renv@v2
- uses: r-lib/actions/setup-r-dependencies@v2
with:
extra-packages: any::covr, any::xml2
extra-packages: any::covr
needs: coverage
- name: Test coverage
run: |
cov <- covr::package_coverage(
covr::codecov(
quiet = FALSE,
clean = FALSE,
install_path = file.path(normalizePath(Sys.getenv("RUNNER_TEMP"), winslash = "/"), "package")
install_path = file.path(Sys.getenv("RUNNER_TEMP"), "package")
)
print(cov)
covr::to_cobertura(cov)
shell: Rscript {0}
- uses: codecov/codecov-action@v4
with:
# Fail if error if not on PR, or if on PR and token is given
fail_ci_if_error: ${{ github.event_name != 'pull_request' || secrets.CODECOV_TOKEN }}
file: ./cobertura.xml
plugin: noop
disable_search: true
token: ${{ secrets.CODECOV_TOKEN }}
- name: Show testthat output
if: always()
run: |
## --------------------------------------------------------------------
find '${{ runner.temp }}/package' -name 'testthat.Rout*' -exec cat '{}' \; || true
find ${{ runner.temp }}/package -name 'testthat.Rout*' -exec cat '{}' \; || true
shell: bash
- name: Upload test results
if: failure()
uses: actions/upload-artifact@v4
uses: actions/upload-artifact@v3
with:
name: coverage-test-failures
path: ${{ runner.temp }}/package

4
.gitignore vendored
View file

@ -11,7 +11,3 @@ drafting
\.DS_Store
.DS_Store
cran-comments.md
~/REDCapCAST/inst/shiny-examples/casting/rsconnect
~/REDCapCAST/inst/shiny-examples/casting/rsconnect/
inst/shiny-examples/casting/functions.R
functions.R

51
DESCRIPTION
View file

@ -1,18 +1,16 @@
Package: REDCapCAST
Title: REDCap Metadata Casting and Castellated Data Handling
Version: 25.3.2
Title: REDCap Castellated Data Handling
Version: 24.6.1
Authors@R: c(
person("Andreas Gammelgaard", "Damsbo", email = "agdamsbo@clin.au.dk",
role = c("aut", "cre"),comment = c(ORCID = "0000-0002-7559-1154")),
person("Paul", "Egeler", email = "paulegeler@gmail.com", role = c("aut"),
comment = c(ORCID = "0000-0001-6948-9498")))
Description: Casting metadata for REDCap database creation and handling of
castellated data using repeated instruments and longitudinal projects in
'REDCap'. Keeps a focused data export approach, by allowing to only export
required data from the database. Also for casting new REDCap databases based
on datasets from other sources.
Originally forked from the R part of 'REDCapRITS' by Paul Egeler.
Description: Originally forked from the R part of 'REDCapRITS' by Paul Egeler.
See <https://github.com/pegeler/REDCapRITS>.
'REDCap' database casting and handling of castellated data when using
repeated instruments and longitudinal projects. Keeps a focused data export
approach, by allowing to only export required data from the database.
'REDCap' (Research Electronic Data Capture) is a secure, web-based software
platform designed to support data capture for research studies, providing
1) an intuitive interface for validated data capture; 2) audit trails for
@ -21,7 +19,7 @@ Description: Casting metadata for REDCap database creation and handling of
4) procedures for data integration and interoperability with external
sources (Harris et al (2009) <doi:10.1016/j.jbi.2008.08.010>;
Harris et al (2019) <doi:10.1016/j.jbi.2019.103208>).
Depends: R (>= 4.1.0)
Depends: R (>= 3.4.0)
Suggests:
httr,
jsonlite,
@ -29,17 +27,20 @@ Suggests:
Hmisc,
knitr,
rmarkdown,
gt,
ggplot2,
here,
styler,
devtools,
roxygen2,
spelling,
glue,
rhub,
rsconnect,
pkgconfig
shinythemes
License: GPL (>= 3)
Encoding: UTF-8
LazyData: true
RoxygenNote: 7.3.2
RoxygenNote: 7.3.1
URL: https://github.com/agdamsbo/REDCapCAST, https://agdamsbo.github.io/REDCapCAST/
BugReports: https://github.com/agdamsbo/REDCapCAST/issues
Imports:
@ -51,33 +52,21 @@ Imports:
purrr,
readr,
stats,
zip,
assertthat,
forcats,
vctrs,
gt,
bslib,
here,
glue,
gtsummary,
shiny,
haven,
openxlsx2,
readODS
Language: en-US
VignetteBuilder: knitr
haven,
readODS,
zip,
assertthat
Collate:
'REDCapCAST-package.R'
'utils.r'
'process_user_input.r'
'REDCap_split.r'
'as_factor.R'
'as_logical.R'
'create_instrument_meta.R'
'doc2dd.R'
'ds2dd.R'
'ds2dd_detailed.R'
'easy_redcap.R'
'export_redcap_instrument.R'
'fct_drop.R'
'html_styling.R'
'mtcars_redcap.R'
'read_redcap_instrument.R'
@ -86,3 +75,5 @@ Collate:
'redcapcast_data.R'
'redcapcast_meta.R'
'shiny_cast.R'
Language: en-US
VignetteBuilder: knitr

48
NAMESPACE
View file

@ -1,91 +1,47 @@
# Generated by roxygen2: do not edit by hand
S3method(as_factor,character)
S3method(as_factor,data.frame)
S3method(as_factor,factor)
S3method(as_factor,haven_labelled)
S3method(as_factor,labelled)
S3method(as_factor,logical)
S3method(as_factor,numeric)
S3method(as_logical,data.frame)
S3method(as_logical,default)
S3method(fct_drop,data.frame)
S3method(fct_drop,factor)
S3method(process_user_input,character)
S3method(process_user_input,data.frame)
S3method(process_user_input,default)
S3method(process_user_input,response)
export(REDCap_split)
export(all_na)
export(apply_factor_labels)
export(apply_field_label)
export(as_factor)
export(as_logical)
export(case_match_regex_list)
export(cast_data_overview)
export(cast_meta_overview)
export(char2choice)
export(char2cond)
export(clean_field_label)
export(clean_redcap_name)
export(compact_vec)
export(create_html_table)
export(create_instrument_meta)
export(cut_string_length)
export(d2w)
export(doc2dd)
export(ds2dd)
export(ds2dd_detailed)
export(easy_redcap)
export(export_redcap_instrument)
export(fct2num)
export(fct_drop)
export(file_extension)
export(focused_metadata)
export(format_redcap_factor)
export(format_subheader)
export(get_api_key)
export(get_attr)
export(guess_time_only)
export(guess_time_only_filter)
export(haven_all_levels)
export(html_tag_wrap)
export(is.labelled)
export(is_repeated_longitudinal)
export(match_fields_to_form)
export(named_levels)
export(nav_bar_page)
export(numchar2fct)
export(parse_data)
export(possibly_numeric)
export(possibly_roman)
export(process_user_input)
export(read_input)
export(read_redcap_instrument)
export(read_redcap_tables)
export(redcap_wider)
export(sanitize_split)
export(set_attr)
export(server_factory)
export(shiny_cast)
export(split_non_repeating_forms)
export(strsplitx)
export(suffix2label)
export(var2fct)
export(vec2choice)
export(ui_factory)
importFrom(REDCapR,redcap_event_instruments)
importFrom(REDCapR,redcap_metadata_read)
importFrom(REDCapR,redcap_read)
importFrom(forcats,as_factor)
importFrom(forcats,fct_drop)
importFrom(haven,read_dta)
importFrom(keyring,key_get)
importFrom(keyring,key_list)
importFrom(keyring,key_set)
importFrom(openxlsx2,read_xlsx)
importFrom(purrr,reduce)
importFrom(readODS,read_ods)
importFrom(readr,parse_time)
importFrom(readr,read_csv)
importFrom(readr,read_rds)
importFrom(tidyr,pivot_wider)
importFrom(tidyselect,all_of)

87
NEWS.md
View file

@ -1,86 +1,3 @@
# REDCapCAST 25.3.2
* BUG: The `redcap_wider()` function would attempt to pivot empty selection of columns from list, and failing, causing all functions relying on this to fail. Fixed by filtering out data.frames in list with no additional columns than the "generics".
# REDCapCAST 25.3.1
* FIX: `as_factor()` now interprets empty variables with empty levels attribute as logicals to avoid returning factors with empty levels.
* NEW: `as_logical()`: interprets vectors with two levels as logical if values matches supplied list of logical pairs like "TRUE"/"FALSE", "Yes"/"No" or 1/2. Eases interpretation of data from databases with minimal metadata. Works on vectors and for data.frames. Interprets vectors with single value also matching to any of supplied levels (Chooses first match pair if several matches).
* NEW: `easy_redcap()`: new parameter `data_format` to specify data format as c("wide", "list", "redcap", "long"). For now "redcap" and "long" is treated equally. This was added to ease MMRM analyses. In that case, missing baseline values can be carried forward as "last observation carried forward" using the `tidyr::fill()` function specifying variables to fill. Interesting discussion on filling data [here on Stackoverflow](https://stackoverflow.com/a/13810615). `redcap_read_tables()` now has the option "none" for the `split_forms` parameter to allow not splitting the data.
* FIX: `ds2dd_detailed()`: The `convert_logicals` parameter has been turned off by default and logicals are now interpreted as field type "truefalse". Converting logicals to factors would result in the numeric values being 1 for FALSE and 2 for TRUE, which is opposite of the traditional notation and could lead to serous problems if not handled correctly. This should solve it.
# REDCapCAST 25.1.1
The newly introduced extension of `forcats::fct_drop()` has been corrected to work as intended as a method.
Conversion of column names to `field_names` are aligning better with REDCap naming.
Shorten variable names above 100 characters (REDCap criteria; note recommended variable name length is <26)
Fixed a params conflict in easy_redcap() when specifying raw_or_label.
# REDCapCAST 24.12.1
This release attempts to solve problems hosting the shiny_cast app, while also implementing functions to preserve as much meta data as possible from the REDCap database when exporting data.
The hosting on shinyapps.io has given a lot of trouble recently. Modified package structure a little around the `shiny_cast()`, to accommodate an alternative hosting approach with all package functions included in a script instead of requiring the package.
* NEW: A new option to `raw_or_label` in `read_redcap_tables()` has been added: "both". Get raw values with REDCap labels applied as labels. Use `as_factor()` to format factors with original labels and use the `gtsummary` package to easily get beautiful tables with original labels from REDCap. Use `fct_drop()` to drop empty levels.
* NEW: fct_drop() has been added with an extension to `forcats::fct_drop()`, that works across data.frames. Use as `fct_drop()`.
* CHANGE: the default data export method of `easy_redcap()` has been changed to use the new labelled data export with `read_redcap_tables()`.
# REDCapCAST 24.11.3
* BUG: shiny_cast() fails to load as I missed loading REDCapCAST library in ui.r. Fixed. Tests would be great.
# REDCapCAST 24.11.2
24.11.1 was rejected on CRAN based on wrong title capitalisation. This was an opportunity to extend the package overhaul. And this actually turned out to be a major step towards a very usable shiny app which have received most of the focus.
I have implemented option to specify categorical variables to factorize, but doing this with a modified version of {forcats} and {haven}'s `as_factor()`, that will preserve any attributes applied to the data to be able to upload and cast REDCap meta data from richly formatted data (use .rds). No matter the input type, all input is parsed using the default options from the {readr} package. Also to avoid mis-labelling, logicals are converted to factors as REDCap truefalse class follows different naming conversion compared to R. Also correct support for variable labels as field labels (use .rds formatted data and label with labelled::var_label())
Vignettes and documentation have been restructured.
This package has been detached from the REDCapRITS, which it was originally forked from. The data split function will be kept, while testing will be rewritten. This projects has evolved away from the original fork.
# REDCapCAST 24.11.1
Revised tests.
Documentation has been slightly updated to highlight the shiny app for casting REDCap metadata. I am working on hosting my own Shiny Server.
### Functions:
* Bug: 'form.name' specified to 'ds2dd_detailed()' was ignored. Corrected to only be ignored if 'form.sep' is specified. Added handling of re-occurring `form.sep` pattern.
* New: `export_redcap_instrument()` is a new version of `create_instrument_meta()`, that will only export a single instrument. Multiple instrument export can be done with `lapply()` or `purrr::map()`. This allows for inclusion of this functionality in the Shiny implementation and is easier to handle. `create_instrument_meta()` is deprecated.
* Improved: `shiny_cast()` app has been updated to actually work if you install the package and not clones the whole repository.
### Shiny:
* New: Major overhaul of the app interface with the introduction of `bslib` for building the page. Also Detailed documentation added for the app workflow.
* New: Export a REDCap instrument ready to add to your database based on an uploaded spreadsheet. This is thanks to the `export_redcap_instrument()` function. This functionality is intended for projects in production and adding instruments should be handled manually and not by API upload.
* Bug: Export datadictionary with "" instead of "NA" for NAs. Upload to REDCap failed. Not anymore.
The shiny implementation is included with this package. Implementing in shinylive may be looked into again later.
# REDCapCAST 24.10.3
Updated links and spelling.
# REDCapCAST 24.10.1
Minor changes to pass tests and renv is out. `rhub` is really not running as smooth as previously.
# REDCapCAST 24.6.1
### Functions
@ -114,7 +31,7 @@ Minor changes to pass tests and renv is out. `rhub` is really not running as smo
* NEW: `read_redcap_instrument()`: convenience function to retrieve complete instrument. Goes a little against the focused approach. With `REDCapR::redcap_read()` you can specify a form to download. You have to also specify the record id variable though. This is done for you with `read_redcap_instrument()`. Nothing fancy.
* NEW: `shiny_cast()`: [Shiny](https://shiny.posit.co/) application to ease the process of converting a spreadsheet/data set to a REDCap database. The app runs locally and data is transferred securely. You can just create and upload the data dictionary, but you can also transfer the given data in the same process. I plan to host the app with shinyapps.io, but for now you can run it locally.
* NEW: `shiny_cast()`: [Shiny](https://www.rstudio.com/products/shiny/) application to ease the process of converting a spreadsheet/data set to a REDCap database. The app runs locally and data is transferred securely. You can just create and upload the data dictionary, but you can also transfer the given data in the same process. I plan to host the app with shinyapps.io, but for now you can run it locally.
### Other
@ -185,7 +102,7 @@ The main goal this package is to keep the option to only export a defined subset
### Functions:
* `read_redcap_tables()` **NEW**: this function is mainly an implementation of the combined use of `REDCapR::redcap_read()` and `REDCap_split()` to maintain the focused nature of `REDCapR::redcap_read()`, to only download the specified data. Also implements tests of valid form names and event names. The usual fall-back solution was to get all data.
* `read_redcap_tables()` **NEW**: this function is mainly an implementation of the combined use of `REDCapR::readcap_read()` and `REDCap_split()` to maintain the focused nature of `REDCapR::readcap_read()`, to only download the specified data. Also implements tests of valid form names and event names. The usual fall-back solution was to get all data.
* `redcap_wider()` **NEW**: this function pivots the long data frames from `read_redcap_tables()` using `tidyr::pivot_wider()`.

7
R/REDCapCAST-package.R
View file

@ -1,7 +0,0 @@
#' @keywords internal
"_PACKAGE"
## usethis namespace: start
#' @importFrom openxlsx2 read_xlsx
## usethis namespace: end
NULL

16
R/REDCap_split.r
View file

@ -11,10 +11,11 @@
#' \code{data.frame}, \code{response}, or \code{character} vector containing
#' JSON from an API call.
#' @param primary_table_name Name given to the list element for the primary
#' output table. Ignored if \code{forms = 'all'}.
#' output table (as described in \emph{README.md}). Ignored if
#' \code{forms = 'all'}.
#' @param forms Indicate whether to create separate tables for repeating
#' instruments only or for all forms.
#' @author Paul W. Egeler
#' @author Paul W. Egeler, M.S., GStat
#' @examples
#' \dontrun{
#' # Using an API call -------------------------------------------------------
@ -39,7 +40,7 @@
#' )
#'
#' # Convert exported JSON strings into a list of data.frames
#' REDCapCAST::REDCap_split(records, metadata)
#' REDCapRITS::REDCap_split(records, metadata)
#'
#' # Using a raw data export -------------------------------------------------
#'
@ -52,7 +53,7 @@
#' )
#'
#' # Split the tables
#' REDCapCAST::REDCap_split(records, metadata)
#' REDCapRITS::REDCap_split(records, metadata)
#'
#' # In conjunction with the R export script ---------------------------------
#'
@ -69,7 +70,7 @@
#' metadata <- read.csv("ExampleProject_DataDictionary_2018-06-03.csv")
#'
#' # Split the tables
#' REDCapCAST::REDCap_split(data, metadata)
#' REDCapRITS::REDCap_split(data, metadata)
#' setwd(old)
#' }
#' @return A list of \code{"data.frame"}s. The number of tables will differ
@ -86,11 +87,6 @@ REDCap_split <- function(records,
metadata,
primary_table_name = "",
forms = c("repeating", "all")) {
# Processing metadata to reflect focused dataset
# metadata <- focused_metadata(metadata, names(records))
# Requires new testing setup. Not doing that now.
# Process user input
records <- process_user_input(records)
metadata <-

477
R/as_factor.R
View file

@ -1,477 +0,0 @@
#' Convert labelled vectors to factors while preserving attributes
#'
#' This extends \link[forcats]{as_factor} as well as \link[haven]{as_factor}, by appending
#' original attributes except for "class" after converting to factor to avoid
#' ta loss in case of rich formatted and labelled data.
#'
#' Please refer to parent functions for extended documentation.
#' To avoid redundancy calls and errors, functions are copy-pasted here
#'
#' Empty variables with empty levels attribute are interpreted as logicals
#'
#' @param x Object to coerce to a factor.
#' @param ... Other arguments passed down to method.
#' @param only_labelled Only apply to labelled columns?
#' @export
#' @examples
#' # will preserve all attributes
#' c(1, 4, 3, "A", 7, 8, 1) |> as_factor()
#' structure(c(1, 2, 3, 2, 10, 9),
#' labels = c(Unknown = 9, Refused = 10)
#' ) |>
#' as_factor() |>
#' dput()
#'
#' structure(c(1, 2, 3, 2, 10, 9),
#' labels = c(Unknown = 9, Refused = 10),
#' class = "haven_labelled"
#' ) |>
#' as_factor() |> class()
#' structure(rep(NA,10),
#' class = c("labelled")
#' ) |>
#' as_factor() |> summary()
#'
#' rep(NA,10) |> as_factor()
#'
#' @importFrom forcats as_factor
#' @export
#' @name as_factor
as_factor <- function(x, ...) {
UseMethod("as_factor")
}
#' @rdname as_factor
#' @export
as_factor.factor <- function(x, ...) {
x
}
#' @rdname as_factor
#' @export
as_factor.logical <- function(x, ...) {
labels <- get_attr(x)
x <- factor(x, levels = c("FALSE", "TRUE"))
set_attr(x, labels, overwrite = FALSE)
}
#' @rdname as_factor
#' @export
as_factor.numeric <- function(x, ...) {
labels <- get_attr(x)
x <- factor(x)
set_attr(x, labels, overwrite = FALSE)
}
#' @rdname as_factor
#' @export
as_factor.character <- function(x, ...) {
labels <- get_attr(x)
if (possibly_roman(x)) {
x <- factor(x)
} else {
x <- structure(
forcats::fct_inorder(x),
label = attr(x, "label", exact = TRUE)
)
}
set_attr(x, labels, overwrite = FALSE)
}
#' @param ordered If `TRUE` create an ordered (ordinal) factor, if
#' `FALSE` (the default) create a regular (nominal) factor.
#' @param levels How to create the levels of the generated factor:
#'
#' * "default": uses labels where available, otherwise the values.
#' Labels are sorted by value.
#' * "both": like "default", but pastes together the level and value
#' * "label": use only the labels; unlabelled values become `NA`
#' * "values": use only the values
#' @rdname as_factor
#' @export
as_factor.haven_labelled <- function(x, levels = c("default", "labels", "values", "both"),
ordered = FALSE, ...) {
labels_all <- get_attr(x)
levels <- match.arg(levels)
label <- attr(x, "label", exact = TRUE)
labels <- attr(x, "labels")
if (levels %in% c("default", "both")) {
if (levels == "both") {
names(labels) <- paste0("[", labels, "] ", names(labels))
}
# Replace each value with its label
vals <- unique(vctrs::vec_data(x))
levs <- replace_with(vals, unname(labels), names(labels))
# Ensure all labels are preserved
levs <- sort(c(stats::setNames(vals, levs), labels), na.last = TRUE)
levs <- unique(names(levs))
x <- replace_with(vctrs::vec_data(x), unname(labels), names(labels))
x <- factor(x, levels = levs, ordered = ordered)
} else if (levels == "labels") {
levs <- unname(labels)
labs <- names(labels)
x <- replace_with(vctrs::vec_data(x), levs, labs)
x <- factor(x, unique(labs), ordered = ordered)
} else if (levels == "values") {
if (all(x %in% labels)) {
levels <- unname(labels)
} else {
levels <- sort(unique(vctrs::vec_data(x)))
}
x <- factor(vctrs::vec_data(x), levels, ordered = ordered)
}
x <- structure(x, label = label)
out <- set_attr(x, labels_all, overwrite = FALSE)
if (all_na(out) & length(levels(out))==0){
as_factor.logical(out)
} else {
out
}
}
#' @export
#' @rdname as_factor
as_factor.labelled <- as_factor.haven_labelled
#' @rdname as_factor
#' @export
as_factor.data.frame <- function(x, ..., only_labelled = TRUE) {
if (only_labelled) {
labelled <- vapply(x, is.labelled, logical(1))
x[labelled] <- lapply(x[labelled], as_factor, ...)
} else {
x[] <- lapply(x, as_factor, ...)
}
x
}
#' Tests for multiple label classes
#'
#' @param x data
#' @param classes classes to test
#'
#' @return logical
#' @export
#'
#' @examples
#' structure(c(1, 2, 3, 2, 10, 9),
#' labels = c(Unknown = 9, Refused = 10),
#' class = "haven_labelled"
#' ) |> is.labelled()
is.labelled <- function(x, classes = c("haven_labelled", "labelled")) {
classes |>
sapply(\(.class){
inherits(x, .class)
}) |>
any()
}
replace_with <- function(x, from, to) {
stopifnot(length(from) == length(to))
out <- x
# First replace regular values
matches <- match(x, from, incomparables = NA)
if (anyNA(matches)) {
out[!is.na(matches)] <- to[matches[!is.na(matches)]]
} else {
out <- to[matches]
}
# Then tagged missing values
tagged <- haven::is_tagged_na(x)
if (!any(tagged)) {
return(out)
}
matches <- match(haven::na_tag(x), haven::na_tag(from), incomparables = NA)
# Could possibly be faster to use anyNA(matches)
out[!is.na(matches)] <- to[matches[!is.na(matches)]]
out
}
#' Get named vector of factor levels and values
#'
#' @param data factor
#' @param label character string of attribute with named vector of factor labels
#' @param na.label character string to refactor NA values. Default is NULL.
#' @param na.value new value for NA strings. Ignored if na.label is NULL.
#' Default is 99.
#' @param sort.numeric sort factor levels if levels are numeric. Default is TRUE
#'
#' @return named vector
#' @export
#'
#' @examples
#' structure(c(1, 2, 3, 2, 10, 9),
#' labels = c(Unknown = 9, Refused = 10),
#' class = "haven_labelled"
#' ) |>
#' as_factor() |>
#' named_levels()
#' structure(c(1, 2, 3, 2, 10, 9),
#' labels = c(Unknown = 9, Refused = 10),
#' class = "labelled"
#' ) |>
#' as_factor() |>
#' named_levels()
named_levels <- function(data, label = "labels", na.label = NULL, na.value = 99, sort.numeric=TRUE) {
stopifnot(is.factor(data))
if (!is.null(na.label)) {
attrs <- attributes(data)
lvls <- as.character(data)
lvls[is.na(lvls)] <- na.label
vals <- as.numeric(data)
vals[is.na(vals)] <- na.value
lbls <- data.frame(
name = lvls,
value = vals
) |>
unique() |>
(\(d){
stats::setNames(d$value, d$name)
})() |>
sort()
data <- do.call(
structure,
c(
list(.Data = match(vals, lbls)),
attrs[-match("levels", names(attrs))],
list(
levels = names(lbls),
labels = lbls
)
)
)
}
# Handle empty factors
if (all_na(data)) {
d <- data.frame(
name = levels(data),
value = seq_along(levels(data))
)
} else {
d <- data.frame(
name = levels(data)[data],
value = as.numeric(data)
) |>
unique() |>
stats::na.omit()
}
## Applying labels
attr_l <- attr(x = data, which = label, exact = TRUE)
if (length(attr_l) != 0) {
if (all(names(attr_l) %in% d$name)) {
d$value[match(names(attr_l), d$name)] <- unname(attr_l)
} else if (all(d$name %in% names(attr_l)) && nrow(d) < length(attr_l)) {
d <- data.frame(
name = names(attr_l),
value = unname(attr_l)
)
} else {
d$name[match(attr_l, d$name)] <- names(attr_l)
d$value[match(names(attr_l), d$name)] <- unname(attr_l)
}
}
out <- stats::setNames(d$value, d$name)
## Sort if levels are numeric
## Else, they appear in order of appearance
if (possibly_numeric(levels(data)) && sort.numeric) {
out <- out |> sort()
}
out
}
#' Test if vector can be interpreted as roman numerals
#'
#' @param data character vector
#'
#' @return logical
#' @export
#'
#' @examples
#' sample(1:100, 10) |>
#' as.roman() |>
#' possibly_roman()
#' sample(c(TRUE, FALSE), 10, TRUE) |> possibly_roman()
#' rep(NA, 10) |> possibly_roman()
possibly_roman <- function(data) {
if (all(is.na(data))) {
return(FALSE)
}
identical(as.character(data),
as.character(suppressWarnings(utils::as.roman(data))))
}
#' Allows conversion of factor to numeric values preserving original levels
#'
#' @param data vector
#'
#' @return numeric vector
#' @export
#'
#' @examples
#' c(1, 4, 3, "A", 7, 8, 1) |>
#' as_factor() |>
#' fct2num()
#'
#' structure(c(1, 2, 3, 2, 10, 9),
#' labels = c(Unknown = 9, Refused = 10),
#' class = "haven_labelled"
#' ) |>
#' as_factor() |>
#' fct2num()
#'
#' structure(c(1, 2, 3, 2, 10, 9),
#' labels = c(Unknown = 9, Refused = 10),
#' class = "labelled"
#' ) |>
#' as_factor() |>
#' fct2num()
#'
#' structure(c(1, 2, 3, 2, 10, 9),
#' labels = c(Unknown = 9, Refused = 10)
#' ) |>
#' as_factor() |>
#' fct2num()
fct2num <- function(data) {
stopifnot(is.factor(data))
if (is.character(named_levels(data))) {
values <- as.numeric(named_levels(data))
} else {
values <- named_levels(data)
}
out <- values[match(data, names(named_levels(data)))]
## If no NA on numeric coercion, of original names, then return
## original numeric names, else values
if (possibly_numeric(names(out))) {
out <- as.numeric(names(out))
}
unname(out)
}
#' Tests if vector can be interpreted as numeric without introducing NAs by
#' coercion
#'
#' @param data vector
#'
#' @return logical
#' @export
#'
#' @examples
#' c("1","5") |> possibly_numeric()
#' c("1","5","e") |> possibly_numeric()
possibly_numeric <- function(data) {
suppressWarnings(
length(stats::na.omit(as.numeric(data))) ==
length(data)
)
}
#' Extract attribute. Returns NA if none
#'
#' @param data vector
#' @param attr attribute name
#'
#' @return character vector
#' @export
#'
#' @examples
#' attr(mtcars$mpg, "label") <- "testing"
#' do.call(c, sapply(mtcars, get_attr))
#' \dontrun{
#' mtcars |>
#' numchar2fct(numeric.threshold = 6) |>
#' ds2dd_detailed()
#' }
get_attr <- function(data, attr = NULL) {
if (is.null(attr)) {
attributes(data)
} else {
a <- attr(data, attr, exact = TRUE)
if (is.null(a)) {
NA
} else {
a
}
}
}
#' Set attributes for named attribute. Appends if attr is NULL
#'
#' @param data vector
#' @param label label
#' @param attr attribute name
#' @param overwrite overwrite existing attributes. Default is FALSE.
#'
#' @return vector with attribute
#' @export
#'
set_attr <- function(data, label, attr = NULL, overwrite = FALSE) {
# browser()
if (is.null(attr)) {
## Has to be a named list
## Will not fail, but just return original data
if (!is.list(label) | length(label) != length(names(label))) {
return(data)
}
## Only include named labels
label <- label[!is.na(names(label))]
if (!overwrite) {
label <- label[!names(label) %in% names(attributes(data))]
}
attributes(data) <- c(attributes(data), label)
} else {
attr(data, attr) <- label
}
data
}
#' Finish incomplete haven attributes substituting missings with values
#'
#' @param data haven labelled variable
#'
#' @return named vector
#' @export
#'
#' @examples
#' ds <- structure(c(1, 2, 3, 2, 10, 9),
#' labels = c(Unknown = 9, Refused = 10),
#' class = "haven_labelled"
#' )
#' haven::is.labelled(ds)
#' attributes(ds)
#' ds |> haven_all_levels()
haven_all_levels <- function(data) {
stopifnot(haven::is.labelled(data))
if (length(attributes(data)$labels) == length(unique(data))) {
out <- attributes(data)$labels
} else {
att <- attributes(data)$labels
out <- c(unique(data[!data %in% att]), att) |>
stats::setNames(c(unique(data[!data %in% att]), names(att)))
}
out
}

116
R/as_logical.R
View file

@ -1,116 +0,0 @@
#' Interpret specific binary values as logicals
#'
#' @param x vector or data.frame
#' @param values list of values to interpret as logicals. First value is
#' @param ... ignored
#' interpreted as TRUE.
#'
#' @returns vector
#' @export
#'
#' @examples
#' c(sample(c("TRUE", "FALSE"), 20, TRUE), NA) |>
#' as_logical() |>
#' class()
#' ds <- dplyr::tibble(
#' B = factor(sample(c(1, 2), 20, TRUE)),
#' A = factor(sample(c("TRUE", "FALSE"), 20, TRUE)),
#' C = sample(c(3, 4), 20, TRUE),
#' D = factor(sample(c("In", "Out"), 20, TRUE))
#' )
#' ds |>
#' as_logical() |>
#' sapply(class)
#' ds$A |> class()
#' sample(c("TRUE",NA), 20, TRUE) |>
#' as_logical()
#' as_logical(0)
#' @name as_logical
as_logical <- function(x,
values = list(
c("TRUE", "FALSE"),
c("Yes", "No"),
c(1, 0),
c(1, 2)
),
...) {
UseMethod("as_logical")
}
#' @rdname as_logical
#' @export
as_logical.data.frame <- function(x,
values = list(
c("TRUE", "FALSE"),
c("Yes", "No"),
c(1, 0),
c(1, 2)
),
...) {
as.data.frame(lapply(x, \(.x){
as_logical.default(x = .x, values = values)
}))
}
#' @rdname as_logical
#' @export
as_logical.default <- function(x,
values = list(
c("TRUE", "FALSE"),
c("Yes", "No"),
c(1, 0),
c(1, 2)
),
...) {
label <- REDCapCAST::get_attr(x, "label")
# browser()
out <- c()
if (any(
c(
"character",
"factor",
"numeric"
) %in% class(x)
)){
if (length(unique(x[!is.na(x)])) == 2) {
if (is.factor(x)) {
match_index <- which(sapply(values, \(.x){
all(.x %in% levels(x))
}))
} else {
match_index <- which(sapply(values, \(.x){
all(.x %in% x)
}))
}
} else if (length(unique(x[!is.na(x)])) == 1){
if (is.factor(x)) {
match_index <- which(sapply(values, \(.x){
any(.x %in% levels(x))
}))
} else {
match_index <- which(sapply(values, \(.x){
any(.x %in% x)
}))
}
} else {
match_index <- c()
}
if (length(match_index) == 1) {
out <- x == values[[match_index]][1]
} else if (length(match_index) > 1) {
# If matching several, the first match is used.
out <- x == values[[match_index[1]]][1]
}
}
if (length(out) == 0) {
out <- x
}
if (!is.na(label)) {
out <- REDCapCAST::set_attr(out, label = label, attr = "label")
}
out
}

50
R/create_instrument_meta.R Normal file
View file

@ -0,0 +1,50 @@
#' Create zips file with necessary content based on data set
#'
#' @description
#' Metadata can be added by editing the data dictionary of a project in the
#' initial design phase. If you want to later add new instruments, this can be
#' used to add instrument(s) to a project in production.
#'
#' @param data metadata for the relevant instrument.
#' Could be from `ds2dd_detailed()`
#' @param dir destination dir for the instrument zip. Default is the current WD.
#' @param record.id flag to omit the first row of the data dictionary assuming
#' this is the record_id field which should not be included in the instrument.
#' Default is TRUE.
#'
#' @return list
#' @export
#'
#' @examples
#' data <- iris |>
#' ds2dd_detailed(add.auto.id = TRUE,
#' form.name=sample(c("b","c"),size = 6,replace = TRUE,prob=rep(.5,2))) |>
#' purrr::pluck("meta")
#' # data |> create_instrument_meta()
#'
#' data <- iris |>
#' ds2dd_detailed(add.auto.id = FALSE) |>
#' purrr::pluck("data")
#' names(data) <- glue::glue("{sample(x = c('a','b'),size = length(names(data)),
#' replace=TRUE,prob = rep(x=.5,2))}__{names(data)}")
#' data <- data |> ds2dd_detailed(form.sep="__")
#' # data |>
#' # purrr::pluck("meta") |>
#' # create_instrument_meta(record.id = FALSE)
create_instrument_meta <- function(data,
dir = here::here(""),
record.id = TRUE) {
if (record.id) {
data <- data[-1,]
}
temp_dir <- tempdir()
split(data,data$form_name) |> purrr::imap(function(.x,.i){
utils::write.csv(.x, paste0(temp_dir, "/instrument.csv"), row.names = FALSE, na = "")
writeLines("REDCapCAST", paste0(temp_dir, "/origin.txt"))
zip::zip(paste0(dir, "/", .i, Sys.Date(), ".zip"),
files = c("origin.txt", "instrument.csv"),
root = temp_dir
)
})
}

89
R/ds2dd.R Normal file
View file

@ -0,0 +1,89 @@
utils::globalVariables(c("metadata_names"))
#' (DEPRECATED) Data set to data dictionary function
#'
#' @description
#' Creates a very basic data dictionary skeleton. Please see `ds2dd_detailed()`
#' for a more advanced function.
#'
#' @details
#' Migrated from stRoke ds2dd(). Fits better with the functionality of
#' 'REDCapCAST'.
#' @param ds data set
#' @param record.id name or column number of id variable, moved to first row of
#' data dictionary, character of integer. Default is "record_id".
#' @param form.name vector of form names, character string, length 1 or length
#' equal to number of variables. Default is "basis".
#' @param field.type vector of field types, character string, length 1 or length
#' equal to number of variables. Default is "text.
#' @param field.label vector of form names, character string, length 1 or length
#' equal to number of variables. Default is NULL and is then identical to field
#' names.
#' @param include.column.names Flag to give detailed output including new
#' column names for original data set for upload.
#' @param metadata Metadata column names. Default is the included
#' REDCapCAST::metadata_names.
#'
#' @return data.frame or list of data.frame and vector
#' @export
#'
#' @examples
#' redcapcast_data$record_id <- seq_len(nrow(redcapcast_data))
#' ds2dd(redcapcast_data, include.column.names=TRUE)
ds2dd <-
function(ds,
record.id = "record_id",
form.name = "basis",
field.type = "text",
field.label = NULL,
include.column.names = FALSE,
metadata = metadata_names) {
dd <- data.frame(matrix(ncol = length(metadata), nrow = ncol(ds)))
colnames(dd) <- metadata
if (is.character(record.id) && !record.id %in% colnames(ds)) {
stop("Provided record.id is not a variable name in provided data set.")
}
# renaming to lower case and substitute spaces with underscore
field.name <- gsub(" ", "_", tolower(colnames(ds)))
# handles both character and integer
colsel <-
colnames(ds) == colnames(ds[record.id])
if (summary(colsel)[3] != 1) {
stop("Provided record.id has to be or refer to a uniquely named column.")
}
dd[, "field_name"] <-
c(field.name[colsel], field.name[!colsel])
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."
)
}
dd[, "form_name"] <- form.name
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."
)
}
dd[, "field_type"] <- field.type
if (is.null(field.label)) {
dd[, "field_label"] <- dd[, "field_name"]
} else
dd[, "field_label"] <- field.label
if (include.column.names){
list("DataDictionary"=dd,"Column names"=field.name)
} else dd
}

568
R/ds2dd_detailed.R
View file

@ -1,4 +1,5 @@
utils::globalVariables(c(
"stats::setNames",
"field_name",
"field_type",
"select_choices_or_calculations",
@ -97,97 +98,6 @@ hms2character <- function(data) {
dplyr::bind_cols()
}
#' (DEPRECATED) Data set to data dictionary function
#'
#' @description
#' Creates a very basic data dictionary skeleton. Please see `ds2dd_detailed()`
#' for a more advanced function.
#'
#' @details
#' Migrated from stRoke ds2dd(). Fits better with the functionality of
#' 'REDCapCAST'.
#' @param ds data set
#' @param record.id name or column number of id variable, moved to first row of
#' data dictionary, character of integer. Default is "record_id".
#' @param form.name vector of form names, character string, length 1 or length
#' equal to number of variables. Default is "basis".
#' @param field.type vector of field types, character string, length 1 or length
#' equal to number of variables. Default is "text.
#' @param field.label vector of form names, character string, length 1 or length
#' equal to number of variables. Default is NULL and is then identical to field
#' names.
#' @param include.column.names Flag to give detailed output including new
#' column names for original data set for upload.
#' @param metadata Metadata column names. Default is the included
#' names(REDCapCAST::redcapcast_meta).
#'
#' @return data.frame or list of data.frame and vector
#' @export
#'
#' @examples
#' redcapcast_data$record_id <- seq_len(nrow(redcapcast_data))
#' ds2dd(redcapcast_data, include.column.names = TRUE)
ds2dd <-
function(ds,
record.id = "record_id",
form.name = "basis",
field.type = "text",
field.label = NULL,
include.column.names = FALSE,
metadata = names(REDCapCAST::redcapcast_meta)) {
dd <- data.frame(matrix(ncol = length(metadata), nrow = ncol(ds)))
colnames(dd) <- metadata
if (is.character(record.id) && !record.id %in% colnames(ds)) {
stop("Provided record.id is not a variable name in provided data set.")
}
# renaming to lower case and substitute spaces with underscore
field.name <- gsub(" ", "_", tolower(colnames(ds)))
# handles both character and integer
colsel <-
colnames(ds) == colnames(ds[record.id])
if (summary(colsel)[3] != 1) {
stop("Provided record.id has to be or refer to a uniquely named column.")
}
dd[, "field_name"] <-
c(field.name[colsel], field.name[!colsel])
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."
)
}
dd[, "form_name"] <- form.name
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."
)
}
dd[, "field_type"] <- field.type
if (is.null(field.label)) {
dd[, "field_label"] <- dd[, "field_name"]
} else {
dd[, "field_label"] <- field.label
}
if (include.column.names) {
list("DataDictionary" = dd, "Column names" = field.name)
} else {
dd
}
}
#' Extract data from stata file for data dictionary
#'
#' @details
@ -207,7 +117,7 @@ ds2dd <-
#' ncol(data). Default is NULL and "data" is used.
#' @param form.sep If supplied dataset has form names as suffix or prefix to the
#' column/variable names, the seperator can be specified. If supplied, the
#' form.name is ignored. Default is NULL.
#' form.sep is ignored. Default is NULL.
#' @param form.prefix Flag to set if form is prefix (TRUE) or suffix (FALSE) to
#' the column names. Assumes all columns have pre- or suffix if specified.
#' @param field.type manually specify field type(s). Vector of length 1 or
@ -224,41 +134,28 @@ ds2dd <-
#' or attribute `factor.labels.attr` for haven_labelled data set (imported .dta
#' file with `haven::read_dta()`).
#' @param metadata redcap metadata headings. Default is
#' names(REDCapCAST::redcapcast_meta).
#' @param convert.logicals convert logicals to factor. Default is TRUE.
#' REDCapCAST:::metadata_names.
#' @param validate.time Flag to validate guessed time columns
#' @param time.var.sel.pos Positive selection regex string passed to
#' `gues_time_only_filter()` as sel.pos.
#' @param time.var.sel.neg Negative selection regex string passed to
#' `gues_time_only_filter()` as sel.neg.
#'
#' @return list of length 2
#' @export
#'
#' @examples
#' ## Basic parsing with default options
#' requireNamespace("REDCapCAST")
#' redcapcast_data |>
#' dplyr::select(-dplyr::starts_with("redcap_")) |>
#' ds2dd_detailed()
#'
#' ## Adding a record_id field
#' data <- REDCapCAST::redcapcast_data
#' data |> ds2dd_detailed(validate.time = TRUE)
#' data |> ds2dd_detailed()
#' iris |> ds2dd_detailed(add.auto.id = TRUE)
#'
#' ## Passing form name information to function
#' iris |>
#' ds2dd_detailed(
#' add.auto.id = TRUE,
#' form.name = sample(c("b", "c"), size = 6, replace = TRUE, prob = rep(.5, 2))
#' ) |>
#' purrr::pluck("meta")
#' mtcars |>
#' dplyr::mutate(unknown = NA) |>
#' numchar2fct() |>
#' ds2dd_detailed(add.auto.id = TRUE)
#'
#' ## Using column name suffix to carry form name
#' mtcars |> ds2dd_detailed(add.auto.id = TRUE)
#' data <- iris |>
#' ds2dd_detailed(add.auto.id = TRUE) |>
#' purrr::pluck("data")
#' names(data) <- glue::glue("{sample(x = c('a','b'),size = length(names(data)),
#' replace=TRUE,prob = rep(x=.5,2))}__{names(data)}")
#' data |> ds2dd_detailed(form.sep = "__")
#' data |> ds2dd_detailed(form.sep="__")
ds2dd_detailed <- function(data,
add.auto.id = FALSE,
date.format = "dmy",
@ -270,29 +167,53 @@ ds2dd_detailed <- function(data,
field.label.attr = "label",
field.validation = NULL,
metadata = names(REDCapCAST::redcapcast_meta),
convert.logicals = FALSE) {
short_names <- colnames(data) |>
lapply(\(.x) cut_string_length(.x, l = 90)) |>
purrr::reduce(c)
data <- stats::setNames(data, short_names)
if (convert.logicals) {
data <- data |>
## Converts logical to factor, which overwrites attributes
dplyr::mutate(dplyr::across(dplyr::where(is.logical), as_factor))
## Problematic example:
## as.logical(sample(0:1,10,TRUE)) |> as.factor() |> as.numeric()
## Possible solution would be to subtract values by 1, so
## "0, FALSE | 1, TRUE" like native REDCap
}
validate.time = FALSE,
time.var.sel.pos = "[Tt]i[d(me)]",
time.var.sel.neg = "[Dd]at[eo]") {
## Handles the odd case of no id column present
if (add.auto.id) {
data <- dplyr::tibble(
record_id = seq_len(nrow(data)),
data
)
message("A default id column has been added")
}
if (validate.time) {
return(data |> guess_time_only_filter(validate = TRUE))
}
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.")
data.source <- "dta"
} else {
data.source <- ""
}
## data 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
) |>
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
) |>
lapply(\(x)class(x)[1]) |>
(\(x)do.call(c, x))()
}
## ---------------------------------------
@ -306,63 +227,52 @@ ds2dd_detailed <- function(data,
dplyr::tibble()
## form_name and field_name
if (!is.null(form.sep)) {
if (form.sep != "") {
parts <- strsplit(names(data), split = form.sep)
## form.sep should be unique, but handles re-occuring pattern (by only considering first or last) and form.prefix defines if form is prefix or suffix
## The other split part is used as field names
if (form.prefix) {
dd$form_name <- clean_redcap_name(Reduce(c, lapply(parts, \(.x) .x[[1]])))
dd$field_name <- Reduce(c, lapply(parts, \(.x) paste(.x[seq_len(length(.x))[-1]], collapse = form.sep)))
} else {
dd$form_name <- clean_redcap_name(Reduce(c, lapply(parts, \(.x) .x[[length(.x)]])))
dd$field_name <- Reduce(c, lapply(parts, \(.x) paste(.x[seq_len(length(.x) - 1)], collapse = form.sep)))
}
## To preserve original
colnames(data) <- dd$field_name
dd$field_name <- tolower(dd$field_name)
if (form.sep!=""){
suppressMessages(nms <- strsplit(names(data), split = form.sep) |>
dplyr::bind_cols())
## Assumes form.sep only occurs once and form.prefix defines if form is prefix or suffix
dd$form_name <- clean_redcap_name(dplyr::slice(nms,ifelse(form.prefix, 1, 2)))
## The other split part is used as field names
dd$field_name <- dplyr::slice(nms,ifelse(!form.prefix, 1, 2)) |> as.character()
} else {
dd$form_name <- "data"
# dd$field_name <- gsub(" ", "_", tolower(colnames(data)))
dd$field_name <- clean_redcap_name(colnames(data))
dd$field_name <- gsub(" ", "_", tolower(colnames(data)))
}
} else {
} else if (is.null(form.sep)) {
## if no form name prefix, the colnames are used as field_names
# dd$field_name <- gsub(" ", "_", tolower(colnames(data)))
dd$field_name <- clean_redcap_name(colnames(data))
if (is.null(form.name)) {
dd$form_name <- "data"
dd$field_name <- gsub(" ", "_", tolower(colnames(data)))
} else if (is.null(form.name)) {
dd$form_name <- "data"
} else {
if (length(form.name) == 1 || length(form.name) == nrow(dd)) {
dd$form_name <- form.name
} else {
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).")
}
stop("Length of supplied 'form.name' has to be one (1) or ncol(data).")
}
}
## field_label
if (is.null(field.label)) {
dd$field_label <- data |>
sapply(function(x) {
get_attr(x, attr = field.label.attr) |>
compact_vec()
})
if (data.source == "dta") {
dd$field_label <- data |>
lapply(function(x) {
if (haven::is.labelled(x)) {
attributes(x)[[field.label.attr]]
} else {
NA
}
}) |>
(\(x)do.call(c, x))()
}
dd <-
dd |>
dplyr::mutate(
field_label = dplyr::if_else(is.na(field_label),
colnames(data),
field_label
)
)
dd |> dplyr::mutate(field_label = dplyr::if_else(is.na(field_label),
field_name, field_label
))
} else {
## It really should be unique for each: same length as number of variables
if (length(field.label) == 1 || length(field.label) == nrow(dd)) {
dd$field_label <- field.label
} else {
@ -370,7 +280,6 @@ ds2dd_detailed <- function(data,
}
}
data_classes <- do.call(c, lapply(data, \(.x)class(.x)[1]))
## field_type
@ -378,14 +287,9 @@ ds2dd_detailed <- function(data,
dd$field_type <- "text"
dd <-
dd |> dplyr::mutate(
field_type = dplyr::case_match(
data_classes,
"factor"~"radio",
"logical"~"truefalse",
.default = 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)) {
dd$field_type <- field.type
@ -395,6 +299,7 @@ ds2dd_detailed <- function(data,
}
## validation
if (is.null(field.validation)) {
dd <-
dd |> dplyr::mutate(
@ -418,19 +323,41 @@ ds2dd_detailed <- function(data,
}
}
## choices
factor_levels <- data |>
sapply(function(x) {
if (is.factor(x)) {
## Custom function to ensure factor order and keep original values
## Avoiding refactoring to keep as much information as possible
sort(named_levels(x)) |>
vec2choice()
} else {
NA
}
})
if (data.source == "dta") {
factor_levels <- data |>
lapply(function(x) {
if (haven::is.labelled(x)) {
att <- attributes(x)$labels
paste(paste(att, names(att), sep = ", "), collapse = " | ")
} else {
NA
}
}) |>
(\(x)do.call(c, x))()
} else {
factor_levels <- data |>
lapply(function(x) {
if (is.factor(x)) {
## Re-factors to avoid confusion with missing levels
## Assumes all relevant levels are represented in the data
re_fac <- factor(x)
paste(
paste(seq_along(levels(re_fac)),
levels(re_fac),
sep = ", "
),
collapse = " | "
)
} else {
NA
}
}) |>
(\(x)do.call(c, x))()
}
dd <-
dd |> dplyr::mutate(
@ -441,74 +368,18 @@ ds2dd_detailed <- function(data,
)
)
out <- list(
list(
data = data |>
time_only_correction(
sel.pos = time.var.sel.pos,
sel.neg = time.var.sel.neg
) |>
hms2character() |>
stats::setNames(dd$field_name) |>
lapply(\(.x){
if (identical("factor", class(.x))) {
as.numeric(.x)
} else {
.x
}
}) |> dplyr::bind_cols(),
stats::setNames(dd$field_name),
meta = dd
)
class(out) <- c("REDCapCAST", class(out))
out
}
#' Check if vector is all NA
#'
#' @param data vector of data.frame
#'
#' @return logical
#' @export
#'
#' @examples
#' rep(NA, 4) |> all_na()
all_na <- function(data) {
all(is.na(data))
}
#' Guess time variables based on naming pattern
#'
#' @description
#' This is for repairing data with time variables with appended "1970-01-01"
#'
#'
#' @param data data.frame or tibble
#' @param validate.time Flag to validate guessed time columns
#' @param time.var.sel.pos Positive selection regex string passed to
#' `gues_time_only_filter()` as sel.pos.
#' @param time.var.sel.neg Negative selection regex string passed to
#' `gues_time_only_filter()` as sel.neg.
#'
#' @return data.frame or tibble
#' @export
#'
#' @examples
#' redcapcast_data |> guess_time_only(validate.time = TRUE)
guess_time_only <- function(data,
validate.time = FALSE,
time.var.sel.pos = "[Tt]i[d(me)]",
time.var.sel.neg = "[Dd]at[eo]") {
if (validate.time) {
return(data |> guess_time_only_filter(validate = TRUE))
}
### Only keeps the first class, as time fields (POSIXct/POSIXt) has two
### classes
data |> time_only_correction(
sel.pos = time.var.sel.pos,
sel.neg = time.var.sel.neg
)
}
### Completion
#' Completion marking based on completed upload
#'
@ -529,186 +400,3 @@ mark_complete <- function(upload, ls) {
) |>
stats::setNames(c(names(data)[1], paste0(forms, "_complete")))
}
#' Helper to auto-parse un-formatted data with haven and readr
#'
#' @param data data.frame or tibble
#' @param guess_type logical to guess type with readr
#' @param col_types specify col_types using readr semantics. Ignored if guess_type is TRUE
#' @param locale option to specify locale. Defaults to readr::default_locale().
#' @param ignore.vars specify column names of columns to ignore when parsing
#' @param ... ignored
#'
#' @return data.frame or tibble
#' @export
#'
#' @examples
#' mtcars |>
#' parse_data() |>
#' str()
parse_data <- function(data,
guess_type = TRUE,
col_types = NULL,
locale = readr::default_locale(),
ignore.vars = "cpr",
...) {
if (any(ignore.vars %in% names(data))) {
ignored <- data[ignore.vars]
} else {
ignored <- NULL
}
## Parses haven data by applying labels as factors in case of any
if (do.call(c, lapply(data, (\(x)inherits(x, "haven_labelled")))) |> any()) {
data <- data |>
as_factor()
}
## Applying readr cols
if (is.null(col_types) && guess_type) {
if (do.call(c, lapply(data, is.character)) |> any()) {
data <- data |> readr::type_convert(
locale = locale,
col_types = readr::cols(.default = readr::col_guess())
)
}
} else {
data <- data |> readr::type_convert(
locale = locale,
col_types = readr::cols(col_types)
)
}
if (!is.null(ignored)) {
data[ignore.vars] <- ignored
}
data
}
#' Convert vector to factor based on threshold of number of unique levels
#'
#' @description
#' This is a wrapper of forcats::as_factor, which sorts numeric vectors before
#' factoring, but levels character vectors in order of appearance.
#'
#'
#' @param data vector or data.frame column
#' @param unique.n threshold to convert class to factor
#'
#' @return vector
#' @export
#' @importFrom forcats as_factor
#'
#' @examples
#' sample(seq_len(4), 20, TRUE) |>
#' var2fct(6) |>
#' summary()
#' sample(letters, 20) |>
#' var2fct(6) |>
#' summary()
#' sample(letters[1:4], 20, TRUE) |> var2fct(6)
var2fct <- function(data, unique.n) {
if (length(unique(data)) <= unique.n) {
as_factor(data)
} else {
data
}
}
#' Applying var2fct across data set
#'
#' @description
#' Individual thresholds for character and numeric columns
#'
#' @param data dataset. data.frame or tibble
#' @param numeric.threshold threshold for var2fct for numeric columns. Default
#' is 6.
#' @param character.throshold threshold for var2fct for character columns.
#' Default is 6.
#'
#' @return data.frame or tibble
#' @export
#'
#' @examples
#' mtcars |> str()
#' \dontrun{
#' mtcars |>
#' numchar2fct(numeric.threshold = 6) |>
#' str()
#' }
numchar2fct <- function(data, numeric.threshold = 6, character.throshold = 6) {
data |>
dplyr::mutate(
dplyr::across(
dplyr::where(is.numeric),
\(.x){
var2fct(data = .x, unique.n = numeric.threshold)
}
),
dplyr::across(
dplyr::where(is.character),
\(.x){
var2fct(data = .x, unique.n = character.throshold)
}
)
)
}
#' Named vector to REDCap choices (`wrapping compact_vec()`)
#'
#' @param data named vector
#'
#' @return character string
#' @export
#'
#' @examples
#' sample(seq_len(4), 20, TRUE) |>
#' as_factor() |>
#' named_levels() |>
#' sort() |>
#' vec2choice()
vec2choice <- function(data) {
compact_vec(data, nm.sep = ", ", val.sep = " | ")
}
#' Compacting a vector of any length with or without names
#'
#' @param data vector, optionally named
#' @param nm.sep string separating name from value if any
#' @param val.sep string separating values
#'
#' @return character string
#' @export
#'
#' @examples
#' sample(seq_len(4), 20, TRUE) |>
#' as_factor() |>
#' named_levels() |>
#' sort() |>
#' compact_vec()
#' 1:6 |> compact_vec()
#' "test" |> compact_vec()
#' sample(letters[1:9], 20, TRUE) |> compact_vec()
compact_vec <- function(data, nm.sep = ": ", val.sep = "; ") {
if (all(is.na(data))) {
return(data)
}
if (length(names(data)) > 0) {
paste(
paste(data,
names(data),
sep = nm.sep
),
collapse = val.sep
)
} else {
paste(
data,
collapse = val.sep
)
}
}

74
R/easy_redcap.R
View file

@ -1,22 +1,15 @@
#' Retrieve project API key if stored, if not, set and retrieve
#'
#' @description
#' Attempting to make secure API key storage so simple, that no other way makes
#' sense. Wrapping \link[keyring]{key_get} and \link[keyring]{key_set} using the
#' \link[keyring]{key_list} to check if key is in storage already.
#'
#'
#' @param key.name character vector of key name
#' @param ... passed to \link[keyring]{key_set}
#'
#' @return character vector
#' @importFrom keyring key_list key_get key_set
#' @export
get_api_key <- function(key.name, ...) {
get_api_key <- function(key.name) {
if (key.name %in% keyring::key_list()$service) {
keyring::key_get(service = key.name)
} else {
keyring::key_set(service = key.name, ...)
keyring::key_set(service = key.name, prompt = "Provide REDCap API key:")
keyring::key_get(service = key.name)
}
}
@ -25,72 +18,25 @@ get_api_key <- function(key.name, ...) {
#' Secure API key storage and data acquisition in one
#'
#' @param project.name The name of the current project (for key storage with
#' \link[keyring]{key_set}, using the default keyring)
#' @param widen.data argument to widen the exported data. [DEPRECATED], use
#' `data_format`instead
#' `keyring::key_set()`, using the default keyring)
#' @param widen.data argument to widen the exported data
#' @param uri REDCap database API uri
#' @param raw_or_label argument passed on to
#' \link[REDCapCAST]{read_redcap_tables}. Default is "both" to get labelled
#' data.
#' @param data_format Choose the data
#' @param ... arguments passed on to \link[REDCapCAST]{read_redcap_tables}.
#' @param ... arguments passed on to `REDCapCAST::read_redcap_tables()`
#'
#' @return data.frame or list depending on widen.data
#' @export
#'
#' @examples
#' \dontrun{
#' easy_redcap("My_new_project", fields = c("record_id", "age", "hypertension"))
#' }
easy_redcap <- function(project.name,
uri,
raw_or_label = "both",
data_format = c("wide", "list", "redcap", "long"),
widen.data = NULL,
...) {
data_format <- match.arg(data_format)
easy_redcap <- function(project.name, widen.data = TRUE, uri, ...) {
key <- get_api_key(key.name = paste0(project.name, "_REDCAP_API"))
# Interpretation of "widen.data" is kept and will override "data_format"
# for legacy sake
if (isTRUE(widen.data)) {
data_format <- "wide"
}
if (data_format %in% c("wide", "list")) {
split_action <- "all"
} else {
split_action <- "none"
}
key <- get_api_key(
key.name = paste0(project.name, "_REDCAP_API"),
prompt = "Provide REDCap API key:"
)
redcap_data <- read_redcap_tables(
out <- read_redcap_tables(
uri = uri,
token = key,
raw_or_label = raw_or_label,
split_forms = split_action,
...
)
# For now, long data format is just legacy REDCap
# All options are written out for future improvements
if (data_format == "wide") {
out <- redcap_data |>
redcap_wider() |>
suffix2label()
} else if (data_format == "list") {
# The read_redcap_tables() output is a list of tables (forms)
out <- redcap_data
} else if (data_format == "long") {
out <- redcap_data
} else if (data_format == "redcap") {
out <- redcap_data
if (widen.data) {
out <- out |> redcap_wider()
}
out
}

126
R/export_redcap_instrument.R
View file

@ -1,126 +0,0 @@
#' Creates zip-file with necessary content to manually add instrument to database
#'
#' @description
#' Metadata can be added by editing the data dictionary of a project in the
#' initial design phase. If you want to later add new instruments, this
#' function can be used to create (an) instrument(s) to add to a project in
#' production.
#'
#' @param data metadata for the relevant instrument.
#' Could be from `ds2dd_detailed()`
#' @param file destination file name.
#' @param force force instrument creation and ignore different form names by
#' just using the first.
#' @param record.id record id variable name. Default is 'record_id'.
#'
#' @return exports zip-file
#' @export
#'
#' @examples
#' # iris |>
#' # ds2dd_detailed(
#' # add.auto.id = TRUE,
#' # form.name = sample(c("b", "c"), size = 6, replace = TRUE, prob = rep(.5, 2))
#' # ) |>
#' # purrr::pluck("meta") |>
#' # (\(.x){
#' # split(.x, .x$form_name)
#' # })() |>
#' # purrr::imap(function(.x, .i){
#' # export_redcap_instrument(.x,file=here::here(paste0(.i,Sys.Date(),".zip")))
#' # })
#'
#' # iris |>
#' # ds2dd_detailed(
#' # add.auto.id = TRUE
#' # ) |>
#' # purrr::pluck("meta") |>
#' # export_redcap_instrument(file=here::here(paste0("instrument",Sys.Date(),".zip")))
export_redcap_instrument <- function(data,
file,
force = FALSE,
record.id = "record_id") {
# Ensure form name is the same
if (force) {
data$form_name <- data$form_name[1]
} else if (length(unique(data$form_name)) != 1) {
stop("Please provide metadata for a single form only. See examples for
ideas on exporting multiple instruments.")
}
if (!is.na(record.id) && record.id %in% data[["field_name"]]) {
data <- data[-match(record.id, data[["field_name"]]), ]
}
temp_dir <- tempdir()
utils::write.csv(data, paste0(temp_dir, "/instrument.csv"), row.names = FALSE, na = "")
writeLines("REDCapCAST", paste0(temp_dir, "/origin.txt"))
zip::zip(
zipfile = file,
files = c("origin.txt", "instrument.csv"),
root = temp_dir
)
}
#' DEPRICATED Create zips file with necessary content based on data set
#'
#' @description
#' Metadata can be added by editing the data dictionary of a project in the
#' initial design phase. If you want to later add new instruments, this
#' function can be used to create (an) instrument(s) to add to a project in
#' production.
#'
#' @param data metadata for the relevant instrument.
#' Could be from `ds2dd_detailed()`
#' @param dir destination dir for the instrument zip. Default is the current WD.
#' @param record.id flag to omit the first row of the data dictionary assuming
#' this is the record_id field which should not be included in the instrument.
#' Default is TRUE.
#'
#' @return list
#' @export
#'
#' @examples
#' \dontrun{
#' data <- iris |>
#' ds2dd_detailed(
#' add.auto.id = TRUE,
#' form.name = sample(c("b", "c"),
#' size = 6,
#' replace = TRUE, prob = rep(.5, 2)
#' )
#' ) |>
#' purrr::pluck("meta")
#' # data |> create_instrument_meta()
#'
#' data <- iris |>
#' ds2dd_detailed(add.auto.id = FALSE) |>
#' purrr::pluck("data")
#' iris |>
#' setNames(glue::glue("{sample(x = c('a','b'),size = length(ncol(iris)),
#' replace=TRUE,prob = rep(x=.5,2))}__{names(iris)}")) |>
#' ds2dd_detailed(form.sep = "__")
#' data |>
#' purrr::pluck("meta") |>
#' create_instrument_meta(record.id = FALSE)
#' }
create_instrument_meta <- function(data,
dir = here::here(""),
record.id = TRUE) {
# browser()
if (record.id) {
data <- data[-1, ]
}
temp_dir <- tempdir()
split(data, data$form_name) |> purrr::imap(function(.x, .i) {
utils::write.csv(.x, paste0(temp_dir, "/instrument.csv"),
row.names = FALSE, na = ""
)
writeLines("REDCapCAST", paste0(temp_dir, "/origin.txt"))
zip::zip(paste0(dir, "/", .i, Sys.Date(), ".zip"),
files = c("origin.txt", "instrument.csv"),
root = temp_dir
)
})
}

45
R/fct_drop.R
View file

@ -1,45 +0,0 @@
#' Drop unused levels preserving label data
#'
#' This extends [forcats::fct_drop()] to natively work across a data.frame and
#' replaces [base::droplevels()].
#'
#' @param x Factor to drop unused levels
#' @param ... Other arguments passed down to method.
#' @export
#'
#' @importFrom forcats fct_drop
#' @export
#' @name fct_drop
fct_drop <- function(x, ...) {
UseMethod("fct_drop")
}
#' @rdname fct_drop
#' @export
#'
#' @examples
#' mtcars |>
#' numchar2fct() |>
#' fct_drop()
fct_drop.data.frame <- function(x, ...) {
purrr::map(x, \(.x){
if (is.factor(.x)) {
forcats::fct_drop(.x)
} else {
.x
}
}) |>
dplyr::bind_cols()
}
#' @rdname fct_drop
#' @export
#'
#' @examples
#' mtcars |>
#' numchar2fct() |>
#' dplyr::mutate(vs = fct_drop(vs))
fct_drop.factor <- function(x, ...) {
forcats::fct_drop(f = x, ...)
}

186
R/read_redcap_tables.R
View file

@ -1,33 +1,19 @@
#' Download REDCap data
#'
#' @description
#' Implementation of passed on to \link[REDCapCAST]{REDCap_split} with a focused
#' data acquisition approach using passed on to \link[REDCapR]{redcap_read} and
#' only downloading specified fields, forms and/or events using the built-in
#' focused_metadata including some clean-up.
#' Implementation of REDCap_split with a focused data acquisition approach using
#' REDCapR::redcap_read and only downloading specified fields, forms and/or
#' events using the built-in focused_metadata including some clean-up.
#' Works with classical and longitudinal projects with or without repeating
#' instruments.
#' Will preserve metadata in the data.frames as labels.
#'
#' @param uri REDCap database API uri
#' @param token API token
#' @param records records to download
#' @param fields fields to download
#' @param events events to download
#' @param forms forms to download
#' @param raw_or_label raw or label tags. Can be "raw", "label" or "both".
#'
#' * "raw": Standard \link[REDCapR]{redcap_read} method to get raw values.
#' * "label": Standard \link[REDCapR]{redcap_read} method to get label values.
#' * "both": Get raw values with REDCap labels applied as labels. Use
#' \link[REDCapCAST]{as_factor} to format factors with original labels and use
#' the `gtsummary` package functions like \link[gtsummary]{tbl_summary} to
#' easily get beautiful tables with original labels from REDCap. Use
#' \link[REDCapCAST]{fct_drop} to drop empty levels.
#'
#' @param raw_or_label raw or label tags
#' @param split_forms Whether to split "repeating" or "all" forms, default is
#' all. Give "none" to export native semi-long REDCap format
#' @param ... passed on to \link[REDCapR]{redcap_read}
#' all.
#'
#' @return list of instruments
#' @importFrom REDCapR redcap_metadata_read redcap_read redcap_event_instruments
@ -42,24 +28,18 @@ read_redcap_tables <- function(uri,
fields = NULL,
events = NULL,
forms = NULL,
raw_or_label = c("raw", "label", "both"),
split_forms = c("all", "repeating", "none"),
...) {
raw_or_label <- match.arg(raw_or_label, c("raw", "label", "both"))
split_forms <- match.arg(split_forms)
raw_or_label = "label",
split_forms = "all") {
# Getting metadata
m <-
REDCapR::redcap_metadata_read(redcap_uri = uri, token = token)[["data"]]
if (!is.null(fields)) {
fields_test <- fields %in% c(m$field_name, paste0(unique(m$form_name), "_complete"))
fields_test <- fields %in% c(m$field_name,paste0(unique(m$form_name),"_complete"))
if (any(!fields_test)) {
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")
}
}
@ -69,10 +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")
}
}
@ -86,20 +64,12 @@ 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")
}
}
if (raw_or_label == "both") {
rorl <- "raw"
} else {
rorl <- raw_or_label
}
# Getting dataset
d <- REDCapR::redcap_read(
redcap_uri = uri,
@ -108,17 +78,9 @@ read_redcap_tables <- function(uri,
events = events,
forms = forms,
records = records,
raw_or_label = rorl,
...
raw_or_label = raw_or_label
)[["data"]]
if (raw_or_label == "both") {
d <- apply_field_label(data = d, meta = m)
d <- apply_factor_labels(data = d, meta = m)
}
# Process repeat instrument naming
# Removes any extra characters other than a-z, 0-9 and "_", to mimic raw
# instrument names.
@ -129,115 +91,13 @@ read_redcap_tables <- function(uri,
# Processing metadata to reflect focused dataset
m <- focused_metadata(m, names(d))
# Splitting
if (split_forms != "none") {
REDCap_split(d,
m,
forms = split_forms,
primary_table_name = ""
) |> sanitize_split()
} else {
d
}
}
#' Very simple function to remove rich text formatting from field label
#' and save the first paragraph ('<p>...</p>').
#'
#' @param data field label
#'
#' @return character vector
#' @export
#'
#' @examples
#' clean_field_label("<div class=\"rich-text-field-label\"><p>Fazekas score</p></div>")
clean_field_label <- function(data) {
out <- data |>
lapply(\(.x){
unlist(strsplit(.x, "</"))[1]
}) |>
lapply(\(.x){
splt <- unlist(strsplit(.x, ">"))
splt[length(splt)]
})
Reduce(c, out)
}
#' Converts REDCap choices to factor levels and stores in labels attribute
#'
#' @description
#' Applying \link[REDCapCAST]{as_factor} to the data.frame or variable, will
#' coerce to a factor.
#'
#' @param data vector
#' @param meta vector of REDCap choices
#'
#' @return vector of class "labelled" with a "labels" attribute
#' @export
#'
#' @examples
#' format_redcap_factor(sample(1:3, 20, TRUE), "1, First. | 2, second | 3, THIRD")
format_redcap_factor <- function(data, meta) {
lvls <- strsplit(meta, " | ", fixed = TRUE) |>
unlist() |>
lapply(\(.x){
splt <- unlist(strsplit(.x, ", "))
stats::setNames(splt[1], nm = paste(splt[-1], collapse = ", "))
}) |>
(\(.x){
Reduce(c, .x)
})()
set_attr(data, label = lvls, attr = "labels") |>
set_attr(data, label = "labelled", attr = "class")
}
#' Apply REDCap filed labels to data frame
#'
#' @param data REDCap exported data set
#' @param meta REDCap data dictionary
#'
#' @return data.frame
#' @export
#'
apply_field_label <- function(data, meta) {
purrr::imap(data, \(.x, .i){
if (.i %in% meta$field_name) {
# Does not handle checkboxes
out <- set_attr(.x,
label = clean_field_label(meta$field_label[meta$field_name == .i]),
attr = "label"
)
out
} else {
.x
}
}) |> dplyr::bind_cols()
}
#' Preserve all factor levels from REDCap data dictionary in data export
#'
#' @param data REDCap exported data set
#' @param meta REDCap data dictionary
#'
#' @return data.frame
#' @export
#'
apply_factor_labels <- function(data, meta = NULL) {
if (is.list(data) && !is.data.frame(data)) {
meta <- data$meta
data <- data$data
} else if (is.null(meta)) {
stop("Please provide a data frame for meta")
}
purrr::imap(data, \(.x, .i){
if (any(c("radio", "dropdown") %in% meta$field_type[meta$field_name == .i]) || is.factor(.x)) {
format_redcap_factor(.x, meta$select_choices_or_calculations[meta$field_name == .i])
} else {
.x
}
}) |> dplyr::bind_cols()
out <- REDCap_split(d,
m,
forms = split_forms,
primary_table_name = ""
)
sanitize_split(out)
}

165
R/redcap_wider.R
View file

@ -4,20 +4,14 @@ utils::globalVariables(c(
"inst.glue"
))
#' Transforms list of REDCap data.frames to a single wide data.frame
#'
#' @description Converts a list of REDCap data.frames from long to wide format.
#' In essence it is a wrapper for the \link[tidyr]{pivot_wider} function applied
#' on a REDCap output (from \link[REDCapCAST]{read_redcap_tables}) or manually
#' split by \link[REDCapCAST]{REDCap_split}.
#'
#' @param data A list of data frames
#' @param event.glue A \link[glue]{glue} string for repeated events naming
#' @param inst.glue A \link[glue]{glue} string for repeated instruments naming
#'
#' @return data.frame in wide format
#' @title Redcap Wider
#' @description Converts a list of REDCap data frames from long to wide format.
#' Handles longitudinal projects, but not yet repeated instruments.
#' @param data A list of data frames.
#' @param event.glue A dplyr::glue string for repeated events naming
#' @param inst.glue A dplyr::glue string for repeated instruments naming
#' @return The list of data frames in wide format.
#' @export
#'
#' @importFrom tidyr pivot_wider
#' @importFrom tidyselect all_of
#' @importFrom purrr reduce
@ -79,35 +73,10 @@ utils::globalVariables(c(
#' )
#' )
#' redcap_wider(list4)
#'
#' list5 <- list(
#' data.frame(
#' record_id = c(1, 2, 1, 2),
#' redcap_event_name = c("baseline", "baseline", "followup", "followup")
#' ),
#' 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(list5)
redcap_wider <-
function(data,
event.glue = "{.value}____{redcap_event_name}",
inst.glue = "{.value}____{redcap_repeat_instance}") {
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) {
@ -119,28 +88,7 @@ redcap_wider <-
out <- data
}
} else {
## Cleaning instrument list to only include instruments holding other data
## than ID and generic columns
## This is to mitigate an issue when not exporting fields from the first
## instrument.
## Not taking this step would throw an error when pivoting.
instrument_names <- lapply(data, names)
id.name <- do.call(c, instrument_names)[[1]]
generic_names <- c(
id.name,
"redcap_event_name",
"redcap_repeat_instrument",
"redcap_repeat_instance"
)
semi_empty <- lapply(instrument_names,\(.x){
all(.x %in% generic_names)
}) |> unlist()
data <- data[!semi_empty]
id.name <- do.call(c, lapply(data, names))[[1]]
l <- lapply(data, function(i) {
rep_inst <- "redcap_repeat_instrument" %in% names(i)
@ -149,7 +97,12 @@ redcap_wider <-
k <- lapply(split(i, f = i[[id.name]]), function(j) {
cname <- colnames(j)
vals <-
cname[!cname %in% generic_names]
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",
@ -158,15 +111,7 @@ redcap_wider <-
)
s[!colnames(s) %in% c("redcap_repeat_instrument")]
})
# Labels are removed and restored after bind_rows as class "labelled"
# is not supported
i <- remove_labelled(k) |>
dplyr::bind_rows()
all_labels <- save_labels(data)
i <- restore_labels(i, all_labels)
i <- Reduce(dplyr::bind_rows, k)
}
event <- "redcap_event_name" %in% names(i)
@ -196,82 +141,8 @@ redcap_wider <-
}
})
# out <- Reduce(f = dplyr::full_join, x = l)
out <- purrr::reduce(.x = l, .f = dplyr::full_join)
out <- data.frame(Reduce(f = dplyr::full_join, x = l))
}
out
}
# Applies list of attributes to data.frame
restore_labels <- function(data, labels) {
stopifnot(is.list(labels))
stopifnot(is.data.frame(data))
for (ndx in names(labels)) {
data <- purrr::imap(data, \(.y, .j){
if (startsWith(.j, ndx)) {
set_attr(.y, labels[[ndx]])
} else {
.y
}
}) |> dplyr::bind_cols()
}
return(data)
}
# Extract unique variable attributes from list of data.frames
save_labels <- function(data) {
stopifnot(is.list(data))
out <- list()
for (j in seq_along(data)) {
out <- c(out, lapply(data[[j]], get_attr))
}
out[!duplicated(names(out))]
}
# Removes class attributes of class "labelled" or "haven_labelled"
remove_labelled <- function(data) {
stopifnot(is.list(data))
lapply(data, \(.x) {
lapply(.x, \(.y) {
if (REDCapCAST::is.labelled(.y)) {
set_attr(.y, label = NULL, attr = "class")
} else {
.y
}
}) |>
dplyr::bind_cols()
})
}
#' Transfer variable name suffix to label in widened data
#'
#' @param data data.frame
#' @param suffix.sep string to split suffix(es). Passed to \link[base]{strsplit}
#' @param attr label attribute. Default is "label"
#' @param glue.str glue string for new label. Available variables are "label"
#' and "suffixes"
#'
#' @return data.frame
#' @export
#'
suffix2label <- function(data,
suffix.sep = "____",
attr = "label",
glue.str="{label} ({paste(suffixes,collapse=', ')})") {
data |>
purrr::imap(\(.d, .i){
suffixes <- unlist(strsplit(.i, suffix.sep))[-1]
if (length(suffixes) > 0) {
label <- get_attr(.d, attr = attr)
set_attr(.d,
glue::glue(glue.str),
attr = attr
)
} else {
.d
}
}) |>
dplyr::bind_cols()
}

3
R/redcapcast_data.R
View file

@ -17,9 +17,6 @@
#' \item{age_integer}{Age integer, numeric}
#' \item{sex}{Legal sex, character}
#' \item{cohabitation}{Cohabitation status, character}
#' \item{con_calc}{con_calc}
#' \item{con_mrs}{con_mrs}
#' \item{consensus_complete}{consensus_complete}
#' \item{hypertension}{Hypertension, character}
#' \item{diabetes}{diabetes, character}
#' \item{region}{region, character}

2
R/redcapcast_meta.R
View file

@ -1,6 +1,6 @@
#' REDCap metadata from data base
#'
#' This metadata dataset from a REDCap database is for demonstration purposes.
#' This metadata dataset from a REDCap database is for demonstrational purposes.
#'
#' @format A data frame with 22 variables:
#' \describe{

282
R/shiny_cast.R
View file

@ -1,27 +1,41 @@
utils::globalVariables(c("server"))
#' Shiny server factory
#'
#' @return shiny server
#' @export
server_factory <- function() {
source(here::here("app/server.R"))
server
}
#' UI factory for shiny app
#'
#' @return shiny ui
#' @export
ui_factory <- function() {
# require(ggplot2)
source(here::here("app/ui.R"))
}
#' Launch the included Shiny-app for database casting and upload
#'
#' @description
#' Wraps shiny::runApp()
#'
#' @param ... Arguments passed to shiny::runApp()
#'
#' @return shiny app
#' @export
#'
#' @examples
#' # shiny_cast()
#'
shiny_cast <- function(...) {
appDir <- system.file("shiny-examples", "casting", package = "REDCapCAST")
if (appDir == "") {
stop("Could not find example directory. Try re-installing `REDCapCAST`.", call. = FALSE)
}
shiny_cast <- function() {
# shiny::runApp(appDir = here::here("app/"), launch.browser = TRUE)
shiny::runApp(appDir = appDir, ...)
shiny::shinyApp(
ui_factory(),
server_factory()
)
}
#' DEPRECATED Helper to import files correctly
#' Helper to import files correctly
#'
#' @param filenames file names
#'
@ -30,13 +44,11 @@ shiny_cast <- function(...) {
#'
#' @examples
#' file_extension(list.files(here::here(""))[[2]])[[1]]
#' file_extension(c("file.cd..ks", "file"))
#' file_extension(c("file.cd..ks","file"))
file_extension <- function(filenames) {
sub(
pattern = "^(.*\\.|[^.]+)(?=[^.]*)", replacement = "",
filenames,
perl = TRUE
)
sub(pattern = "^(.*\\.|[^.]+)(?=[^.]*)", replacement = "",
filenames,
perl = TRUE)
}
#' Flexible file import based on extension
@ -47,32 +59,24 @@ file_extension <- function(filenames) {
#' @return tibble
#' @export
#'
#' @importFrom openxlsx2 read_xlsx
#' @importFrom haven read_dta
#' @importFrom readODS read_ods
#' @importFrom readr read_csv read_rds
#'
#'
#' @examples
#' read_input("https://raw.githubusercontent.com/agdamsbo/cognitive.index.lookup/main/data/sample.csv")
read_input <- function(file, consider.na = c("NA", '""', "")) {
ext <- tolower(tools::file_ext(file))
ext <- file_extension(file)
tryCatch(
{
if (ext == "csv") {
df <- read_csv(file = file, na = consider.na)
df <- readr::read_csv(file = file, na = consider.na)
} else if (ext %in% c("xls", "xlsx")) {
df <- read_xlsx(file = file, na.strings = consider.na)
df <- openxlsx2::read_xlsx(file = file, na.strings = consider.na)
} else if (ext == "dta") {
df <- read_dta(file = file)
df <- haven::read_dta(file = file)
} else if (ext == "ods") {
df <- read_ods(path = file)
} else if (ext == "rds") {
df <- read_rds(file = file)
}else {
df <- readODS::read_ods(file = file)
} else {
stop("Input file format has to be on of:
'.csv', '.xls', '.xlsx', '.dta', '.ods' or '.rds'")
'.csv', '.xls', '.xlsx', '.dta' or '.ods'")
}
},
error = function(e) {
@ -84,215 +88,3 @@ read_input <- function(file, consider.na = c("NA", '""', "")) {
df
}
#' Overview of REDCapCAST data for shiny
#'
#' @param data list with class 'REDCapCAST'
#'
#' @return gt object
#' @export
cast_data_overview <- function(data){
stopifnot("REDCapCAST" %in% class(data))
data |>
purrr::pluck("data") |>
utils::head(20) |>
# dplyr::tibble() |>
gt::gt() |>
gt::tab_style(
style = gt::cell_text(weight = "bold"),
locations = gt::cells_column_labels(dplyr::everything())
) |>
gt::tab_header(
title = "Imported data preview",
subtitle = "The first 20 subjects of the supplied dataset for reference."
)
}
#' Overview of REDCapCAST meta data for shiny
#'
#' @param data list with class 'REDCapCAST'
#'
#' @return gt object
#' @export
cast_meta_overview <- function(data){
stopifnot("REDCapCAST" %in% class(data))
data |>
purrr::pluck("meta") |>
# dplyr::tibble() |>
dplyr::mutate(
dplyr::across(
dplyr::everything(),
\(.x) {
.x[is.na(.x)] <- ""
return(.x)
}
)
) |>
dplyr::select(1:8) |>
gt::gt() |>
gt::tab_style(
style = gt::cell_text(weight = "bold"),
locations = gt::cells_column_labels(dplyr::everything())
) |>
gt::tab_header(
title = "Generated metadata",
subtitle = "Only the first 8 columns are modified using REDCapCAST. Download the metadata to see everything."
) |>
gt::tab_style(
style = gt::cell_borders(
sides = c("left", "right"),
color = "grey80",
weight = gt::px(1)
),
locations = gt::cells_body(
columns = dplyr::everything()
)
)
}
#' Nav_bar defining function for shiny ui
#'
#' @return shiny object
#' @export
#'
nav_bar_page <- function(){
bslib::page_navbar(
title = "Easy REDCap database creation",
sidebar = bslib::sidebar(
width = 300,
shiny::h5("Metadata casting"),
shiny::fileInput(
inputId = "ds",
label = "Upload spreadsheet",
multiple = FALSE,
accept = c(
".csv",
".xls",
".xlsx",
".dta",
".rds",
".ods"
)
),
# shiny::actionButton(
# inputId = "load_data",
# label = "Load data",
# icon = shiny::icon("circle-down")
# ),
shiny::helpText("Have a look at the preview panels to validate the data dictionary and imported data."),
# For some odd reason this only unfolds when the preview panel is shown..
# This has been solved by adding an arbitrary button to load data - which was abandoned again
shiny::conditionalPanel(
condition = "output.uploaded=='yes'",
shiny::radioButtons(
inputId = "add_id",
label = "Add ID, or use first column?",
selected = "no",
inline = TRUE,
choices = list(
"First column" = "no",
"Add ID" = "yes",
"No ID" = "none"
)
),
shiny::radioButtons(
inputId = "specify_factors",
label = "Specify categorical variables?",
selected = "no",
inline = TRUE,
choices = list(
"No" = "no",
"Yes" = "yes"
)
),
shiny::conditionalPanel(
condition = "input.specify_factors=='yes'",
shiny::uiOutput("factor_vars")
),
# condition = "input.load_data",
# shiny::helpText("Below you can download the dataset formatted for upload and the
# corresponding data dictionary for a new data base, if you want to upload manually."),
# Button
shiny::downloadButton(outputId = "downloadData", label = "Download renamed data"),
# Button
shiny::downloadButton(outputId = "downloadMeta", label = "Download data dictionary"),
# Button
shiny::downloadButton(outputId = "downloadInstrument", label = "Download as instrument"),
# Horizontal line ----
shiny::tags$hr(),
shiny::radioButtons(
inputId = "upload_redcap",
label = "Upload directly to REDCap server?",
selected = "no",
inline = TRUE,
choices = list(
"No" = "no",
"Yes" = "yes"
)
),
shiny::conditionalPanel(
condition = "input.upload_redcap=='yes'",
shiny::h4("2) Data base upload"),
shiny::helpText("This tool is usable for now. Detailed instructions are coming."),
shiny::textInput(
inputId = "uri",
label = "URI",
value = "https://redcap.your.institution/api/"
),
shiny::textInput(
inputId = "api",
label = "API key",
value = ""
),
shiny::helpText("An API key is an access key to the REDCap database. Please", shiny::a("see here for directions", href = "https://www.iths.org/news/redcap-tip/redcap-api-101/"), " to obtain an API key for your project."),
shiny::actionButton(
inputId = "upload.meta",
label = "Upload datadictionary", icon = shiny::icon("book-bookmark")
),
shiny::helpText("Please note, that before uploading any real data, put your project
into production mode."),
shiny::actionButton(
inputId = "upload.data",
label = "Upload data", icon = shiny::icon("upload")
)
)
),
shiny::br(),
shiny::br(),
shiny::br(),
shiny::p(
"License: ", shiny::a("GPL-3+", href = "https://agdamsbo.github.io/REDCapCAST/LICENSE.html")
),
shiny::p(
shiny::a("Package documentation", href = "https://agdamsbo.github.io/REDCapCAST")
)
),
bslib::nav_panel(
title = "Intro",
shiny::markdown(readLines("www/SHINYCAST.md")),
shiny::br()
),
# bslib::nav_spacer(),
bslib::nav_panel(
title = "Data preview",
gt::gt_output(outputId = "data.tbl")
# shiny::htmlOutput(outputId = "data.tbl", container = shiny::span)
),
bslib::nav_panel(
title = "Dictionary overview",
gt::gt_output(outputId = "meta.tbl")
# shiny::htmlOutput(outputId = "meta.tbl", container = shiny::span)
),
bslib::nav_panel(
title = "Upload",
shiny::h3("Meta upload overview"),
shiny::textOutput(outputId = "upload.meta.print"),
shiny::h3("Data upload overview"),
shiny::textOutput(outputId = "upload.data.print")
)
)
}

BIN
R/sysdata.rda
View file

Binary file not shown.

53
R/utils.r
View file

@ -97,10 +97,7 @@ focused_metadata <- function(metadata, vars_in_data) {
#' @return vector or data frame, same format as input
#' @export
#'
#' @examples
#' "Research!, ne:ws? and c;l-.ls" |> clean_redcap_name()
clean_redcap_name <- function(x) {
gsub("[,.;:?!@]","",
gsub(
" ", "_",
gsub(
@ -111,19 +108,14 @@ clean_redcap_name <- function(x) {
)
)
)
)
}
#' Sanitize list of data frames
#'
#' Removing empty rows
#'
#' @param l A list of data frames.
#' @param generic.names A vector of generic names to be excluded.
#' @param drop.complete logical to remove generic REDCap variables indicating
#' instrument completion. Default is TRUE.
#' @param drop.empty logical to remove variables with only NAs Default is TRUE.
#'
#' @return A list of data frames with generic names excluded.
#'
@ -135,34 +127,21 @@ sanitize_split <- function(l,
"redcap_event_name",
"redcap_repeat_instrument",
"redcap_repeat_instance"
),
drop.complete=TRUE,
drop.empty=TRUE) {
)) {
generic.names <- c(
get_id_name(l),
generic.names
generic.names,
paste0(names(l), "_complete")
)
if (drop.complete){
generic.names <- c(
generic.names,
paste0(names(l), "_complete")
)
}
out <- lapply(l, function(i) {
lapply(l, function(i) {
if (ncol(i) > 2) {
s <- i[!colnames(i) %in% generic.names]
if (drop.empty){
s <- data.frame(i[, !colnames(i) %in% generic.names])
i[!apply(is.na(s), MARGIN = 1, FUN = all), ]
}
} else {
i
}
})
# On removing empty variables, a list may end up empty
out[sapply(out,nrow)>0]
}
@ -517,27 +496,5 @@ is_repeated_longitudinal <- function(data, generics = c(
}
dummy_fun <- function(...){
list(
gtsummary::add_difference()
)
}
#' Cut string to desired length
#'
#' @param data data
#' @param l length
#'
#' @returns character string of length l
#' @export
#'
#' @examples
#' "length" |> cut_string_length(l=3)
cut_string_length <- function(data,l=100){
if (nchar(data)>=l){
substr(data,1,l)
} else {
data
}
}

53
README.md
View file

@ -1,53 +1,60 @@
<!-- badges: start -->
[![GitHub R package version](https://img.shields.io/github/r-package/v/agdamsbo/REDCapCAST)](https://github.com/agdamsbo/REDCapCAST) [![CRAN/METACRAN](https://img.shields.io/cran/v/REDCapCAST)](https://CRAN.R-project.org/package=REDCapCAST) [![DOI](https://zenodo.org/badge/DOI/10.5281/zenodo.8013984.svg)](https://doi.org/10.5281/zenodo.8013984) [![R-hub](https://github.com/agdamsbo/REDCapCAST/actions/workflows/rhub.yaml/badge.svg)](https://github.com/agdamsbo/REDCapCAST/actions/workflows/rhub.yaml) [![R-CMD-check](https://github.com/agdamsbo/REDCapCAST/actions/workflows/R-CMD-check.yaml/badge.svg)](https://github.com/agdamsbo/REDCapCAST/actions/workflows/R-CMD-check.yaml) [![Page deployed](https://github.com/agdamsbo/REDCapCAST/actions/workflows/pages/pages-build-deployment/badge.svg)](https://github.com/agdamsbo/REDCapCAST/actions/workflows/pages/pages-build-deployment) [![CRAN downloads](https://cranlogs.r-pkg.org/badges/grand-total/REDCapCAST)](https://cran.r-project.org/package=REDCapCAST) [![Lifecycle: experimental](https://img.shields.io/badge/lifecycle-experimental-orange.svg)](https://lifecycle.r-lib.org/articles/stages.html) [![Codecov test coverage](https://codecov.io/gh/agdamsbo/REDCapCAST/graph/badge.svg)](https://app.codecov.io/gh/agdamsbo/REDCapCAST)
[![GitHub R package version](https://img.shields.io/github/r-package/v/agdamsbo/REDCapCAST)](https://github.com/agdamsbo/REDCapCAST)
[![CRAN/METACRAN](https://img.shields.io/cran/v/REDCapCAST)](https://CRAN.R-project.org/package=REDCapCAST)
[![DOI](https://zenodo.org/badge/DOI/10.5281/zenodo.8013984.svg)](https://doi.org/10.5281/zenodo.8013984)
[![R-hub](https://github.com/agdamsbo/REDCapCAST/actions/workflows/rhub.yaml/badge.svg)](https://github.com/agdamsbo/REDCapCAST/actions/workflows/rhub.yaml)
[![R-CMD-check](https://github.com/agdamsbo/REDCapCAST/actions/workflows/R-CMD-check.yaml/badge.svg)](https://github.com/agdamsbo/REDCapCAST/actions/workflows/R-CMD-check.yaml)
[![Page deployed](https://github.com/agdamsbo/REDCapCAST/actions/workflows/pages/pages-build-deployment/badge.svg)](https://github.com/agdamsbo/REDCapCAST/actions/workflows/pages/pages-build-deployment)
[![Codecov test coverage](https://codecov.io/gh/agdamsbo/REDCapCAST/branch/master/graph/badge.svg)](https://app.codecov.io/gh/agdamsbo/REDCapCAST?branch=master)
[![CRAN downloads](https://cranlogs.r-pkg.org/badges/grand-total/REDCapCAST)](https://cran.r-project.org/package=REDCapCAST)
[![Lifecycle:
experimental](https://img.shields.io/badge/lifecycle-experimental-orange.svg)](https://lifecycle.r-lib.org/articles/stages.html)
<!-- badges: end -->
# REDCapCAST package <img src="man/figures/logo.png" align="right"/>
# REDCapCAST package <img src="man/figures/logo.png" align="right" />
Casting metadata for REDCap database creation and handling of castellated data using repeated instruments and longitudinal projects in REDCap.
REDCap database casting and handling of castellated data when using repeated instruments and longitudinal projects.
This is implemented with
This package is a fork of [pegeler/REDCapRITS](https://github.com/pegeler/REDCapRITS). The REDCapRITS represents great and extensive work to handle castellated REDCap data in different programming languages. This fork is purely minded on R usage and includes a few implementations of the main `REDCap_split` function.
- An app-interface for easy database creation [accessible here](https://agdamsbo.shinyapps.io/redcapcast/) or available to run locally with `shiny_cast()` allowing you to easily create a REDCap database based on an existing spreadsheet.
I started working on this project as the castellated longitudinal data set was a little challenging. Later, I have come to learn of the [`redcapAPI`](https://github.com/vubiostat/redcapAPI) package, which would also cover this functionality. I find the `redcapAPI`package quite advanced and a little difficult to work with. This have led to the continued work on this package, as an easy-to-use approach for data migration, data base creation and data handling. This package is very much to be seen as an attempt at a R-to-REDCap-to-R foundry for handling both the transition from dataset/variable list to database and the other way, from REDCap database to a tidy dataset. The goal was also to allow for a "minimal data" approach by allowing to filter records, instruments and variables in the export to only download data needed. I think this approach is desirable for handling sensitive, clinical data. Please refer to [REDCap-Tools](https://redcap-tools.github.io/) for other great tools for working with REDCap in R.
- Export data from REDCap in different formats handling castellated data, and on default only export requested data, this is mainly through `read_redcap_tables()`.
For any more advanced uses, consider using the `redcapAPI` package.
REDCapCAST was initially build on, and still includes code from [pegeler/REDCapRITS](https://github.com/pegeler/REDCapRITS), and relies on functions from the [`REDCapR`](https://ouhscbbmc.github.io/REDCapR/)-project
## Use and immprovements
## History
Here is just a short description of the main functions:
This package was originally forked from [pegeler/REDCapRITS](https://github.com/pegeler/REDCapRITS). The `REDCapRITS` represents great and extensive work to handle castellated REDCap data in different programming languages. REDCapCAST has evolved into much more than just handling castellated data and so has been detatched from the original project while still relying on the main `REDCap_split` function. All access to the REDCap database is build on the outstanding work in [`REDCapR`](#0).
* `REDcap_split()`: Works largely as the original `REDCapRITS::REDCap_split()`. It takes a REDCap dataset and metadata (data dictionary) to split the data set into a list of dataframes of instruments.
This package really started out of frustration during my PhD in health science hearing colleagues complaining about that "castellated" data formatting of REDCap exports when doing longitudinal projects and being used to wide data. This led to some bad decisions in building databases avoiding repeated instruments. This package solves these challenges, but solutions are also implemented else where like the [redcapAPI](https://github.com/vubiostat/redcapAPI) or [REDCapTidieR](https://github.com/CHOP-CGTInformatics/REDCapTidieR) packages, which are bigger project.
* `read_redcap_tables()`: wraps the use of [`REDCapR::redcap_read()`](https://github.com/OuhscBbmc/REDCapR) with `REDCap_split()` to ease the export of REDCap data. Default output is a list of data frames with one data frame for each REDCap instrument.
To help new PhD students and other researchers, I have also worked on creating a few helper/wrapper-functions to ease data access. Documentation is on it's way.
* `redcap_wider()`: joins and pivots a list of data frames with repeated instruments to a wide format utilizing the [`tidyr::pivot_wider()`](https://tidyr.tidyverse.org/reference/pivot_wider.html) from the [tidyverse](https://www.tidyverse.org/).
For any more advanced uses, consider using the [`redcapAPI`](https://github.com/vubiostat/redcapAPI) or [`REDCapR`](https://ouhscbbmc.github.io/REDCapR/) packages.
* `easy_redcap()`: combines secure API key storage with the `keyring`-package, focused data retrieval and optional widening. This is the recommended approach for easy data access and analysis.
* `ds2dd_detailed()`: Converts a data set to a data dictionary for upload to a new REDCap database. Variables (fields) and instruments in a REDCap data base are defined by this data dictionary.
* `doc2dd()`: Converts a document table to data dictionary. This allows to specify instrument or whole data dictionary in text document, which for most is easier to work with and easily modifiable. Very much like a easy version of just working directly in the data dictionary file itself.
* `shiny_cast()`: [Shiny](https://www.rstudio.com/products/shiny/) application to ease the process of converting a spreadsheet/data set to a REDCap database. The app runs locally and data is transferred securely. You can just create and upload the data dictionary, but you can also transfer the given data in the same process. The app is [hosted on shinyapps.io](https://agdamsbo.shinyapps.io/redcapcast/) ~~while I work on a [shinylive](https://posit-dev.github.io/r-shinylive/) implementation~~.
## Future
The plan with this package is to be bundled with a Handbook on working with REDCap from R. This work is in progress but is limited by the time available. Please feel free to contact me or create and issue with ideas for future additions.
## Installation and use
## Installation
The package is available on CRAN. Install the latest version:
```
```
install.packages("REDCapCAST")
```
Install the latest version directly from GitHub:
```
require("remotes")
remotes::install_github("agdamsbo/REDCapCAST")
```
Launch the REDCapCAST app interface directly on your own machine:
```
REDCapCAST::shiny_cast()
pak::pak("agdamsbo/REDCapCAST")
```
## Code of Conduct

2
REDCapCAST.Rproj
View file

@ -1,5 +1,4 @@
Version: 1.0
ProjectId: d97cf790-0785-4be6-9651-e02a4867726b
RestoreWorkspace: No
SaveWorkspace: No
@ -19,5 +18,4 @@ StripTrailingWhitespace: Yes
BuildType: Package
PackageUseDevtools: Yes
PackageInstallArgs: --no-multiarch --with-keep.source
PackageCheckArgs: --as-cran
PackageRoxygenize: rd,collate,namespace,vignette

81
app/server.R Normal file
View file

@ -0,0 +1,81 @@
server <- function(input, output, session) {
require(REDCapCAST)
dat <- shiny::reactive({
shiny::req(input$ds)
read_input(input$ds$datapath)
})
dd <- shiny::reactive({
ds2dd_detailed(data = dat())
})
output$data.tbl <- shiny::renderTable({
dd() |>
purrr::pluck("data") |>
head(20) |>
dplyr::tibble()
})
output$meta.tbl <- shiny::renderTable({
dd() |>
purrr::pluck("meta") |>
dplyr::tibble()
})
# Downloadable csv of dataset ----
output$downloadData <- shiny::downloadHandler(
filename = "data_ready.csv",
content = function(file) {
write.csv(purrr::pluck(dd(), "data"), file, row.names = FALSE)
}
)
# Downloadable csv of data dictionary ----
output$downloadMeta <- shiny::downloadHandler(
filename = "dictionary_ready.csv",
content = function(file) {
write.csv(purrr::pluck(dd(), "meta"), file, row.names = FALSE)
}
)
output_staging <- shiny::reactiveValues()
output_staging$meta <- output_staging$data <- NA
shiny::observeEvent(input$upload.meta,{ upload_meta() })
shiny::observeEvent(input$upload.data,{ upload_data() })
upload_meta <- function(){
shiny::req(input$uri)
shiny::req(input$api)
output_staging$meta <- REDCapR::redcap_metadata_write(
ds = purrr::pluck(dd(), "meta"),
redcap_uri = input$uri,
token = input$api
)|> purrr::pluck("success")
}
upload_data <- function(){
shiny::req(input$uri)
shiny::req(input$api)
output_staging$data <- REDCapR::redcap_write(
ds = purrr::pluck(dd(), "data"),
redcap_uri = input$uri,
token = input$api
) |> purrr::pluck("success")
}
output$upload.meta.print <- renderText(output_staging$meta)
output$upload.data.print <- renderText(output_staging$data)
}

141
app/ui.R Normal file
View file

@ -0,0 +1,141 @@
ui <- shiny::shinyUI(
shiny::fluidPage(
theme = shinythemes::shinytheme("flatly"),
## -----------------------------------------------------------------------------
## Application title
## -----------------------------------------------------------------------------
# customHeaderPanel(title = "REDCapCAST: data base creation and data upload from data set file",
# windowTitle = "REDCap database creator"
# ),
shiny::titlePanel(
title = shiny::div(
shiny::a(shiny::img(src = "logo.png"), href = "https://agdamsbo.github.io/REDCapCAST"),
"Easy REDCap database creation"
),
windowTitle = "REDCap database creator"
),
shiny::h4(
"This tool includes to convenient functions:",
shiny::br(),
"1) creating a REDCap data dictionary based on a spreadsheet (.csv/.xls(x)/.dta/.ods) and",
shiny::br(),
"2) creating said database on a given REDCap server and uploading the dataset via API access."
),
## -----------------------------------------------------------------------------
## Side panel
## -----------------------------------------------------------------------------
shiny::sidebarPanel(
shiny::h4("1) REDCap datadictionary and compatible dataset"),
shiny::fileInput("ds", "Choose data file",
multiple = FALSE,
accept = c(
".csv",
".xls",
".xlsx",
".dta",
".ods"
)
),
shiny::h6("Below you can download the dataset formatted for upload and the
corresponding data dictionary for a new data base, if you want to upload manually."),
# Button
shiny::downloadButton("downloadData", "Download data"),
# Button
shiny::downloadButton("downloadMeta", "Download datadictionary"),
# Horizontal line ----
shiny::tags$hr(),
shiny::h4("2) REDCap upload"),
shiny::h6("This tool is usable for now. Detailed instructions are coming."),
shiny::textInput(
inputId = "uri",
label = "URI",
value = "https://redcap.your.institution/api/"
),
shiny::textInput(
inputId = "api",
label = "API key",
value = ""
),
shiny::h6("An API key is an access key to the REDCap database. Please", shiny::a("see here for directions", href = "https://www.iths.org/news/redcap-tip/redcap-api-101/"), " to obtain an API key for your project."),
shiny::actionButton(
inputId = "upload.meta",
label = "Upload datadictionary", icon = shiny::icon("book-bookmark")
),
shiny::h6("Please note, that before uploading any real data, put your project
into production mode."),
shiny::actionButton(
inputId = "upload.data",
label = "Upload data", icon = shiny::icon("upload")
),
# Horizontal line ----
shiny::tags$hr()
),
shiny::mainPanel(
shiny::tabsetPanel(
## -----------------------------------------------------------------------------
## Summary tab
## -----------------------------------------------------------------------------
shiny::tabPanel(
"Summary",
shiny::h3("Data overview (first 20)"),
shiny::htmlOutput("data.tbl", container = shiny::span),
shiny::h3("Dictionary overview"),
shiny::htmlOutput("meta.tbl", container = shiny::span)
),
## -----------------------------------------------------------------------------
## Upload tab
## -----------------------------------------------------------------------------
shiny::tabPanel(
"Upload",
shiny::h3("Meta upload overview"),
shiny::htmlOutput("upload.meta.print", container = shiny::span),
shiny::h3("Data upload overview"),
shiny::htmlOutput("upload.data.print", container = shiny::span)
)
)
),
# close sidebarLayout
shiny::br(),
shiny::br(),
shiny::br(),
shiny::br(),
shiny::hr(),
shiny::tags$footer(shiny::strong("Disclaimer: "),
"This tool is aimed at demonstrating use of REDCapCAST. The app can be run locally or on a hosted server (will save no data anywhere). No responsibility for data loss or any other problems will be taken. Please contact me for support.",
shiny::br(),
shiny::a("License: GPL-3+", href = "https://agdamsbo.github.io/REDCapCAST/LICENSE.html"),
"|",
shiny::a("agdamsbo/REDCapCAST", href = "https://agdamsbo.github.io/REDCapCAST"),
"|",
shiny::a("Source", href = "https://github.com/agdamsbo/REDCapCAST"),
"|",
shiny::a("Contact", href = "https://andreas.gdamsbo.dk"),
align = "center",
style = "
position:fixed;
bottom:40px;
width:100%;
height:20px;
color: black;
padding: 0px;
background-color: White;
z-index: 100;
"
)
)
)

0
inst/shiny-examples/casting/www/logo.png → app/www/logo.png
View file

Side by side Swipe Overlay

Before

Width:  |  Height:  |  Size: 8.1 KiB

After

Width:  |  Height:  |  Size: 8.1 KiB

9
cran-comments.md
View file

@ -1,10 +1,11 @@
── R CMD check results ───────────────────────────────────────────────────────────────────────────────── REDCapCAST 25.3.2 ────
Duration: 37.1s
── R CMD check results ───────────────────────────────────────── REDCapCAST 24.6.1 ────
Duration: 22.2s
0 errors ✔ | 0 warnings ✔ | 0 notes ✔
R CMD check succeeded
## Test environments
Rhubv2 runs and checks out.
New Rhubv2 implemented and tested with GitHub actions. All passed.
Link corrected.

8
data-raw/data-upload-examples.R
View file

@ -9,11 +9,3 @@ mtcars_redcap |>
write.csv(here::here("data/mtcars_redcap.csv"), row.names = FALSE)
usethis::use_data(mtcars_redcap, overwrite = TRUE)
gtsummary::trial|>
dplyr::mutate(
record_id = dplyr::row_number()
) |>
dplyr::select(record_id, dplyr::everything())|>
write.csv(here::here("drafting/trials_redcap.csv"), row.names = FALSE)

2
data-raw/redcapcast_data.R
View file

@ -11,5 +11,3 @@ redcapcast_data <- REDCapR::redcap_read(
# widen.data = FALSE)
usethis::use_data(redcapcast_data, overwrite = TRUE)
# write.csv(redcapcast_data,here::here("data/redcapcast_data.csv"),row.names = FALSE)

26
data/redcapcast_data.csv
View file

@ -1,26 +0,0 @@
"record_id","redcap_event_name","redcap_repeat_instrument","redcap_repeat_instance","cpr","inclusion","inclusion_time","dob","age","age_integer","sex","cohabitation","hypertension","diabetes","region","baseline_data_start_complete","mrs_assessed","mrs_date","mrs_score","mrs_complete","con_mrs","con_calc","consensus_complete","event_datetime","event_age","event_type","new_event_complete"
1,"inclusion",NA,NA,"1203401OB4",2023-03-13,12:38:49,1940-03-12,83.0023888238636,83,"female","Yes","No","Yes","East","Incomplete","Yes",2023-03-13,1,"Incomplete",NA,NA,NA,NA,NA,NA,NA
2,"inclusion",NA,NA,"0102342303",2023-03-01,10:38:57,1934-02-01,89.0778044723711,89,"male","Yes","No","No","South","Incomplete","Yes",2023-03-07,1,"Incomplete",NA,NA,NA,NA,NA,NA,NA
2,"follow1",NA,NA,NA,NA,NA,NA,NA,NA,NA,NA,NA,NA,NA,NA,"Yes",2023-03-09,3,"Incomplete",NA,NA,"Incomplete",NA,NA,NA,NA
2,"follow1","New Event (?)",1,NA,NA,NA,NA,NA,NA,NA,NA,NA,NA,NA,NA,NA,NA,NA,NA,NA,NA,NA,2024-01-18 12:49:42,NA,"TIA","Incomplete"
3,"inclusion",NA,NA,"2301569823",2022-03-08,12:01:07,1956-01-23,66.1231921257795,66,"male","No","Yes","Yes","North","Incomplete",NA,NA,NA,"Incomplete",NA,NA,NA,NA,NA,NA,NA
3,"follow1",NA,NA,NA,NA,NA,NA,NA,NA,NA,NA,NA,NA,NA,NA,"Yes",2022-08-16,2,"Incomplete",NA,NA,"Incomplete",NA,NA,NA,NA
3,"follow2",NA,NA,NA,NA,NA,NA,NA,NA,NA,NA,NA,NA,NA,NA,"Yes",2023-03-13,1,"Incomplete",NA,NA,"Incomplete",NA,NA,NA,NA
3,"follow1","New Event (?)",1,NA,NA,NA,NA,NA,NA,NA,NA,NA,NA,NA,NA,NA,NA,NA,NA,NA,NA,NA,2024-01-18 12:49:58,NA,"AIS","Incomplete"
3,"follow1","New Event (?)",2,NA,NA,NA,NA,NA,NA,NA,NA,NA,NA,NA,NA,NA,NA,NA,NA,NA,NA,NA,2024-01-18 12:50:01,NA,"ICH","Incomplete"
3,"follow2","New Event (?)",1,NA,NA,NA,NA,NA,NA,NA,NA,NA,NA,NA,NA,NA,NA,NA,NA,NA,NA,NA,2024-01-18 12:50:05,NA,"ICH","Incomplete"
3,"follow2","New Event (?)",2,NA,NA,NA,NA,NA,NA,NA,NA,NA,NA,NA,NA,NA,NA,NA,NA,NA,NA,NA,2024-01-18 12:50:07,NA,"TIA","Incomplete"
3,"follow2","New Event (?)",3,NA,NA,NA,NA,NA,NA,NA,NA,NA,NA,NA,NA,NA,NA,NA,NA,NA,NA,NA,2024-01-18 12:50:09,NA,"AIS","Incomplete"
4,"inclusion",NA,NA,"0204051342",2023-03-14,20:39:19,1905-04-02,117.949033861065,117,"female",NA,NA,NA,NA,"Incomplete",NA,NA,NA,"Incomplete",NA,NA,NA,NA,NA,NA,NA
4,"follow1",NA,NA,NA,NA,NA,NA,NA,NA,NA,NA,NA,NA,NA,NA,NA,NA,NA,"Incomplete",NA,NA,"Incomplete",NA,NA,NA,NA
4,"follow2",NA,NA,NA,NA,NA,NA,NA,NA,NA,NA,NA,NA,NA,NA,NA,NA,NA,"Incomplete",NA,NA,"Incomplete",NA,NA,NA,NA
4,"follow1","New Event (?)",1,NA,NA,NA,NA,NA,NA,NA,NA,NA,NA,NA,NA,NA,NA,NA,NA,NA,NA,NA,2001-04-11 08:39:05,96,"TIA","Complete"
4,"follow1","New Event (?)",2,NA,NA,NA,NA,NA,NA,NA,NA,NA,NA,NA,NA,NA,NA,NA,NA,NA,NA,NA,2010-04-11 08:39:25,105,"TIA","Complete"
4,"follow2","New Event (?)",1,NA,NA,NA,NA,NA,NA,NA,NA,NA,NA,NA,NA,NA,NA,NA,NA,NA,NA,NA,2024-01-18 12:50:19,118,"AIS","Complete"
4,"follow2","New Event (?)",2,NA,NA,NA,NA,NA,NA,NA,NA,NA,NA,NA,NA,NA,NA,NA,NA,NA,NA,NA,2024-01-18 12:50:22,118,"ICH","Incomplete"
4,"follow2","New Event (?)",3,NA,NA,NA,NA,NA,NA,NA,NA,NA,NA,NA,NA,NA,NA,NA,NA,NA,NA,NA,2024-01-18 12:50:24,118,"Unknown","Complete"
5,"inclusion",NA,NA,"0201976043",2023-03-23,08:50:31,1897-01-02,126.21751302217,126,"male","No","Yes","Yes","East","Complete",NA,NA,NA,"Incomplete",NA,NA,NA,NA,NA,NA,NA
5,"follow1",NA,NA,NA,NA,NA,NA,NA,NA,NA,NA,NA,NA,NA,NA,NA,NA,NA,"Incomplete",NA,NA,"Incomplete",NA,NA,NA,NA
5,"follow1","New Event (?)",1,NA,NA,NA,NA,NA,NA,NA,NA,NA,NA,NA,NA,NA,NA,NA,NA,NA,NA,NA,2024-04-11 09:00:33,127,"AIS","Complete"
5,"follow1","New Event (?)",2,NA,NA,NA,NA,NA,NA,NA,NA,NA,NA,NA,NA,NA,NA,NA,NA,NA,NA,NA,2024-04-11 09:00:41,127,"ICH","Complete"
6,"inclusion",NA,NA,"1202320122",2024-01-25,08:49:28,1932-02-12,91.952606829709,91,"female","No","Yes","No","East","Complete",NA,NA,NA,"Incomplete",NA,NA,NA,NA,NA,NA,NA
1 record_id redcap_event_name redcap_repeat_instrument redcap_repeat_instance cpr inclusion inclusion_time dob age age_integer sex cohabitation hypertension diabetes region baseline_data_start_complete mrs_assessed mrs_date mrs_score mrs_complete con_mrs con_calc consensus_complete event_datetime event_age event_type new_event_complete
2 1 inclusion NA NA 1203401OB4 2023-03-13 12:38:49 1940-03-12 83.0023888238636 83 female Yes No Yes East Incomplete Yes 2023-03-13 1 Incomplete NA NA NA NA NA NA NA
3 2 inclusion NA NA 0102342303 2023-03-01 10:38:57 1934-02-01 89.0778044723711 89 male Yes No No South Incomplete Yes 2023-03-07 1 Incomplete NA NA NA NA NA NA NA
4 2 follow1 NA NA NA NA NA NA NA NA NA NA NA NA NA NA Yes 2023-03-09 3 Incomplete NA NA Incomplete NA NA NA NA
5 2 follow1 New Event (?) 1 NA NA NA NA NA NA NA NA NA NA NA NA NA NA NA NA NA NA NA 2024-01-18 12:49:42 NA TIA Incomplete
6 3 inclusion NA NA 2301569823 2022-03-08 12:01:07 1956-01-23 66.1231921257795 66 male No Yes Yes North Incomplete NA NA NA Incomplete NA NA NA NA NA NA NA
7 3 follow1 NA NA NA NA NA NA NA NA NA NA NA NA NA NA Yes 2022-08-16 2 Incomplete NA NA Incomplete NA NA NA NA
8 3 follow2 NA NA NA NA NA NA NA NA NA NA NA NA NA NA Yes 2023-03-13 1 Incomplete NA NA Incomplete NA NA NA NA
9 3 follow1 New Event (?) 1 NA NA NA NA NA NA NA NA NA NA NA NA NA NA NA NA NA NA NA 2024-01-18 12:49:58 NA AIS Incomplete
10 3 follow1 New Event (?) 2 NA NA NA NA NA NA NA NA NA NA NA NA NA NA NA NA NA NA NA 2024-01-18 12:50:01 NA ICH Incomplete
11 3 follow2 New Event (?) 1 NA NA NA NA NA NA NA NA NA NA NA NA NA NA NA NA NA NA NA 2024-01-18 12:50:05 NA ICH Incomplete
12 3 follow2 New Event (?) 2 NA NA NA NA NA NA NA NA NA NA NA NA NA NA NA NA NA NA NA 2024-01-18 12:50:07 NA TIA Incomplete
13 3 follow2 New Event (?) 3 NA NA NA NA NA NA NA NA NA NA NA NA NA NA NA NA NA NA NA 2024-01-18 12:50:09 NA AIS Incomplete
14 4 inclusion NA NA 0204051342 2023-03-14 20:39:19 1905-04-02 117.949033861065 117 female NA NA NA NA Incomplete NA NA NA Incomplete NA NA NA NA NA NA NA
15 4 follow1 NA NA NA NA NA NA NA NA NA NA NA NA NA NA NA NA NA Incomplete NA NA Incomplete NA NA NA NA
16 4 follow2 NA NA NA NA NA NA NA NA NA NA NA NA NA NA NA NA NA Incomplete NA NA Incomplete NA NA NA NA
17 4 follow1 New Event (?) 1 NA NA NA NA NA NA NA NA NA NA NA NA NA NA NA NA NA NA NA 2001-04-11 08:39:05 96 TIA Complete
18 4 follow1 New Event (?) 2 NA NA NA NA NA NA NA NA NA NA NA NA NA NA NA NA NA NA NA 2010-04-11 08:39:25 105 TIA Complete
19 4 follow2 New Event (?) 1 NA NA NA NA NA NA NA NA NA NA NA NA NA NA NA NA NA NA NA 2024-01-18 12:50:19 118 AIS Complete
20 4 follow2 New Event (?) 2 NA NA NA NA NA NA NA NA NA NA NA NA NA NA NA NA NA NA NA 2024-01-18 12:50:22 118 ICH Incomplete
21 4 follow2 New Event (?) 3 NA NA NA NA NA NA NA NA NA NA NA NA NA NA NA NA NA NA NA 2024-01-18 12:50:24 118 Unknown Complete
22 5 inclusion NA NA 0201976043 2023-03-23 08:50:31 1897-01-02 126.21751302217 126 male No Yes Yes East Complete NA NA NA Incomplete NA NA NA NA NA NA NA
23 5 follow1 NA NA NA NA NA NA NA NA NA NA NA NA NA NA NA NA NA Incomplete NA NA Incomplete NA NA NA NA
24 5 follow1 New Event (?) 1 NA NA NA NA NA NA NA NA NA NA NA NA NA NA NA NA NA NA NA 2024-04-11 09:00:33 127 AIS Complete
25 5 follow1 New Event (?) 2 NA NA NA NA NA NA NA NA NA NA NA NA NA NA NA NA NA NA NA 2024-04-11 09:00:41 127 ICH Complete
26 6 inclusion NA NA 1202320122 2024-01-25 08:49:28 1932-02-12 91.952606829709 91 female No Yes No East Complete NA NA NA Incomplete NA NA NA NA NA NA NA

BIN
data/redcapcast_data.rda
View file

Binary file not shown.

BIN
data/redcapcast_meta.rda
View file

Binary file not shown.

41
inst/WORDLIST
View file

@ -1,87 +1,63 @@
Andreas
Assesment
CMD
Codecov
DEPRICATED
DOI
DataDictionary
Gammelgaard
GStat
Github
GithubActions
JSON
Lifecycle
METACRAN
MMRM
Nav
ORCID
POSIXct
Pivotting
README
REDCap
REDCapR
REDCapRITS
REDCapTidieR
Stackoverflow
UI
WD
al
api
attr
calc
capitalisation
charater
cond
cpr
da
dafault
datadictionary
datetime
demonstrational
detatched
dir
dmy
docx
doi
dplyr
dropdown
droplevels
ds
dta
et
factorises
factorising
fct
forcats
github
gtsummary
gues
hms
https
immprovements
io
jbi
keyring
labelled
labelling
mRS
matadata
md
mdy
mis
mrs
mtcars
na
natively
ncol
og
param
params
pegeler
perl
pos
pre
rds
readr
realising
redcapAPI
redcapcast
renv
runApp
sel
sep
seperator
@ -94,12 +70,9 @@ subheader
textclean
thorugh
tibble
tidyverse
trinker
truefalse
ui
un
unlabelled
uri
vec
wil
ymd

372
inst/shiny-examples/casting/app.R
View file

@ -1,372 +0,0 @@
library(bslib)
library(shiny)
library(openxlsx2)
library(haven)
library(readODS)
library(readr)
library(dplyr)
library(gt)
library(devtools)
# if (!requireNamespace("REDCapCAST")) {
# install.packages("REDCapCAST")
# }
# library(REDCapCAST)
## Load merged files for shinyapps.io hosting
if (file.exists(here::here("functions.R"))) {
source(here::here("functions.R"))
}
server <- function(input, output, session) {
v <- shiny::reactiveValues(
file = NULL
)
ds <- shiny::reactive({
shiny::req(input$ds)
out <- read_input(input$ds$datapath)
out <- out |>
## Parses data with readr functions
parse_data() |>
## Converts logical to factor, preserving attributes with own function
dplyr::mutate(dplyr::across(dplyr::where(is.logical), as_factor))
out
})
dat <- shiny::reactive({
out <- ds()
if (!is.null(input$factor_vars)) {
out <- out |>
dplyr::mutate(
dplyr::across(
dplyr::all_of(input$factor_vars),
as_factor
)
)
}
if (input$factorize == "yes") {
out <- out |>
(\(.x){
suppressWarnings(
numchar2fct(.x)
)
})()
}
out
})
shiny::eventReactive(input$load_data, {
v$file <- "loaded"
})
# getData <- reactive({
# if(is.null(input$ds$datapath)) return(NULL)
# })
# output$uploaded <- reactive({
# return(!is.null(getData()))
# })
dd <- shiny::reactive({
shiny::req(input$ds)
# v$file <- "loaded"
ds2dd_detailed(
data = dat(),
add.auto.id = input$add_id == "yes",
metadata = c(
"field_name", "form_name", "section_header", "field_type",
"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"
)
)
})
output$factor_vars <- shiny::renderUI({
shiny::req(input$ds)
selectizeInput(
inputId = "factor_vars",
selected = colnames(dat())[sapply(dat(), is.factor)],
label = "Covariables to format as categorical",
choices = colnames(dat()),
multiple = TRUE
)
})
## Specify ID if necessary
# output$id_var <- shiny::renderUI({
# shiny::req(input$ds)
# selectizeInput(
# inputId = "id_var",
# selected = colnames(dat())[1],
# label = "ID variable",
# choices = colnames(dat())[-match(colnames(dat()),input$factor_vars)],
# multiple = FALSE
# )
# })
output$data.tbl <- gt::render_gt(
dd() |>
cast_data_overview()
)
output$meta.tbl <- gt::render_gt(
dd() |>
cast_meta_overview()
)
# Downloadable csv of dataset ----
output$downloadData <- shiny::downloadHandler(
filename = "data_ready.csv",
content = function(file) {
write.csv(purrr::pluck(dd(), "data"), file, row.names = FALSE, na = "")
}
)
# Downloadable csv of data dictionary ----
output$downloadMeta <- shiny::downloadHandler(
filename = paste0("REDCapCAST_DataDictionary_", Sys.Date(), ".csv"),
content = function(file) {
write.csv(purrr::pluck(dd(), "meta"), file, row.names = FALSE, na = "")
}
)
# Downloadable .zip of instrument ----
output$downloadInstrument <- shiny::downloadHandler(
filename = paste0("REDCapCAST_instrument", Sys.Date(), ".zip"),
content = function(file) {
export_redcap_instrument(purrr::pluck(dd(), "meta"),
file = file,
record.id = ifelse(input$add_id == "none", NA, names(dat())[1])
)
}
)
output_staging <- shiny::reactiveValues()
output_staging$meta <- output_staging$data <- NA
shiny::observeEvent(input$upload.meta, {
upload_meta()
})
shiny::observeEvent(input$upload.data, {
upload_data()
})
upload_meta <- function() {
shiny::req(input$uri)
shiny::req(input$api)
output_staging$meta <- REDCapR::redcap_metadata_write(
ds = purrr::pluck(dd(), "meta"),
redcap_uri = input$uri,
token = input$api
) |> purrr::pluck("success")
}
upload_data <- function() {
shiny::req(input$uri)
shiny::req(input$api)
output_staging$data <- dd() |>
apply_factor_labels() |>
REDCapR::redcap_write(
redcap_uri = input$uri,
token = input$api
) |>
purrr::pluck("success")
}
output$upload.meta.print <- renderText(output_staging$meta)
output$upload.data.print <- renderText(output_staging$data)
output$uploaded <- shiny::reactive({
if (is.null(v$file)) {
"no"
} else {
"yes"
}
})
shiny::outputOptions(output, "uploaded", suspendWhenHidden = FALSE)
output$data.load <- shiny::renderText(expr = nrow(dat()))
# session$onSessionEnded(function() {
# # cat("Session Ended\n")
# unlink("www",recursive = TRUE)
# })
}
ui <-
bslib::page(
theme = bslib::bs_theme(preset = "united"),
title = "REDCap database creator",
bslib::page_navbar(
title = "Easy REDCap database creation",
sidebar = bslib::sidebar(
width = 300,
shiny::h5("Metadata casting"),
shiny::fileInput(
inputId = "ds",
label = "Upload spreadsheet",
multiple = FALSE,
accept = c(
".csv",
".xls",
".xlsx",
".dta",
".rds",
".ods"
)
),
shiny::actionButton(
inputId = "options",
label = "Show options",
icon = shiny::icon("wrench")
),
shiny::helpText("Choose and upload a dataset, then press the button for data modification and options for data download or upload."),
# For some odd reason this only unfolds when the preview panel is shown..
# This has been solved by adding an arbitrary button to load data - which was abandoned again
shiny::conditionalPanel(
# condition = "output.uploaded=='yes'",
condition = "input.options > 0",
shiny::radioButtons(
inputId = "add_id",
label = "Add ID, or use first column?",
selected = "no",
inline = TRUE,
choices = list(
"First column" = "no",
"Add ID" = "yes",
"No ID" = "none"
)
),
shiny::radioButtons(
inputId = "factorize",
label = "Factorize variables with few levels?",
selected = "yes",
inline = TRUE,
choices = list(
"Yes" = "yes",
"No" = "no"
)
),
shiny::radioButtons(
inputId = "specify_factors",
label = "Specify categorical variables?",
selected = "no",
inline = TRUE,
choices = list(
"Yes" = "yes",
"No" = "no"
)
),
shiny::conditionalPanel(
condition = "input.specify_factors=='yes'",
shiny::uiOutput("factor_vars")
),
# condition = "input.load_data",
# shiny::helpText("Below you can download the dataset formatted for upload and the
# corresponding data dictionary for a new data base, if you want to upload manually."),
shiny::tags$hr(),
shiny::h4("Download data for manual upload"),
shiny::helpText("Look further down for direct upload option"),
# Button
shiny::downloadButton(outputId = "downloadData", label = "Download renamed data"),
shiny::em("and then"),
# Button
shiny::downloadButton(outputId = "downloadMeta", label = "Download data dictionary"),
shiny::em("or"),
shiny::downloadButton(outputId = "downloadInstrument", label = "Download as instrument"),
# Horizontal line ----
shiny::tags$hr(),
shiny::radioButtons(
inputId = "upload_redcap",
label = "Upload directly to a REDCap server?",
selected = "no",
inline = TRUE,
choices = list(
"Yes" = "yes",
"No" = "no"
)
),
shiny::conditionalPanel(
condition = "input.upload_redcap=='yes'",
shiny::h4("2) Data base upload"),
shiny::helpText("This tool is usable for now. Detailed instructions are coming."),
shiny::textInput(
inputId = "uri",
label = "URI",
value = "https://redcap.your.institution/api/"
),
shiny::textInput(
inputId = "api",
label = "API key",
value = ""
),
shiny::helpText("An API key is an access key to the REDCap database. Please", shiny::a("see here for directions", href = "https://www.iths.org/news/redcap-tip/redcap-api-101/"), " to obtain an API key for your project."),
shiny::actionButton(
inputId = "upload.meta",
label = "Upload datadictionary", icon = shiny::icon("book-bookmark")
),
shiny::helpText("Please note, that before uploading any real data, put your project
into production mode."),
shiny::actionButton(
inputId = "upload.data",
label = "Upload data", icon = shiny::icon("upload")
)
)
),
shiny::br(),
shiny::br(),
shiny::br(),
shiny::p(
"License: ", shiny::a("GPL-3+", href = "https://agdamsbo.github.io/REDCapCAST/LICENSE.html")
),
shiny::p(
shiny::a("Package documentation", href = "https://agdamsbo.github.io/REDCapCAST")
)
),
bslib::nav_panel(
title = "Intro",
shiny::markdown(readLines("www/SHINYCAST.md")),
shiny::br(),
shiny::textOutput(outputId = "data.load")
),
# bslib::nav_spacer(),
bslib::nav_panel(
title = "Data preview",
gt::gt_output(outputId = "data.tbl")
# shiny::htmlOutput(outputId = "data.tbl", container = shiny::span)
),
bslib::nav_panel(
title = "Dictionary overview",
gt::gt_output(outputId = "meta.tbl")
# shiny::htmlOutput(outputId = "meta.tbl", container = shiny::span)
),
bslib::nav_panel(
title = "Upload",
shiny::h3("Meta upload overview"),
shiny::textOutput(outputId = "upload.meta.print"),
shiny::h3("Data upload overview"),
shiny::textOutput(outputId = "upload.data.print")
)
)
)
shiny::shinyApp(ui = ui, server = server)

10
inst/shiny-examples/casting/rsconnect/shinyapps.io/agdamsbo/redcapcast-dev.dcf
View file

@ -1,10 +0,0 @@
name: redcapcast-dev
title:
username: agdamsbo
account: agdamsbo
server: shinyapps.io
hostUrl: https://api.shinyapps.io/v1
appId: 13463848
bundleId: 9425126
url: https://agdamsbo.shinyapps.io/redcapcast-dev/
version: 1

10
inst/shiny-examples/casting/rsconnect/shinyapps.io/agdamsbo/redcapcast.dcf
View file

@ -1,10 +0,0 @@
name: redcapcast
title:
username: agdamsbo
account: agdamsbo
server: shinyapps.io
hostUrl: https://api.shinyapps.io/v1
appId: 11351429
bundleId: 9642648
url: https://agdamsbo.shinyapps.io/redcapcast/
version: 1

68
inst/shiny-examples/casting/www/SHINYCAST.md
View file

@ -1,68 +0,0 @@
# ![](logo.png) REDCapCAST app
Welcome to the REDCapCAST app to create/cast REDCap database metadata. This is app allows you to create a new REDCap data base or instrument based on a simple spreadsheet.
## Disclaimer
This tool is aimed at demonstrating use of REDCapCAST. The app can be run locally or on a hosted server (will save no data anywhere). No responsibility for data loss or any other problems will be taken.
Also, this tool will not produce a ready-for-prime-time database, but it will be a comprehensive framework with suggestions for data-classes. You will need to go through your database afterwards and take your time to ensure everything is as you'd expect and work as intended.
## Overview
The functions of this app can be described in two parts:
1. create REDCap metadata files like data dictionary or instrument based on a spreadsheet (.csv/.xls(x)/.dta/.ods) for download and manual upload to your REDCap server or
2. upload the created database file and data to a given REDCap server via API access.
## Getting started
On the left, you initially just find one single option to upload a spreadsheet. Having done this, you can then preview the uploaded data and generated data dictionary by selecting the relevant tab on the top right.
### REDCap database files creation
The spreadsheet column names will be adjusted to comply with REDCap naming criteria, and a renamed (adjusted) spreadsheet can be downloaded. If your spreadsheet columns are labelled (exported from stata or labelled in R, these labels will be used for the visible field names (field label) i REDCap).
Based on the uploaded spreadsheet, the app will make a qualified guess on data classes and if the data is labelled (like .rda or .dta) all this information will be included in the data dictionary file. The default data format is "text". In addition categorical variables can be specified manually, and you caon add an ID column , or assume the first column is the ID (please reorder before export).
If you want to add data to an existing database, an instrument can be created. This metadata file is identical to a data dictionary, but does not include the ID field (if included or added) and is packaged as a .zip file, which is uploaded in the "Designer" interface in REDCap.
### Transferring directly to a REDCap database
This feature is mainly a show-case. Use it if you like, but most will feel more secure doing manual uploads.
Based on the API-functions in REDCap, you can upload your data dictionary and renamed data directly from this interface (no data is stored on the server, but consider launching this shiny app on your own machine after having installed the [REDCapCAST package](https://agdamsbo.github.io/REDCapCAST/#installation) in R). Launch a local instance of this app with:
```
REDCapCAST::shiny_cast()
```
Please mind you, that uploading a new data dictionary can delete data in your database and is non-reversible. Make sure to save a backup beforehand. Also, uploading a data dictionary to a server in production is not possible. This step is only advisable for newly created databases. See the "Disclaimer" above.
## Background
The main structure of variables of a REDCap database is defined by a so-called data dictionary. This is a simple spreadsheet file defining one or more instruments, data classes, branching logic and more. It does not contain any information on randomization, longitudinal data or repeatable instruments. These functions must be set up in the REDCap interface after having defined the data dictionary.
## Motivation
This tool has been created out of frustration with the lack of easy-to-use tools available and with a hope to help colleagues and others to easily create and extend REDCap databases.
## Use and feedback
Please, if you use this tool, don't hesitate to contact me with feedback if something doesn't work as expected. But, please also mind the disclaimer above. Contact information can be found on the [package documentation page](https://agdamsbo.github.io/REDCapCAST/).
## Citing
This app and package can be cited using the following bibtex citation or by referencing the following doi-identifier: [10.5281/zenodo.8013984](https://doi.org/10.5281/zenodo.8013984)
```
@agdamsboREDCapCAST{,
title = {REDCapCAST: REDCap Castellated Data Handling and Metadata Casting},
author = {Andreas Gammelgaard Damsbo},
year = {2024},
note = {R package version 24.11.2, https://agdamsbo.github.io/REDCapCAST/},
url = {https://github.com/agdamsbo/REDCapCAST},
doi = {10.5281/zenodo.8013984},
}
```

29
man/REDCapCAST-package.Rd
View file

@ -1,29 +0,0 @@
% Generated by roxygen2: do not edit by hand
% Please edit documentation in R/REDCapCAST-package.R
\docType{package}
\name{REDCapCAST-package}
\alias{REDCapCAST}
\alias{REDCapCAST-package}
\title{REDCapCAST: REDCap Metadata Casting and Castellated Data Handling}
\description{
Casting metadata for REDCap database creation and handling of castellated data using repeated instruments and longitudinal projects in 'REDCap'. Keeps a focused data export approach, by allowing to only export required data from the database. Also for casting new REDCap databases based on datasets from other sources. Originally forked from the R part of 'REDCapRITS' by Paul Egeler. See \url{https://github.com/pegeler/REDCapRITS}. 'REDCap' (Research Electronic Data Capture) is a secure, web-based software platform designed to support data capture for research studies, providing 1) an intuitive interface for validated data capture; 2) audit trails for tracking data manipulation and export procedures; 3) automated export procedures for seamless data downloads to common statistical packages; and 4) procedures for data integration and interoperability with external sources (Harris et al (2009) \doi{10.1016/j.jbi.2008.08.010}; Harris et al (2019) \doi{10.1016/j.jbi.2019.103208}).
}
\seealso{
Useful links:
\itemize{
\item \url{https://github.com/agdamsbo/REDCapCAST}
\item \url{https://agdamsbo.github.io/REDCapCAST/}
\item Report bugs at \url{https://github.com/agdamsbo/REDCapCAST/issues}
}
}
\author{
\strong{Maintainer}: Andreas Gammelgaard Damsbo \email{agdamsbo@clin.au.dk} (\href{https://orcid.org/0000-0002-7559-1154}{ORCID})
Authors:
\itemize{
\item Paul Egeler \email{paulegeler@gmail.com} (\href{https://orcid.org/0000-0001-6948-9498}{ORCID})
}
}
\keyword{internal}

11
man/REDCap_split.Rd
View file

@ -21,7 +21,8 @@ call.}
JSON from an API call.}
\item{primary_table_name}{Name given to the list element for the primary
output table. Ignored if \code{forms = 'all'}.}
output table (as described in \emph{README.md}). Ignored if
\code{forms = 'all'}.}
\item{forms}{Indicate whether to create separate tables for repeating
instruments only or for all forms.}
@ -65,7 +66,7 @@ metadata <- postForm(
)
# Convert exported JSON strings into a list of data.frames
REDCapCAST::REDCap_split(records, metadata)
REDCapRITS::REDCap_split(records, metadata)
# Using a raw data export -------------------------------------------------
@ -78,7 +79,7 @@ metadata <- read.csv(
)
# Split the tables
REDCapCAST::REDCap_split(records, metadata)
REDCapRITS::REDCap_split(records, metadata)
# In conjunction with the R export script ---------------------------------
@ -95,10 +96,10 @@ source("ExampleProject_R_2018-06-03_1700.r")
metadata <- read.csv("ExampleProject_DataDictionary_2018-06-03.csv")
# Split the tables
REDCapCAST::REDCap_split(data, metadata)
REDCapRITS::REDCap_split(data, metadata)
setwd(old)
}
}
\author{
Paul W. Egeler
Paul W. Egeler, M.S., GStat
}

20
man/all_na.Rd
View file

@ -1,20 +0,0 @@
% Generated by roxygen2: do not edit by hand
% Please edit documentation in R/ds2dd_detailed.R
\name{all_na}
\alias{all_na}
\title{Check if vector is all NA}
\usage{
all_na(data)
}
\arguments{
\item{data}{vector of data.frame}
}
\value{
logical
}
\description{
Check if vector is all NA
}
\examples{
rep(NA, 4) |> all_na()
}

19
man/apply_factor_labels.Rd
View file

@ -1,19 +0,0 @@
% Generated by roxygen2: do not edit by hand
% Please edit documentation in R/read_redcap_tables.R
\name{apply_factor_labels}
\alias{apply_factor_labels}
\title{Preserve all factor levels from REDCap data dictionary in data export}
\usage{
apply_factor_labels(data, meta = NULL)
}
\arguments{
\item{data}{REDCap exported data set}
\item{meta}{REDCap data dictionary}
}
\value{
data.frame
}
\description{
Preserve all factor levels from REDCap data dictionary in data export
}

19
man/apply_field_label.Rd
View file

@ -1,19 +0,0 @@
% Generated by roxygen2: do not edit by hand
% Please edit documentation in R/read_redcap_tables.R
\name{apply_field_label}
\alias{apply_field_label}
\title{Apply REDCap filed labels to data frame}
\usage{
apply_field_label(data, meta)
}
\arguments{
\item{data}{REDCap exported data set}
\item{meta}{REDCap data dictionary}
}
\value{
data.frame
}
\description{
Apply REDCap filed labels to data frame
}

90
man/as_factor.Rd
View file

@ -1,90 +0,0 @@
% Generated by roxygen2: do not edit by hand
% Please edit documentation in R/as_factor.R
\name{as_factor}
\alias{as_factor}
\alias{as_factor.factor}
\alias{as_factor.logical}
\alias{as_factor.numeric}
\alias{as_factor.character}
\alias{as_factor.haven_labelled}
\alias{as_factor.labelled}
\alias{as_factor.data.frame}
\title{Convert labelled vectors to factors while preserving attributes}
\usage{
as_factor(x, ...)
\method{as_factor}{factor}(x, ...)
\method{as_factor}{logical}(x, ...)
\method{as_factor}{numeric}(x, ...)
\method{as_factor}{character}(x, ...)
\method{as_factor}{haven_labelled}(
x,
levels = c("default", "labels", "values", "both"),
ordered = FALSE,
...
)
\method{as_factor}{labelled}(
x,
levels = c("default", "labels", "values", "both"),
ordered = FALSE,
...
)
\method{as_factor}{data.frame}(x, ..., only_labelled = TRUE)
}
\arguments{
\item{x}{Object to coerce to a factor.}
\item{...}{Other arguments passed down to method.}
\item{levels}{How to create the levels of the generated factor:
* "default": uses labels where available, otherwise the values.
Labels are sorted by value.
* "both": like "default", but pastes together the level and value
* "label": use only the labels; unlabelled values become `NA`
* "values": use only the values}
\item{ordered}{If `TRUE` create an ordered (ordinal) factor, if
`FALSE` (the default) create a regular (nominal) factor.}
\item{only_labelled}{Only apply to labelled columns?}
}
\description{
This extends \link[forcats]{as_factor} as well as \link[haven]{as_factor}, by appending
original attributes except for "class" after converting to factor to avoid
ta loss in case of rich formatted and labelled data.
}
\details{
Please refer to parent functions for extended documentation.
To avoid redundancy calls and errors, functions are copy-pasted here
Empty variables with empty levels attribute are interpreted as logicals
}
\examples{
# will preserve all attributes
c(1, 4, 3, "A", 7, 8, 1) |> as_factor()
structure(c(1, 2, 3, 2, 10, 9),
labels = c(Unknown = 9, Refused = 10)
) |>
as_factor() |>
dput()
structure(c(1, 2, 3, 2, 10, 9),
labels = c(Unknown = 9, Refused = 10),
class = "haven_labelled"
) |>
as_factor() |> class()
structure(rep(NA,10),
class = c("labelled")
) |>
as_factor() |> summary()
rep(NA,10) |> as_factor()
}

58
man/as_logical.Rd
View file

@ -1,58 +0,0 @@
% Generated by roxygen2: do not edit by hand
% Please edit documentation in R/as_logical.R
\name{as_logical}
\alias{as_logical}
\alias{as_logical.data.frame}
\alias{as_logical.default}
\title{Interpret specific binary values as logicals}
\usage{
as_logical(
x,
values = list(c("TRUE", "FALSE"), c("Yes", "No"), c(1, 0), c(1, 2)),
...
)
\method{as_logical}{data.frame}(
x,
values = list(c("TRUE", "FALSE"), c("Yes", "No"), c(1, 0), c(1, 2)),
...
)
\method{as_logical}{default}(
x,
values = list(c("TRUE", "FALSE"), c("Yes", "No"), c(1, 0), c(1, 2)),
...
)
}
\arguments{
\item{x}{vector or data.frame}
\item{values}{list of values to interpret as logicals. First value is}
\item{...}{ignored
interpreted as TRUE.}
}
\value{
vector
}
\description{
Interpret specific binary values as logicals
}
\examples{
c(sample(c("TRUE", "FALSE"), 20, TRUE), NA) |>
as_logical() |>
class()
ds <- dplyr::tibble(
B = factor(sample(c(1, 2), 20, TRUE)),
A = factor(sample(c("TRUE", "FALSE"), 20, TRUE)),
C = sample(c(3, 4), 20, TRUE),
D = factor(sample(c("In", "Out"), 20, TRUE))
)
ds |>
as_logical() |>
sapply(class)
ds$A |> class()
sample(c("TRUE",NA), 20, TRUE) |>
as_logical()
as_logical(0)
}

17
man/cast_data_overview.Rd
View file

@ -1,17 +0,0 @@
% Generated by roxygen2: do not edit by hand
% Please edit documentation in R/shiny_cast.R
\name{cast_data_overview}
\alias{cast_data_overview}
\title{Overview of REDCapCAST data for shiny}
\usage{
cast_data_overview(data)
}
\arguments{
\item{data}{list with class 'REDCapCAST'}
}
\value{
gt object
}
\description{
Overview of REDCapCAST data for shiny
}

17
man/cast_meta_overview.Rd
View file

@ -1,17 +0,0 @@
% Generated by roxygen2: do not edit by hand
% Please edit documentation in R/shiny_cast.R
\name{cast_meta_overview}
\alias{cast_meta_overview}
\title{Overview of REDCapCAST meta data for shiny}
\usage{
cast_meta_overview(data)
}
\arguments{
\item{data}{list with class 'REDCapCAST'}
}
\value{
gt object
}
\description{
Overview of REDCapCAST meta data for shiny
}

22
man/clean_field_label.Rd
View file

@ -1,22 +0,0 @@
% Generated by roxygen2: do not edit by hand
% Please edit documentation in R/read_redcap_tables.R
\name{clean_field_label}
\alias{clean_field_label}
\title{Very simple function to remove rich text formatting from field label
and save the first paragraph ('<p>...</p>').}
\usage{
clean_field_label(data)
}
\arguments{
\item{data}{field label}
}
\value{
character vector
}
\description{
Very simple function to remove rich text formatting from field label
and save the first paragraph ('<p>...</p>').
}
\examples{
clean_field_label("<div class=\"rich-text-field-label\"><p>Fazekas score</p></div>")
}

3
man/clean_redcap_name.Rd
View file

@ -17,6 +17,3 @@ Stepwise removal on non-alphanumeric characters, trailing white space,
substitutes spaces for underscores and converts to lower case.
Trying to make up for different naming conventions.
}
\examples{
"Research!, ne:ws? and c;l-.ls" |> clean_redcap_name()
}

31
man/compact_vec.Rd
View file

@ -1,31 +0,0 @@
% Generated by roxygen2: do not edit by hand
% Please edit documentation in R/ds2dd_detailed.R
\name{compact_vec}
\alias{compact_vec}
\title{Compacting a vector of any length with or without names}
\usage{
compact_vec(data, nm.sep = ": ", val.sep = "; ")
}
\arguments{
\item{data}{vector, optionally named}
\item{nm.sep}{string separating name from value if any}
\item{val.sep}{string separating values}
}
\value{
character string
}
\description{
Compacting a vector of any length with or without names
}
\examples{
sample(seq_len(4), 20, TRUE) |>
as_factor() |>
named_levels() |>
sort() |>
compact_vec()
1:6 |> compact_vec()
"test" |> compact_vec()
sample(letters[1:9], 20, TRUE) |> compact_vec()
}

33
man/create_instrument_meta.Rd
View file

@ -1,8 +1,8 @@
% Generated by roxygen2: do not edit by hand
% Please edit documentation in R/export_redcap_instrument.R
% Please edit documentation in R/create_instrument_meta.R
\name{create_instrument_meta}
\alias{create_instrument_meta}
\title{DEPRICATED Create zips file with necessary content based on data set}
\title{Create zips file with necessary content based on data set}
\usage{
create_instrument_meta(data, dir = here::here(""), record.id = TRUE)
}
@ -21,32 +21,23 @@ list
}
\description{
Metadata can be added by editing the data dictionary of a project in the
initial design phase. If you want to later add new instruments, this
function can be used to create (an) instrument(s) to add to a project in
production.
initial design phase. If you want to later add new instruments, this can be
used to add instrument(s) to a project in production.
}
\examples{
\dontrun{
data <- iris |>
ds2dd_detailed(
add.auto.id = TRUE,
form.name = sample(c("b", "c"),
size = 6,
replace = TRUE, prob = rep(.5, 2)
)
) |>
ds2dd_detailed(add.auto.id = TRUE,
form.name=sample(c("b","c"),size = 6,replace = TRUE,prob=rep(.5,2))) |>
purrr::pluck("meta")
# data |> create_instrument_meta()
data <- iris |>
ds2dd_detailed(add.auto.id = FALSE) |>
purrr::pluck("data")
iris |>
setNames(glue::glue("{sample(x = c('a','b'),size = length(ncol(iris)),
replace=TRUE,prob = rep(x=.5,2))}__{names(iris)}")) |>
ds2dd_detailed(form.sep = "__")
data |>
purrr::pluck("meta") |>
create_instrument_meta(record.id = FALSE)
}
names(data) <- glue::glue("{sample(x = c('a','b'),size = length(names(data)),
replace=TRUE,prob = rep(x=.5,2))}__{names(data)}")
data <- data |> ds2dd_detailed(form.sep="__")
# data |>
# purrr::pluck("meta") |>
# create_instrument_meta(record.id = FALSE)
}

22
man/cut_string_length.Rd
View file

@ -1,22 +0,0 @@
% Generated by roxygen2: do not edit by hand
% Please edit documentation in R/utils.r
\name{cut_string_length}
\alias{cut_string_length}
\title{Cut string to desired length}
\usage{
cut_string_length(data, l = 100)
}
\arguments{
\item{data}{data}
\item{l}{length}
}
\value{
character string of length l
}
\description{
Cut string to desired length
}
\examples{
"length" |> cut_string_length(l=3)
}

8
man/ds2dd.Rd
View file

@ -1,5 +1,5 @@
% Generated by roxygen2: do not edit by hand
% Please edit documentation in R/ds2dd_detailed.R
% Please edit documentation in R/ds2dd.R
\name{ds2dd}
\alias{ds2dd}
\title{(DEPRECATED) Data set to data dictionary function}
@ -11,7 +11,7 @@ ds2dd(
field.type = "text",
field.label = NULL,
include.column.names = FALSE,
metadata = names(REDCapCAST::redcapcast_meta)
metadata = metadata_names
)
}
\arguments{
@ -34,7 +34,7 @@ names.}
column names for original data set for upload.}
\item{metadata}{Metadata column names. Default is the included
names(REDCapCAST::redcapcast_meta).}
REDCapCAST::metadata_names.}
}
\value{
data.frame or list of data.frame and vector
@ -49,5 +49,5 @@ Migrated from stRoke ds2dd(). Fits better with the functionality of
}
\examples{
redcapcast_data$record_id <- seq_len(nrow(redcapcast_data))
ds2dd(redcapcast_data, include.column.names = TRUE)
ds2dd(redcapcast_data, include.column.names=TRUE)
}

43
man/ds2dd_detailed.Rd
View file

@ -16,7 +16,9 @@ ds2dd_detailed(
field.label.attr = "label",
field.validation = NULL,
metadata = names(REDCapCAST::redcapcast_meta),
convert.logicals = FALSE
validate.time = FALSE,
time.var.sel.pos = "[Tt]i[d(me)]",
time.var.sel.neg = "[Dd]at[eo]"
)
}
\arguments{
@ -32,7 +34,7 @@ ncol(data). Default is NULL and "data" is used.}
\item{form.sep}{If supplied dataset has form names as suffix or prefix to the
column/variable names, the seperator can be specified. If supplied, the
form.name is ignored. Default is NULL.}
form.sep is ignored. Default is NULL.}
\item{form.prefix}{Flag to set if form is prefix (TRUE) or suffix (FALSE) to
the column names. Assumes all columns have pre- or suffix if specified.}
@ -55,9 +57,15 @@ or attribute `factor.labels.attr` for haven_labelled data set (imported .dta
file with `haven::read_dta()`).}
\item{metadata}{redcap metadata headings. Default is
names(REDCapCAST::redcapcast_meta).}
REDCapCAST:::metadata_names.}
\item{convert.logicals}{convert logicals to factor. Default is TRUE.}
\item{validate.time}{Flag to validate guessed time columns}
\item{time.var.sel.pos}{Positive selection regex string passed to
`gues_time_only_filter()` as sel.pos.}
\item{time.var.sel.neg}{Negative selection regex string passed to
`gues_time_only_filter()` as sel.neg.}
}
\value{
list of length 2
@ -75,32 +83,15 @@ Ensure, that the data set is formatted with as much information as possible.
`field.type` can be supplied
}
\examples{
## Basic parsing with default options
requireNamespace("REDCapCAST")
redcapcast_data |>
dplyr::select(-dplyr::starts_with("redcap_")) |>
ds2dd_detailed()
## Adding a record_id field
data <- REDCapCAST::redcapcast_data
data |> ds2dd_detailed(validate.time = TRUE)
data |> ds2dd_detailed()
iris |> ds2dd_detailed(add.auto.id = TRUE)
## Passing form name information to function
iris |>
ds2dd_detailed(
add.auto.id = TRUE,
form.name = sample(c("b", "c"), size = 6, replace = TRUE, prob = rep(.5, 2))
) |>
purrr::pluck("meta")
mtcars |>
dplyr::mutate(unknown = NA) |>
numchar2fct() |>
ds2dd_detailed(add.auto.id = TRUE)
## Using column name suffix to carry form name
mtcars |> ds2dd_detailed(add.auto.id = TRUE)
data <- iris |>
ds2dd_detailed(add.auto.id = TRUE) |>
purrr::pluck("data")
names(data) <- glue::glue("{sample(x = c('a','b'),size = length(names(data)),
replace=TRUE,prob = rep(x=.5,2))}__{names(data)}")
data |> ds2dd_detailed(form.sep = "__")
data |> ds2dd_detailed(form.sep="__")
}

29
man/easy_redcap.Rd
View file

@ -4,31 +4,17 @@
\alias{easy_redcap}
\title{Secure API key storage and data acquisition in one}
\usage{
easy_redcap(
project.name,
uri,
raw_or_label = "both",
data_format = c("wide", "list", "redcap", "long"),
widen.data = NULL,
...
)
easy_redcap(project.name, widen.data = TRUE, uri, ...)
}
\arguments{
\item{project.name}{The name of the current project (for key storage with
\link[keyring]{key_set}, using the default keyring)}
`keyring::key_set()`, using the default keyring)}
\item{widen.data}{argument to widen the exported data}
\item{uri}{REDCap database API uri}
\item{raw_or_label}{argument passed on to
\link[REDCapCAST]{read_redcap_tables}. Default is "both" to get labelled
data.}
\item{data_format}{Choose the data}
\item{widen.data}{argument to widen the exported data. [DEPRECATED], use
`data_format`instead}
\item{...}{arguments passed on to \link[REDCapCAST]{read_redcap_tables}.}
\item{...}{arguments passed on to `REDCapCAST::read_redcap_tables()`}
}
\value{
data.frame or list depending on widen.data
@ -36,8 +22,3 @@ data.frame or list depending on widen.data
\description{
Secure API key storage and data acquisition in one
}
\examples{
\dontrun{
easy_redcap("My_new_project", fields = c("record_id", "age", "hypertension"))
}
}

49
man/export_redcap_instrument.Rd
View file

@ -1,49 +0,0 @@
% Generated by roxygen2: do not edit by hand
% Please edit documentation in R/export_redcap_instrument.R
\name{export_redcap_instrument}
\alias{export_redcap_instrument}
\title{Creates zip-file with necessary content to manually add instrument to database}
\usage{
export_redcap_instrument(data, file, force = FALSE, record.id = "record_id")
}
\arguments{
\item{data}{metadata for the relevant instrument.
Could be from `ds2dd_detailed()`}
\item{file}{destination file name.}
\item{force}{force instrument creation and ignore different form names by
just using the first.}
\item{record.id}{record id variable name. Default is 'record_id'.}
}
\value{
exports zip-file
}
\description{
Metadata can be added by editing the data dictionary of a project in the
initial design phase. If you want to later add new instruments, this
function can be used to create (an) instrument(s) to add to a project in
production.
}
\examples{
# iris |>
# ds2dd_detailed(
# add.auto.id = TRUE,
# form.name = sample(c("b", "c"), size = 6, replace = TRUE, prob = rep(.5, 2))
# ) |>
# purrr::pluck("meta") |>
# (\(.x){
# split(.x, .x$form_name)
# })() |>
# purrr::imap(function(.x, .i){
# export_redcap_instrument(.x,file=here::here(paste0(.i,Sys.Date(),".zip")))
# })
# iris |>
# ds2dd_detailed(
# add.auto.id = TRUE
# ) |>
# purrr::pluck("meta") |>
# export_redcap_instrument(file=here::here(paste0("instrument",Sys.Date(),".zip")))
}

42
man/fct2num.Rd
View file

@ -1,42 +0,0 @@
% Generated by roxygen2: do not edit by hand
% Please edit documentation in R/as_factor.R
\name{fct2num}
\alias{fct2num}
\title{Allows conversion of factor to numeric values preserving original levels}
\usage{
fct2num(data)
}
\arguments{
\item{data}{vector}
}
\value{
numeric vector
}
\description{
Allows conversion of factor to numeric values preserving original levels
}
\examples{
c(1, 4, 3, "A", 7, 8, 1) |>
as_factor() |>
fct2num()
structure(c(1, 2, 3, 2, 10, 9),
labels = c(Unknown = 9, Refused = 10),
class = "haven_labelled"
) |>
as_factor() |>
fct2num()
structure(c(1, 2, 3, 2, 10, 9),
labels = c(Unknown = 9, Refused = 10),
class = "labelled"
) |>
as_factor() |>
fct2num()
structure(c(1, 2, 3, 2, 10, 9),
labels = c(Unknown = 9, Refused = 10)
) |>
as_factor() |>
fct2num()
}

31
man/fct_drop.Rd
View file

@ -1,31 +0,0 @@
% Generated by roxygen2: do not edit by hand
% Please edit documentation in R/fct_drop.R
\name{fct_drop}
\alias{fct_drop}
\alias{fct_drop.data.frame}
\alias{fct_drop.factor}
\title{Drop unused levels preserving label data}
\usage{
fct_drop(x, ...)
\method{fct_drop}{data.frame}(x, ...)
\method{fct_drop}{factor}(x, ...)
}
\arguments{
\item{x}{Factor to drop unused levels}
\item{...}{Other arguments passed down to method.}
}
\description{
This extends [forcats::fct_drop()] to natively work across a data.frame and
replaces [base::droplevels()].
}
\examples{
mtcars |>
numchar2fct() |>
fct_drop()
mtcars |>
numchar2fct() |>
dplyr::mutate(vs = fct_drop(vs))
}

BIN
man/figures/logo.png Normal file
View file

Binary file not shown.
Side by side

After

Width:  |  Height:  |  Size: 9.8 KiB

BIN
man/figures/rook-cap.png Normal file
View file

Binary file not shown.
Side by side

After

Width:  |  Height:  |  Size: 8.6 KiB

6
man/file_extension.Rd
View file

@ -2,7 +2,7 @@
% Please edit documentation in R/shiny_cast.R
\name{file_extension}
\alias{file_extension}
\title{DEPRECATED Helper to import files correctly}
\title{Helper to import files correctly}
\usage{
file_extension(filenames)
}
@ -13,9 +13,9 @@ file_extension(filenames)
character vector
}
\description{
DEPRECATED Helper to import files correctly
Helper to import files correctly
}
\examples{
file_extension(list.files(here::here(""))[[2]])[[1]]
file_extension(c("file.cd..ks", "file"))
file_extension(c("file.cd..ks","file"))
}

23
man/format_redcap_factor.Rd
View file

@ -1,23 +0,0 @@
% Generated by roxygen2: do not edit by hand
% Please edit documentation in R/read_redcap_tables.R
\name{format_redcap_factor}
\alias{format_redcap_factor}
\title{Converts REDCap choices to factor levels and stores in labels attribute}
\usage{
format_redcap_factor(data, meta)
}
\arguments{
\item{data}{vector}
\item{meta}{vector of REDCap choices}
}
\value{
vector of class "labelled" with a "labels" attribute
}
\description{
Applying \link[REDCapCAST]{as_factor} to the data.frame or variable, will
coerce to a factor.
}
\examples{
format_redcap_factor(sample(1:3, 20, TRUE), "1, First. | 2, second | 3, THIRD")
}

8
man/get_api_key.Rd
View file

@ -4,18 +4,14 @@
\alias{get_api_key}
\title{Retrieve project API key if stored, if not, set and retrieve}
\usage{
get_api_key(key.name, ...)
get_api_key(key.name)
}
\arguments{
\item{key.name}{character vector of key name}
\item{...}{passed to \link[keyring]{key_set}}
}
\value{
character vector
}
\description{
Attempting to make secure API key storage so simple, that no other way makes
sense. Wrapping \link[keyring]{key_get} and \link[keyring]{key_set} using the
\link[keyring]{key_list} to check if key is in storage already.
Retrieve project API key if stored, if not, set and retrieve
}

28
man/get_attr.Rd
View file

@ -1,28 +0,0 @@
% Generated by roxygen2: do not edit by hand
% Please edit documentation in R/as_factor.R
\name{get_attr}
\alias{get_attr}
\title{Extract attribute. Returns NA if none}
\usage{
get_attr(data, attr = NULL)
}
\arguments{
\item{data}{vector}
\item{attr}{attribute name}
}
\value{
character vector
}
\description{
Extract attribute. Returns NA if none
}
\examples{
attr(mtcars$mpg, "label") <- "testing"
do.call(c, sapply(mtcars, get_attr))
\dontrun{
mtcars |>
numchar2fct(numeric.threshold = 6) |>
ds2dd_detailed()
}
}

33
man/guess_time_only.Rd
View file

@ -1,33 +0,0 @@
% Generated by roxygen2: do not edit by hand
% Please edit documentation in R/ds2dd_detailed.R
\name{guess_time_only}
\alias{guess_time_only}
\title{Guess time variables based on naming pattern}
\usage{
guess_time_only(
data,
validate.time = FALSE,
time.var.sel.pos = "[Tt]i[d(me)]",
time.var.sel.neg = "[Dd]at[eo]"
)
}
\arguments{
\item{data}{data.frame or tibble}
\item{validate.time}{Flag to validate guessed time columns}
\item{time.var.sel.pos}{Positive selection regex string passed to
`gues_time_only_filter()` as sel.pos.}
\item{time.var.sel.neg}{Negative selection regex string passed to
`gues_time_only_filter()` as sel.neg.}
}
\value{
data.frame or tibble
}
\description{
This is for repairing data with time variables with appended "1970-01-01"
}
\examples{
redcapcast_data |> guess_time_only(validate.time = TRUE)
}

26
man/haven_all_levels.Rd
View file

@ -1,26 +0,0 @@
% Generated by roxygen2: do not edit by hand
% Please edit documentation in R/as_factor.R
\name{haven_all_levels}
\alias{haven_all_levels}
\title{Finish incomplete haven attributes substituting missings with values}
\usage{
haven_all_levels(data)
}
\arguments{
\item{data}{haven labelled variable}
}
\value{
named vector
}
\description{
Finish incomplete haven attributes substituting missings with values
}
\examples{
ds <- structure(c(1, 2, 3, 2, 10, 9),
labels = c(Unknown = 9, Refused = 10),
class = "haven_labelled"
)
haven::is.labelled(ds)
attributes(ds)
ds |> haven_all_levels()
}

25
man/is.labelled.Rd
View file

@ -1,25 +0,0 @@
% Generated by roxygen2: do not edit by hand
% Please edit documentation in R/as_factor.R
\name{is.labelled}
\alias{is.labelled}
\title{Tests for multiple label classes}
\usage{
is.labelled(x, classes = c("haven_labelled", "labelled"))
}
\arguments{
\item{x}{data}
\item{classes}{classes to test}
}
\value{
logical
}
\description{
Tests for multiple label classes
}
\examples{
structure(c(1, 2, 3, 2, 10, 9),
labels = c(Unknown = 9, Refused = 10),
class = "haven_labelled"
) |> is.labelled()
}

46
man/named_levels.Rd
View file

@ -1,46 +0,0 @@
% Generated by roxygen2: do not edit by hand
% Please edit documentation in R/as_factor.R
\name{named_levels}
\alias{named_levels}
\title{Get named vector of factor levels and values}
\usage{
named_levels(
data,
label = "labels",
na.label = NULL,
na.value = 99,
sort.numeric = TRUE
)
}
\arguments{
\item{data}{factor}
\item{label}{character string of attribute with named vector of factor labels}
\item{na.label}{character string to refactor NA values. Default is NULL.}
\item{na.value}{new value for NA strings. Ignored if na.label is NULL.
Default is 99.}
\item{sort.numeric}{sort factor levels if levels are numeric. Default is TRUE}
}
\value{
named vector
}
\description{
Get named vector of factor levels and values
}
\examples{
structure(c(1, 2, 3, 2, 10, 9),
labels = c(Unknown = 9, Refused = 10),
class = "haven_labelled"
) |>
as_factor() |>
named_levels()
structure(c(1, 2, 3, 2, 10, 9),
labels = c(Unknown = 9, Refused = 10),
class = "labelled"
) |>
as_factor() |>
named_levels()
}

14
man/nav_bar_page.Rd
View file

@ -1,14 +0,0 @@
% Generated by roxygen2: do not edit by hand
% Please edit documentation in R/shiny_cast.R
\name{nav_bar_page}
\alias{nav_bar_page}
\title{Nav_bar defining function for shiny ui}
\usage{
nav_bar_page()
}
\value{
shiny object
}
\description{
Nav_bar defining function for shiny ui
}

31
man/numchar2fct.Rd
View file

@ -1,31 +0,0 @@
% Generated by roxygen2: do not edit by hand
% Please edit documentation in R/ds2dd_detailed.R
\name{numchar2fct}
\alias{numchar2fct}
\title{Applying var2fct across data set}
\usage{
numchar2fct(data, numeric.threshold = 6, character.throshold = 6)
}
\arguments{
\item{data}{dataset. data.frame or tibble}
\item{numeric.threshold}{threshold for var2fct for numeric columns. Default
is 6.}
\item{character.throshold}{threshold for var2fct for character columns.
Default is 6.}
}
\value{
data.frame or tibble
}
\description{
Individual thresholds for character and numeric columns
}
\examples{
mtcars |> str()
\dontrun{
mtcars |>
numchar2fct(numeric.threshold = 6) |>
str()
}
}

39
man/parse_data.Rd
View file

@ -1,39 +0,0 @@
% Generated by roxygen2: do not edit by hand
% Please edit documentation in R/ds2dd_detailed.R
\name{parse_data}
\alias{parse_data}
\title{Helper to auto-parse un-formatted data with haven and readr}
\usage{
parse_data(
data,
guess_type = TRUE,
col_types = NULL,
locale = readr::default_locale(),
ignore.vars = "cpr",
...
)
}
\arguments{
\item{data}{data.frame or tibble}
\item{guess_type}{logical to guess type with readr}
\item{col_types}{specify col_types using readr semantics. Ignored if guess_type is TRUE}
\item{locale}{option to specify locale. Defaults to readr::default_locale().}
\item{ignore.vars}{specify column names of columns to ignore when parsing}
\item{...}{ignored}
}
\value{
data.frame or tibble
}
\description{
Helper to auto-parse un-formatted data with haven and readr
}
\examples{
mtcars |>
parse_data() |>
str()
}

23
man/possibly_numeric.Rd
View file

@ -1,23 +0,0 @@
% Generated by roxygen2: do not edit by hand
% Please edit documentation in R/as_factor.R
\name{possibly_numeric}
\alias{possibly_numeric}
\title{Tests if vector can be interpreted as numeric without introducing NAs by
coercion}
\usage{
possibly_numeric(data)
}
\arguments{
\item{data}{vector}
}
\value{
logical
}
\description{
Tests if vector can be interpreted as numeric without introducing NAs by
coercion
}
\examples{
c("1","5") |> possibly_numeric()
c("1","5","e") |> possibly_numeric()
}

24
man/possibly_roman.Rd
View file

@ -1,24 +0,0 @@
% Generated by roxygen2: do not edit by hand
% Please edit documentation in R/as_factor.R
\name{possibly_roman}
\alias{possibly_roman}
\title{Test if vector can be interpreted as roman numerals}
\usage{
possibly_roman(data)
}
\arguments{
\item{data}{character vector}
}
\value{
logical
}
\description{
Test if vector can be interpreted as roman numerals
}
\examples{
sample(1:100, 10) |>
as.roman() |>
possibly_roman()
sample(c(TRUE, FALSE), 10, TRUE) |> possibly_roman()
rep(NA, 10) |> possibly_roman()
}

27
man/read_redcap_tables.Rd
View file

@ -11,9 +11,8 @@ read_redcap_tables(
fields = NULL,
events = NULL,
forms = NULL,
raw_or_label = c("raw", "label", "both"),
split_forms = c("all", "repeating", "none"),
...
raw_or_label = "label",
split_forms = "all"
)
}
\arguments{
@ -29,32 +28,20 @@ read_redcap_tables(
\item{forms}{forms to download}
\item{raw_or_label}{raw or label tags. Can be "raw", "label" or "both".
* "raw": Standard \link[REDCapR]{redcap_read} method to get raw values.
* "label": Standard \link[REDCapR]{redcap_read} method to get label values.
* "both": Get raw values with REDCap labels applied as labels. Use
\link[REDCapCAST]{as_factor} to format factors with original labels and use
the `gtsummary` package functions like \link[gtsummary]{tbl_summary} to
easily get beautiful tables with original labels from REDCap. Use
\link[REDCapCAST]{fct_drop} to drop empty levels.}
\item{raw_or_label}{raw or label tags}
\item{split_forms}{Whether to split "repeating" or "all" forms, default is
all. Give "none" to export native semi-long REDCap format}
\item{...}{passed on to \link[REDCapR]{redcap_read}}
all.}
}
\value{
list of instruments
}
\description{
Implementation of passed on to \link[REDCapCAST]{REDCap_split} with a focused
data acquisition approach using passed on to \link[REDCapR]{redcap_read} and
only downloading specified fields, forms and/or events using the built-in
focused_metadata including some clean-up.
Implementation of REDCap_split with a focused data acquisition approach using
REDCapR::redcap_read and only downloading specified fields, forms and/or
events using the built-in focused_metadata including some clean-up.
Works with classical and longitudinal projects with or without repeating
instruments.
Will preserve metadata in the data.frames as labels.
}
\examples{
# Examples will be provided later

43
man/redcap_wider.Rd
View file

@ -2,29 +2,27 @@
% Please edit documentation in R/redcap_wider.R
\name{redcap_wider}
\alias{redcap_wider}
\title{Transforms list of REDCap data.frames to a single wide data.frame}
\title{Redcap Wider}
\usage{
redcap_wider(
data,
event.glue = "{.value}____{redcap_event_name}",
inst.glue = "{.value}____{redcap_repeat_instance}"
event.glue = "{.value}_{redcap_event_name}",
inst.glue = "{.value}_{redcap_repeat_instance}"
)
}
\arguments{
\item{data}{A list of data frames}
\item{data}{A list of data frames.}
\item{event.glue}{A \link[glue]{glue} string for repeated events naming}
\item{event.glue}{A dplyr::glue string for repeated events naming}
\item{inst.glue}{A \link[glue]{glue} string for repeated instruments naming}
\item{inst.glue}{A dplyr::glue string for repeated instruments naming}
}
\value{
data.frame in wide format
The list of data frames in wide format.
}
\description{
Converts a list of REDCap data.frames from long to wide format.
In essence it is a wrapper for the \link[tidyr]{pivot_wider} function applied
on a REDCap output (from \link[REDCapCAST]{read_redcap_tables}) or manually
split by \link[REDCapCAST]{REDCap_split}.
Converts a list of REDCap data frames from long to wide format.
Handles longitudinal projects, but not yet repeated instruments.
}
\examples{
# Longitudinal
@ -83,27 +81,4 @@ list4 <- list(
)
)
redcap_wider(list4)
list5 <- list(
data.frame(
record_id = c(1, 2, 1, 2),
redcap_event_name = c("baseline", "baseline", "followup", "followup")
),
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(list5)
}

3
man/redcapcast_data.Rd
View file

@ -19,9 +19,6 @@ A data frame with 22 variables:
\item{age_integer}{Age integer, numeric}
\item{sex}{Legal sex, character}
\item{cohabitation}{Cohabitation status, character}
\item{con_calc}{con_calc}
\item{con_mrs}{con_mrs}
\item{consensus_complete}{consensus_complete}
\item{hypertension}{Hypertension, character}
\item{diabetes}{diabetes, character}
\item{region}{region, character}

2
man/redcapcast_meta.Rd
View file

@ -31,6 +31,6 @@ A data frame with 22 variables:
data(redcapcast_meta)
}
\description{
This metadata dataset from a REDCap database is for demonstration purposes.
This metadata dataset from a REDCap database is for demonstrational purposes.
}
\keyword{datasets}

9
man/sanitize_split.Rd
View file

@ -7,20 +7,13 @@
sanitize_split(
l,
generic.names = c("redcap_event_name", "redcap_repeat_instrument",
"redcap_repeat_instance"),
drop.complete = TRUE,
drop.empty = TRUE
"redcap_repeat_instance")
)
}
\arguments{
\item{l}{A list of data frames.}
\item{generic.names}{A vector of generic names to be excluded.}
\item{drop.complete}{logical to remove generic REDCap variables indicating
instrument completion. Default is TRUE.}
\item{drop.empty}{logical to remove variables with only NAs Default is TRUE.}
}
\value{
A list of data frames with generic names excluded.

14
man/server_factory.Rd Normal file
View file

@ -0,0 +1,14 @@
% Generated by roxygen2: do not edit by hand
% Please edit documentation in R/shiny_cast.R
\name{server_factory}
\alias{server_factory}
\title{Shiny server factory}
\usage{
server_factory()
}
\value{
shiny server
}
\description{
Shiny server factory
}

23
man/set_attr.Rd
View file

@ -1,23 +0,0 @@
% Generated by roxygen2: do not edit by hand
% Please edit documentation in R/as_factor.R
\name{set_attr}
\alias{set_attr}
\title{Set attributes for named attribute. Appends if attr is NULL}
\usage{
set_attr(data, label, attr = NULL, overwrite = FALSE)
}
\arguments{
\item{data}{vector}
\item{label}{label}
\item{attr}{attribute name}
\item{overwrite}{overwrite existing attributes. Default is FALSE.}
}
\value{
vector with attribute
}
\description{
Set attributes for named attribute. Appends if attr is NULL
}

7
man/shiny_cast.Rd
View file

@ -4,16 +4,13 @@
\alias{shiny_cast}
\title{Launch the included Shiny-app for database casting and upload}
\usage{
shiny_cast(...)
}
\arguments{
\item{...}{Arguments passed to shiny::runApp()}
shiny_cast()
}
\value{
shiny app
}
\description{
Wraps shiny::runApp()
Launch the included Shiny-app for database casting and upload
}
\examples{
# shiny_cast()

29
man/suffix2label.Rd
View file

@ -1,29 +0,0 @@
% Generated by roxygen2: do not edit by hand
% Please edit documentation in R/redcap_wider.R
\name{suffix2label}
\alias{suffix2label}
\title{Transfer variable name suffix to label in widened data}
\usage{
suffix2label(
data,
suffix.sep = "____",
attr = "label",
glue.str = "{label} ({paste(suffixes,collapse=', ')})"
)
}
\arguments{
\item{data}{data.frame}
\item{suffix.sep}{string to split suffix(es). Passed to \link[base]{strsplit}}
\item{attr}{label attribute. Default is "label"}
\item{glue.str}{glue string for new label. Available variables are "label"
and "suffixes"}
}
\value{
data.frame
}
\description{
Transfer variable name suffix to label in widened data
}

14
man/ui_factory.Rd Normal file
View file

@ -0,0 +1,14 @@
% Generated by roxygen2: do not edit by hand
% Please edit documentation in R/shiny_cast.R
\name{ui_factory}
\alias{ui_factory}
\title{UI factory for shiny app}
\usage{
ui_factory()
}
\value{
shiny ui
}
\description{
UI factory for shiny app
}

29
man/var2fct.Rd
View file

@ -1,29 +0,0 @@
% Generated by roxygen2: do not edit by hand
% Please edit documentation in R/ds2dd_detailed.R
\name{var2fct}
\alias{var2fct}
\title{Convert vector to factor based on threshold of number of unique levels}
\usage{
var2fct(data, unique.n)
}
\arguments{
\item{data}{vector or data.frame column}
\item{unique.n}{threshold to convert class to factor}
}
\value{
vector
}
\description{
This is a wrapper of forcats::as_factor, which sorts numeric vectors before
factoring, but levels character vectors in order of appearance.
}
\examples{
sample(seq_len(4), 20, TRUE) |>
var2fct(6) |>
summary()
sample(letters, 20) |>
var2fct(6) |>
summary()
sample(letters[1:4], 20, TRUE) |> var2fct(6)
}

24
man/vec2choice.Rd
View file

@ -1,24 +0,0 @@
% Generated by roxygen2: do not edit by hand
% Please edit documentation in R/ds2dd_detailed.R
\name{vec2choice}
\alias{vec2choice}
\title{Named vector to REDCap choices (`wrapping compact_vec()`)}
\usage{
vec2choice(data)
}
\arguments{
\item{data}{named vector}
}
\value{
character string
}
\description{
Named vector to REDCap choices (`wrapping compact_vec()`)
}
\examples{
sample(seq_len(4), 20, TRUE) |>
as_factor() |>
named_levels() |>
sort() |>
vec2choice()
}

535
renv.lock
View file

@ -1,10 +1,10 @@
{
"R": {
"Version": "4.4.1",
"Version": "4.4.0",
"Repositories": [
{
"Name": "CRAN",
"URL": "https://mirrors.dotsrc.org/cran"
"URL": "https://cloud.r-project.org"
}
]
},
@ -19,19 +19,9 @@
],
"Hash": "470851b6d5d0ac559e9d01bb352b4021"
},
"RColorBrewer": {
"Package": "RColorBrewer",
"Version": "1.1-3",
"Source": "Repository",
"Repository": "CRAN",
"Requirements": [
"R"
],
"Hash": "45f0398006e83a5b10b72a90663d8d8c"
},
"REDCapR": {
"Package": "REDCapR",
"Version": "1.3.0",
"Version": "1.1.0",
"Source": "Repository",
"Repository": "CRAN",
"Requirements": [
@ -47,41 +37,28 @@
"tibble",
"tidyr"
],
"Hash": "de630e9e6168aae0a178eaa3198dbe54"
"Hash": "e76c401b631961c865b89bb5a4ea3b97"
},
"Rcpp": {
"Package": "Rcpp",
"Version": "1.0.13-1",
"Version": "1.0.12",
"Source": "Repository",
"Repository": "CRAN",
"Requirements": [
"methods",
"utils"
],
"Hash": "6b868847b365672d6c1677b1608da9ed"
},
"V8": {
"Package": "V8",
"Version": "6.0.0",
"Source": "Repository",
"Repository": "CRAN",
"Requirements": [
"Rcpp",
"curl",
"jsonlite",
"utils"
],
"Hash": "6603bfcbc7883a5fed41fb13042a3899"
"Hash": "5ea2700d21e038ace58269ecdbeb9ec0"
},
"askpass": {
"Package": "askpass",
"Version": "1.2.1",
"Version": "1.2.0",
"Source": "Repository",
"Repository": "CRAN",
"Requirements": [
"sys"
],
"Hash": "c39f4155b3ceb1a9a2799d700fbd4b6a"
"Hash": "cad6cf7f1d5f6e906700b9d3e718c796"
},
"assertthat": {
"Package": "assertthat",
@ -95,13 +72,13 @@
},
"backports": {
"Package": "backports",
"Version": "1.5.0",
"Version": "1.4.1",
"Source": "Repository",
"Repository": "CRAN",
"Requirements": [
"R"
],
"Hash": "e1e1b9d75c37401117b636b7ae50827a"
"Hash": "c39fbec8a30d23e721980b8afb31984c"
},
"base64enc": {
"Package": "base64enc",
@ -113,29 +90,19 @@
],
"Hash": "543776ae6848fde2f48ff3816d0628bc"
},
"bigD": {
"Package": "bigD",
"Version": "0.3.0",
"Source": "Repository",
"Repository": "CRAN",
"Requirements": [
"R"
],
"Hash": "78dfe2b21e523358871eea1601b04b56"
},
"bit": {
"Package": "bit",
"Version": "4.5.0",
"Version": "4.0.5",
"Source": "Repository",
"Repository": "CRAN",
"Requirements": [
"R"
],
"Hash": "5dc7b2677d65d0e874fc4aaf0e879987"
"Hash": "d242abec29412ce988848d0294b208fd"
},
"bit64": {
"Package": "bit64",
"Version": "4.5.2",
"Version": "4.0.5",
"Source": "Repository",
"Repository": "CRAN",
"Requirements": [
@ -145,18 +112,11 @@
"stats",
"utils"
],
"Hash": "e84984bf5f12a18628d9a02322128dfd"
},
"bitops": {
"Package": "bitops",
"Version": "1.0-9",
"Source": "Repository",
"Repository": "CRAN",
"Hash": "d972ef991d58c19e6efa71b21f5e144b"
"Hash": "9fe98599ca456d6552421db0d6772d8f"
},
"bslib": {
"Package": "bslib",
"Version": "0.8.0",
"Version": "0.7.0",
"Source": "Repository",
"Repository": "CRAN",
"Requirements": [
@ -174,7 +134,7 @@
"rlang",
"sass"
],
"Hash": "b299c6741ca9746fb227debcb0f9fb6c"
"Hash": "8644cc53f43828f19133548195d7e59e"
},
"cachem": {
"Package": "cachem",
@ -187,22 +147,6 @@
],
"Hash": "cd9a672193789068eb5a2aad65a0dedf"
},
"cards": {
"Package": "cards",
"Version": "0.4.0",
"Source": "Repository",
"Repository": "CRAN",
"Requirements": [
"R",
"cli",
"dplyr",
"glue",
"rlang",
"tidyr",
"tidyselect"
],
"Hash": "2cd0d1966092de416f9b7fa1e88b6132"
},
"cellranger": {
"Package": "cellranger",
"Version": "1.1.0",
@ -217,26 +161,26 @@
},
"checkmate": {
"Package": "checkmate",
"Version": "2.3.2",
"Version": "2.3.1",
"Source": "Repository",
"Repository": "CRAN",
"Repository": "RSPM",
"Requirements": [
"R",
"backports",
"utils"
],
"Hash": "0e14e01ce07e7c88fd25de6d4260d26b"
"Hash": "c01cab1cb0f9125211a6fc99d540e315"
},
"cli": {
"Package": "cli",
"Version": "3.6.3",
"Version": "3.6.2",
"Source": "Repository",
"Repository": "CRAN",
"Repository": "RSPM",
"Requirements": [
"R",
"utils"
],
"Hash": "b21916dd77a27642b447374a5d30ecf3"
"Hash": "1216ac65ac55ec0058a6f75d7ca0fd52"
},
"clipr": {
"Package": "clipr",
@ -248,40 +192,16 @@
],
"Hash": "3f038e5ac7f41d4ac41ce658c85e3042"
},
"colorspace": {
"Package": "colorspace",
"Version": "2.1-1",
"Source": "Repository",
"Repository": "CRAN",
"Requirements": [
"R",
"grDevices",
"graphics",
"methods",
"stats"
],
"Hash": "d954cb1c57e8d8b756165d7ba18aa55a"
},
"commonmark": {
"Package": "commonmark",
"Version": "1.9.2",
"Version": "1.9.1",
"Source": "Repository",
"Repository": "CRAN",
"Hash": "14eb0596f987c71535d07c3aff814742"
},
"cpp11": {
"Package": "cpp11",
"Version": "0.5.0",
"Source": "Repository",
"Repository": "CRAN",
"Requirements": [
"R"
],
"Hash": "91570bba75d0c9d3f1040c835cee8fba"
"Hash": "5d8225445acb167abf7797de48b2ee3c"
},
"crayon": {
"Package": "crayon",
"Version": "1.5.3",
"Version": "1.5.2",
"Source": "Repository",
"Repository": "CRAN",
"Requirements": [
@ -289,28 +209,28 @@
"methods",
"utils"
],
"Hash": "859d96e65ef198fd43e82b9628d593ef"
"Hash": "e8a1e41acf02548751f45c718d55aa6a"
},
"curl": {
"Package": "curl",
"Version": "6.0.1",
"Version": "5.2.1",
"Source": "Repository",
"Repository": "CRAN",
"Requirements": [
"R"
],
"Hash": "e8ba62486230951fcd2b881c5be23f96"
"Hash": "411ca2c03b1ce5f548345d2fc2685f7a"
},
"digest": {
"Package": "digest",
"Version": "0.6.37",
"Version": "0.6.35",
"Source": "Repository",
"Repository": "CRAN",
"Requirements": [
"R",
"utils"
],
"Hash": "33698c4b3127fc9f506654607fb73676"
"Hash": "698ece7ba5a4fa4559e3d537e7ec3d31"
},
"dplyr": {
"Package": "dplyr",
@ -335,16 +255,6 @@
],
"Hash": "fedd9d00c2944ff00a0e2696ccf048ec"
},
"evaluate": {
"Package": "evaluate",
"Version": "1.0.1",
"Source": "Repository",
"Repository": "CRAN",
"Requirements": [
"R"
],
"Hash": "3fd29944b231036ad67c3edb32e02201"
},
"fansi": {
"Package": "fansi",
"Version": "1.0.6",
@ -357,13 +267,6 @@
],
"Hash": "962174cf2aeb5b9eea581522286a911f"
},
"farver": {
"Package": "farver",
"Version": "2.1.2",
"Source": "Repository",
"Repository": "CRAN",
"Hash": "680887028577f3fa2a81e410ed0d6e42"
},
"fastmap": {
"Package": "fastmap",
"Version": "1.2.0",
@ -383,7 +286,7 @@
},
"fontawesome": {
"Package": "fontawesome",
"Version": "0.5.3",
"Version": "0.5.2",
"Source": "Repository",
"Repository": "CRAN",
"Requirements": [
@ -391,7 +294,7 @@
"htmltools",
"rlang"
],
"Hash": "bd1297f9b5b1fc1372d19e2c4cd82215"
"Hash": "c2efdd5f0bcd1ea861c2d4e2a883a67d"
},
"forcats": {
"Package": "forcats",
@ -411,14 +314,14 @@
},
"fs": {
"Package": "fs",
"Version": "1.6.5",
"Version": "1.6.4",
"Source": "Repository",
"Repository": "CRAN",
"Requirements": [
"R",
"methods"
],
"Hash": "7f48af39fa27711ea5fbd183b399920d"
"Hash": "15aeb8c27f5ea5161f9f6a641fafd93a"
},
"generics": {
"Package": "generics",
@ -433,69 +336,20 @@
},
"glue": {
"Package": "glue",
"Version": "1.8.0",
"Version": "1.7.0",
"Source": "Repository",
"Repository": "CRAN",
"Repository": "RSPM",
"Requirements": [
"R",
"methods"
],
"Hash": "5899f1eaa825580172bb56c08266f37c"
},
"gt": {
"Package": "gt",
"Version": "0.11.1",
"Source": "Repository",
"Repository": "CRAN",
"Requirements": [
"R",
"base64enc",
"bigD",
"bitops",
"cli",
"commonmark",
"dplyr",
"fs",
"glue",
"htmltools",
"htmlwidgets",
"juicyjuice",
"magrittr",
"markdown",
"reactable",
"rlang",
"sass",
"scales",
"tidyselect",
"vctrs",
"xml2"
],
"Hash": "3170d1f0f45e531c241179ab57cd30bd"
},
"gtsummary": {
"Package": "gtsummary",
"Version": "2.0.3",
"Source": "Repository",
"Repository": "CRAN",
"Requirements": [
"R",
"cards",
"cli",
"dplyr",
"glue",
"gt",
"lifecycle",
"rlang",
"tidyr",
"vctrs"
],
"Hash": "cd4d593e8ce0ad4e5c2c0acc50ce7330"
"Hash": "e0b3a53876554bd45879e596cdb10a52"
},
"haven": {
"Package": "haven",
"Version": "2.5.4",
"Source": "Repository",
"Repository": "CRAN",
"Repository": "RSPM",
"Requirements": [
"R",
"cli",
@ -512,27 +366,6 @@
],
"Hash": "9171f898db9d9c4c1b2c745adc2c1ef1"
},
"here": {
"Package": "here",
"Version": "1.0.1",
"Source": "Repository",
"Repository": "CRAN",
"Requirements": [
"rprojroot"
],
"Hash": "24b224366f9c2e7534d2344d10d59211"
},
"highr": {
"Package": "highr",
"Version": "0.11",
"Source": "Repository",
"Repository": "CRAN",
"Requirements": [
"R",
"xfun"
],
"Hash": "d65ba49117ca223614f71b60d85b8ab7"
},
"hms": {
"Package": "hms",
"Version": "1.1.3",
@ -563,21 +396,6 @@
],
"Hash": "81d371a9cc60640e74e4ab6ac46dcedc"
},
"htmlwidgets": {
"Package": "htmlwidgets",
"Version": "1.6.4",
"Source": "Repository",
"Repository": "CRAN",
"Requirements": [
"grDevices",
"htmltools",
"jsonlite",
"knitr",
"rmarkdown",
"yaml"
],
"Hash": "04291cc45198225444a397606810ac37"
},
"httpuv": {
"Package": "httpuv",
"Version": "1.6.15",
@ -620,23 +438,13 @@
},
"jsonlite": {
"Package": "jsonlite",
"Version": "1.8.9",
"Version": "1.8.8",
"Source": "Repository",
"Repository": "CRAN",
"Repository": "RSPM",
"Requirements": [
"methods"
],
"Hash": "4e993b65c2c3ffbffce7bb3e2c6f832b"
},
"juicyjuice": {
"Package": "juicyjuice",
"Version": "0.1.0",
"Source": "Repository",
"Repository": "CRAN",
"Requirements": [
"V8"
],
"Hash": "3bcd11943da509341838da9399e18bce"
"Hash": "e1b9c55281c5adc4dd113652d9e26768"
},
"keyring": {
"Package": "keyring",
@ -658,33 +466,6 @@
],
"Hash": "5cd8cfb2e90c57110b7dd1785c599aba"
},
"knitr": {
"Package": "knitr",
"Version": "1.49",
"Source": "Repository",
"Repository": "CRAN",
"Requirements": [
"R",
"evaluate",
"highr",
"methods",
"tools",
"xfun",
"yaml"
],
"Hash": "9fcb189926d93c636dea94fbe4f44480"
},
"labeling": {
"Package": "labeling",
"Version": "0.4.3",
"Source": "Repository",
"Repository": "CRAN",
"Requirements": [
"graphics",
"stats"
],
"Hash": "b64ec208ac5bc1852b285f665d6368b3"
},
"later": {
"Package": "later",
"Version": "1.3.2",
@ -700,7 +481,7 @@
"Package": "lifecycle",
"Version": "1.0.4",
"Source": "Repository",
"Repository": "CRAN",
"Repository": "RSPM",
"Requirements": [
"R",
"cli",
@ -719,19 +500,6 @@
],
"Hash": "7ce2733a9826b3aeb1775d56fd305472"
},
"markdown": {
"Package": "markdown",
"Version": "1.13",
"Source": "Repository",
"Repository": "CRAN",
"Requirements": [
"R",
"commonmark",
"utils",
"xfun"
],
"Hash": "074efab766a9d6360865ad39512f2a7e"
},
"memoise": {
"Package": "memoise",
"Version": "2.0.1",
@ -753,42 +521,19 @@
],
"Hash": "18e9c28c1d3ca1560ce30658b22ce104"
},
"minty": {
"Package": "minty",
"Version": "0.0.4",
"Source": "Repository",
"Repository": "CRAN",
"Requirements": [
"R",
"cpp11",
"tzdb"
],
"Hash": "ab9d0930bfa21e98aec9d07f0c43cc89"
},
"munsell": {
"Package": "munsell",
"Version": "0.5.1",
"Source": "Repository",
"Repository": "CRAN",
"Requirements": [
"colorspace",
"methods"
],
"Hash": "4fd8900853b746af55b81fda99da7695"
},
"openssl": {
"Package": "openssl",
"Version": "2.2.2",
"Version": "2.2.0",
"Source": "Repository",
"Repository": "CRAN",
"Requirements": [
"askpass"
],
"Hash": "d413e0fef796c9401a4419485f709ca1"
"Hash": "2bcca3848e4734eb3b16103bc9aa4b8e"
},
"openxlsx2": {
"Package": "openxlsx2",
"Version": "1.11",
"Version": "1.6",
"Source": "Repository",
"Repository": "CRAN",
"Requirements": [
@ -801,7 +546,7 @@
"utils",
"zip"
],
"Hash": "c519244e5080a630292e1fdc36717f0d"
"Hash": "6122f5f24dfa643c1ef69bcbb130da85"
},
"pillar": {
"Package": "pillar",
@ -830,30 +575,6 @@
],
"Hash": "01f28d4278f15c76cddbea05899c5d6f"
},
"prettyunits": {
"Package": "prettyunits",
"Version": "1.2.0",
"Source": "Repository",
"Repository": "CRAN",
"Requirements": [
"R"
],
"Hash": "6b01fc98b1e86c4f705ce9dcfd2f57c7"
},
"progress": {
"Package": "progress",
"Version": "1.2.3",
"Source": "Repository",
"Repository": "CRAN",
"Requirements": [
"R",
"R6",
"crayon",
"hms",
"prettyunits"
],
"Hash": "f4625e061cb2865f111b47ff163a5ca6"
},
"promises": {
"Package": "promises",
"Version": "1.3.0",
@ -895,48 +616,23 @@
],
"Hash": "5e3c5dc0b071b21fa128676560dbe94d"
},
"reactR": {
"Package": "reactR",
"Version": "0.6.1",
"Source": "Repository",
"Repository": "CRAN",
"Requirements": [
"htmltools"
],
"Hash": "b8e3d93f508045812f47136c7c44c251"
},
"reactable": {
"Package": "reactable",
"Version": "0.4.4",
"Source": "Repository",
"Repository": "CRAN",
"Requirements": [
"R",
"digest",
"htmltools",
"htmlwidgets",
"jsonlite",
"reactR"
],
"Hash": "6069eb2a6597963eae0605c1875ff14c"
},
"readODS": {
"Package": "readODS",
"Version": "2.3.1",
"Version": "2.2.0",
"Source": "Repository",
"Repository": "CRAN",
"Requirements": [
"R",
"cellranger",
"cpp11",
"minty",
"readr",
"stringi",
"tibble",
"tools",
"vctrs",
"zip"
],
"Hash": "d81971565325ed8cbe59993ed5c0e611"
"Hash": "79c0f23a27909659c1a2d62048c15096"
},
"readr": {
"Package": "readr",
@ -970,57 +666,24 @@
},
"renv": {
"Package": "renv",
"Version": "1.0.11",
"Version": "1.0.7",
"Source": "Repository",
"Repository": "CRAN",
"Requirements": [
"utils"
],
"Hash": "47623f66b4e80b3b0587bc5d7b309888"
"Hash": "397b7b2a265bc5a7a06852524dabae20"
},
"rlang": {
"Package": "rlang",
"Version": "1.1.4",
"Version": "1.1.3",
"Source": "Repository",
"Repository": "CRAN",
"Repository": "RSPM",
"Requirements": [
"R",
"utils"
],
"Hash": "3eec01f8b1dee337674b2e34ab1f9bc1"
},
"rmarkdown": {
"Package": "rmarkdown",
"Version": "2.29",
"Source": "Repository",
"Repository": "CRAN",
"Requirements": [
"R",
"bslib",
"evaluate",
"fontawesome",
"htmltools",
"jquerylib",
"jsonlite",
"knitr",
"methods",
"tinytex",
"tools",
"utils",
"xfun",
"yaml"
],
"Hash": "df99277f63d01c34e95e3d2f06a79736"
},
"rprojroot": {
"Package": "rprojroot",
"Version": "2.0.4",
"Source": "Repository",
"Repository": "CRAN",
"Requirements": [
"R"
],
"Hash": "4c8415e0ec1e29f3f4f6fc108bef0144"
"Hash": "42548638fae05fd9a9b5f3f437fbbbe2"
},
"sass": {
"Package": "sass",
@ -1036,29 +699,9 @@
],
"Hash": "d53dbfddf695303ea4ad66f86e99b95d"
},
"scales": {
"Package": "scales",
"Version": "1.3.0",
"Source": "Repository",
"Repository": "CRAN",
"Requirements": [
"R",
"R6",
"RColorBrewer",
"cli",
"farver",
"glue",
"labeling",
"lifecycle",
"munsell",
"rlang",
"viridisLite"
],
"Hash": "c19df082ba346b0ffa6f833e92de34d1"
},
"shiny": {
"Package": "shiny",
"Version": "1.9.1",
"Version": "1.8.1.1",
"Source": "Repository",
"Repository": "CRAN",
"Requirements": [
@ -1087,20 +730,20 @@
"withr",
"xtable"
],
"Hash": "6a293995a66e12c48d13aa1f957d09c7"
"Hash": "54b26646816af9960a4c64d8ceec75d6"
},
"sodium": {
"Package": "sodium",
"Version": "1.3.2",
"Version": "1.3.1",
"Source": "Repository",
"Repository": "CRAN",
"Hash": "869b09ca565ecaa9efc62534ebfa3efd"
"Hash": "dd86d6fd2a01d4eb3777dfdee7076d56"
},
"sourcetools": {
"Package": "sourcetools",
"Version": "0.1.7-1",
"Source": "Repository",
"Repository": "CRAN",
"Repository": "RSPM",
"Requirements": [
"R"
],
@ -1138,10 +781,10 @@
},
"sys": {
"Package": "sys",
"Version": "3.4.3",
"Version": "3.4.2",
"Source": "Repository",
"Repository": "CRAN",
"Hash": "de342ebfebdbf40477d0758d05426646"
"Hash": "3a1be13d68d47a8cd0bfd74739ca1555"
},
"tibble": {
"Package": "tibble",
@ -1201,16 +844,6 @@
],
"Hash": "829f27b9c4919c16b593794a6344d6c0"
},
"tinytex": {
"Package": "tinytex",
"Version": "0.54",
"Source": "Repository",
"Repository": "CRAN",
"Requirements": [
"xfun"
],
"Hash": "3ec7e3ddcacc2d34a9046941222bf94d"
},
"tzdb": {
"Package": "tzdb",
"Version": "0.4.0",
@ -1246,16 +879,6 @@
],
"Hash": "c03fa420630029418f7e6da3667aac4a"
},
"viridisLite": {
"Package": "viridisLite",
"Version": "0.4.2",
"Source": "Repository",
"Repository": "CRAN",
"Requirements": [
"R"
],
"Hash": "c826c7c4241b6fc89ff55aaea3fa7491"
},
"vroom": {
"Package": "vroom",
"Version": "1.6.5",
@ -1284,7 +907,7 @@
},
"withr": {
"Package": "withr",
"Version": "3.0.2",
"Version": "3.0.0",
"Source": "Repository",
"Repository": "CRAN",
"Requirements": [
@ -1292,33 +915,7 @@
"grDevices",
"graphics"
],
"Hash": "cc2d62c76458d425210d1eb1478b30b4"
},
"xfun": {
"Package": "xfun",
"Version": "0.49",
"Source": "Repository",
"Repository": "CRAN",
"Requirements": [
"R",
"grDevices",
"stats",
"tools"
],
"Hash": "8687398773806cfff9401a2feca96298"
},
"xml2": {
"Package": "xml2",
"Version": "1.3.6",
"Source": "Repository",
"Repository": "CRAN",
"Requirements": [
"R",
"cli",
"methods",
"rlang"
],
"Hash": "1d0336142f4cd25d8d23cd3ba7a8fb61"
"Hash": "d31b6c62c10dcf11ec530ca6b0dd5d35"
},
"xtable": {
"Package": "xtable",
@ -1334,16 +931,16 @@
},
"yaml": {
"Package": "yaml",
"Version": "2.3.10",
"Version": "2.3.8",
"Source": "Repository",
"Repository": "CRAN",
"Hash": "51dab85c6c98e50a18d7551e9d49f76c"
"Hash": "29240487a071f535f5e5d5a323b7afbd"
},
"zip": {
"Package": "zip",
"Version": "2.3.1",
"Source": "Repository",
"Repository": "CRAN",
"Repository": "RSPM",
"Hash": "fcc4bd8e6da2d2011eb64a5e5cc685ab"
}
}

105
renv/activate.R
View file

@ -2,7 +2,7 @@
local({
# the requested version of renv
version <- "1.0.11"
version <- "1.0.7"
attr(version, "sha") <- NULL
# the project directory
@ -98,66 +98,6 @@ local({
unloadNamespace("renv")
# load bootstrap tools
ansify <- function(text) {
if (renv_ansify_enabled())
renv_ansify_enhanced(text)
else
renv_ansify_default(text)
}
renv_ansify_enabled <- function() {
override <- Sys.getenv("RENV_ANSIFY_ENABLED", unset = NA)
if (!is.na(override))
return(as.logical(override))
pane <- Sys.getenv("RSTUDIO_CHILD_PROCESS_PANE", unset = NA)
if (identical(pane, "build"))
return(FALSE)
testthat <- Sys.getenv("TESTTHAT", unset = "false")
if (tolower(testthat) %in% "true")
return(FALSE)
iderun <- Sys.getenv("R_CLI_HAS_HYPERLINK_IDE_RUN", unset = "false")
if (tolower(iderun) %in% "false")
return(FALSE)
TRUE
}
renv_ansify_default <- function(text) {
text
}
renv_ansify_enhanced <- function(text) {
# R help links
pattern <- "`\\?(renv::(?:[^`])+)`"
replacement <- "`\033]8;;ide:help:\\1\a?\\1\033]8;;\a`"
text <- gsub(pattern, replacement, text, perl = TRUE)
# runnable code
pattern <- "`(renv::(?:[^`])+)`"
replacement <- "`\033]8;;ide:run:\\1\a\\1\033]8;;\a`"
text <- gsub(pattern, replacement, text, perl = TRUE)
# return ansified text
text
}
renv_ansify_init <- function() {
envir <- renv_envir_self()
if (renv_ansify_enabled())
assign("ansify", renv_ansify_enhanced, envir = envir)
else
assign("ansify", renv_ansify_default, envir = envir)
}
`%||%` <- function(x, y) {
if (is.null(x)) y else x
}
@ -202,10 +142,7 @@ local({
# compute common indent
indent <- regexpr("[^[:space:]]", lines)
common <- min(setdiff(indent, -1L)) - leave
text <- paste(substring(lines, common), collapse = "\n")
# substitute in ANSI links for executable renv code
ansify(text)
paste(substring(lines, common), collapse = "\n")
}
@ -368,11 +305,8 @@ local({
quiet = TRUE
)
if ("headers" %in% names(formals(utils::download.file))) {
headers <- renv_bootstrap_download_custom_headers(url)
if (length(headers) && is.character(headers))
args$headers <- headers
}
if ("headers" %in% names(formals(utils::download.file)))
args$headers <- renv_bootstrap_download_custom_headers(url)
do.call(utils::download.file, args)
@ -451,21 +385,10 @@ local({
for (type in types) {
for (repos in renv_bootstrap_repos()) {
# build arguments for utils::available.packages() call
args <- list(type = type, repos = repos)
# add custom headers if available -- note that
# utils::available.packages() will pass this to download.file()
if ("headers" %in% names(formals(utils::download.file))) {
headers <- renv_bootstrap_download_custom_headers(repos)
if (length(headers) && is.character(headers))
args$headers <- headers
}
# retrieve package database
db <- tryCatch(
as.data.frame(
do.call(utils::available.packages, args),
utils::available.packages(type = type, repos = repos),
stringsAsFactors = FALSE
),
error = identity
@ -547,14 +470,6 @@ local({
}
renv_bootstrap_github_token <- function() {
for (envvar in c("GITHUB_TOKEN", "GITHUB_PAT", "GH_TOKEN")) {
envval <- Sys.getenv(envvar, unset = NA)
if (!is.na(envval))
return(envval)
}
}
renv_bootstrap_download_github <- function(version) {
enabled <- Sys.getenv("RENV_BOOTSTRAP_FROM_GITHUB", unset = "TRUE")
@ -562,16 +477,16 @@ local({
return(FALSE)
# prepare download options
token <- renv_bootstrap_github_token()
if (nzchar(Sys.which("curl")) && nzchar(token)) {
pat <- Sys.getenv("GITHUB_PAT")
if (nzchar(Sys.which("curl")) && nzchar(pat)) {
fmt <- "--location --fail --header \"Authorization: token %s\""
extra <- sprintf(fmt, token)
extra <- sprintf(fmt, pat)
saved <- options("download.file.method", "download.file.extra")
options(download.file.method = "curl", download.file.extra = extra)
on.exit(do.call(base::options, saved), add = TRUE)
} else if (nzchar(Sys.which("wget")) && nzchar(token)) {
} else if (nzchar(Sys.which("wget")) && nzchar(pat)) {
fmt <- "--header=\"Authorization: token %s\""
extra <- sprintf(fmt, token)
extra <- sprintf(fmt, pat)
saved <- options("download.file.method", "download.file.extra")
options(download.file.method = "wget", download.file.extra = extra)
on.exit(do.call(base::options, saved), add = TRUE)

3
tests/spelling.R Normal file
View file

@ -0,0 +1,3 @@
if(requireNamespace('spelling', quietly = TRUE))
spelling::spell_check_test(vignettes = TRUE, error = FALSE,
skip_on_cran = TRUE)

25
tests/spelling.Rout.save Normal file
View file

@ -0,0 +1,25 @@
R version 3.4.1 (2017-06-30) -- "Single Candle"
Copyright (C) 2017 The R Foundation for Statistical Computing
Platform: x86_64-apple-darwin15.6.0 (64-bit)
R is free software and comes with ABSOLUTELY NO WARRANTY.
You are welcome to redistribute it under certain conditions.
Type 'license()' or 'licence()' for distribution details.
R is a collaborative project with many contributors.
Type 'contributors()' for more information and
'citation()' on how to cite R or R packages in publications.
Type 'demo()' for some demos, 'help()' for on-line help, or
'help.start()' for an HTML browser interface to help.
Type 'q()' to quit R.
> if(requireNamespace('spelling', quietly = TRUE))
+ spelling::spell_check_test(vignettes = TRUE, error = FALSE,
+ skip_on_cran = TRUE)
All Done!
>
> proc.time()
user system elapsed
0.372 0.039 0.408

168
tests/testthat/test-API.R
View file

@ -1,3 +1,5 @@
# Check the RCurl export ---------------------------------------------------
test_that("JSON character vector from RCurl matches reference", {
metadata <-
@ -8,168 +10,6 @@ test_that("JSON character vector from RCurl matches reference", {
redcap_output_json1 <- REDCap_split(records, metadata)
# expect_known_hash(redcap_output_json1, "2c8b6531597182af1248f92124161e0c")
# dput(redcap_output_json1)
expect_identical(
redcap_output_json1,
list(structure(list(
row = c(
"AMC Javelin", "Cadillac Fleetwood",
"Camaro Z28", "Chrysler Imperial", "Datsun 710", "Dodge Challenger",
"Duster 360", "Ferrari Dino", "Fiat 128", "Fiat X1-9", "Ford Pantera L",
"Honda Civic", "Hornet 4 Drive", "Hornet Sportabout", "Lincoln Continental",
"Lotus Europa", "Maserati Bora", "Mazda RX4", "Mazda RX4 Wag",
"Merc 230", "Merc 240D", "Merc 280", "Merc 280C", "Merc 450SE",
"Merc 450SL", "Merc 450SLC", "Pontiac Firebird", "Porsche 914-2",
"Toyota Corolla", "Toyota Corona", "Valiant", "Volvo 142E"
),
mpg = c(
"15.2", "10.4", "13.3", "14.7", "22.8", "15.5", "14.3",
"19.7", "32.4", "27.3", "15.8", "30.4", "21.4", "18.7", "10.4",
"30.4", "15", "21", "21", "22.8", "24.4", "19.2", "17.8",
"16.4", "17.3", "15.2", "19.2", "26", "33.9", "21.5", "18.1",
"21.4"
), cyl = c(
"8", "8", "8", "8", "4", "8", "8", "6",
"4", "4", "8", "4", "6", "8", "8", "4", "8", "6", "6", "4",
"4", "6", "6", "8", "8", "8", "8", "4", "4", "4", "6", "4"
), disp = c(
"304", "472", "350", "440", "108", "318", "360",
"145", "78.7", "79", "351", "75.7", "258", "360", "460",
"95.1", "301", "160", "160", "140.8", "146.7", "167.6", "167.6",
"275.8", "275.8", "275.8", "400", "120.3", "71.1", "120.1",
"225", "121"
), hp = c(
"150", "205", "245", "230", "93", "150",
"245", "175", "66", "66", "264", "52", "110", "175", "215",
"113", "335", "110", "110", "95", "62", "123", "123", "180",
"180", "180", "175", "91", "65", "97", "105", "109"
), drat = c(
"3.15",
"2.93", "3.73", "3.23", "3.85", "2.76", "3.21", "3.62", "4.08",
"4.08", "4.22", "4.93", "3.08", "3.15", "3", "3.77", "3.54",
"3.9", "3.9", "3.92", "3.69", "3.92", "3.92", "3.07", "3.07",
"3.07", "3.08", "4.43", "4.22", "3.7", "2.76", "4.11"
), wt = c(
"3.435",
"5.25", "3.84", "5.345", "2.32", "3.52", "3.57", "2.77",
"2.2", "1.935", "3.17", "1.615", "3.215", "3.44", "5.424",
"1.513", "3.57", "2.62", "2.875", "3.15", "3.19", "3.44",
"3.44", "4.07", "3.73", "3.78", "3.845", "2.14", "1.835",
"2.465", "3.46", "2.78"
), qsec = c(
"17.3", "17.98", "15.41",
"17.42", "18.61", "16.87", "15.84", "15.5", "19.47", "18.9",
"14.5", "18.52", "19.44", "17.02", "17.82", "16.9", "14.6",
"16.46", "17.02", "22.9", "20", "18.3", "18.9", "17.4", "17.6",
"18", "17.05", "16.7", "19.9", "20.01", "20.22", "18.6"
),
vs = c(
"0", "0", "0", "0", "1", "0", "0", "0", "1", "1",
"0", "1", "1", "0", "0", "1", "0", "0", "0", "1", "1", "1",
"1", "0", "0", "0", "0", "0", "1", "1", "1", "1"
), am = c(
"0",
"0", "0", "0", "1", "0", "0", "1", "1", "1", "1", "1", "0",
"0", "0", "1", "1", "1", "1", "0", "0", "0", "0", "0", "0",
"0", "0", "1", "1", "0", "0", "1"
), gear = c(
"3", "3", "3",
"3", "4", "3", "3", "5", "4", "4", "5", "4", "3", "3", "3",
"5", "5", "4", "4", "4", "4", "4", "4", "3", "3", "3", "3",
"5", "4", "3", "3", "4"
), carb = c(
"2", "4", "4", "4", "1",
"2", "4", "6", "1", "1", "4", "2", "1", "2", "4", "2", "8",
"4", "4", "2", "2", "4", "4", "3", "3", "3", "2", "2", "1",
"1", "1", "2"
), color_available___red = c(
"1", "0", "0",
"0", "0", "0", "0", "0", "0", "0", "0", "0", "0", "0", "0",
"0", "0", "0", "0", "0", "0", "0", "0", "0", "0", "0", "0",
"0", "0", "0", "0", "0"
), color_available___green = c(
"1",
"0", "0", "0", "0", "0", "0", "0", "0", "0", "0", "0", "0",
"0", "0", "0", "0", "0", "0", "0", "0", "0", "0", "0", "0",
"0", "0", "0", "0", "0", "0", "0"
), color_available___blue = c(
"1",
"0", "0", "0", "0", "0", "0", "0", "0", "0", "0", "0", "0",
"0", "0", "0", "0", "0", "0", "0", "0", "0", "0", "0", "0",
"0", "0", "0", "0", "0", "0", "0"
), color_available___black = c(
"0",
"0", "0", "0", "0", "0", "0", "0", "0", "0", "0", "0", "0",
"0", "0", "0", "0", "0", "0", "0", "0", "0", "0", "0", "0",
"0", "0", "0", "0", "0", "0", "0"
), motor_trend_cars_complete = c(
"1",
"0", "0", "0", "0", "0", "0", "0", "0", "0", "0", "0", "0",
"0", "0", "0", "0", "0", "0", "0", "0", "0", "0", "0", "0",
"0", "0", "0", "0", "0", "0", "0"
), letter_group___a = c(
"1",
"0", "1", "0", "0", "0", "0", "0", "0", "0", "0", "0", "0",
"0", "0", "0", "0", "0", "1", "1", "0", "0", "0", "0", "0",
"0", "0", "0", "0", "0", "0", "0"
), letter_group___b = c(
"1",
"0", "0", "1", "1", "0", "1", "0", "0", "0", "0", "0", "0",
"0", "0", "0", "0", "0", "1", "1", "0", "0", "0", "0", "0",
"0", "0", "0", "0", "0", "0", "0"
), letter_group___c = c(
"0",
"0", "1", "1", "1", "0", "1", "0", "0", "0", "0", "0", "0",
"0", "0", "0", "0", "0", "0", "0", "0", "0", "0", "0", "0",
"0", "0", "0", "0", "0", "0", "0"
), choice = c(
"choice2",
"", "choice1", "choice1", "", "", "choice1", "", "", "",
"", "", "", "", "", "", "", "", "", "choice2", "", "", "",
"", "", "", "", "", "", "", "", ""
), grouping_complete = c(
"2",
"0", "2", "2", "0", "0", "1", "0", "0", "0", "0", "0", "0",
"0", "0", "0", "0", "0", "0", "0", "0", "0", "0", "0", "0",
"0", "0", "0", "0", "0", "0", "0"
)
), row.names = c(
1L, 5L,
6L, 9L, 11L, 12L, 13L, 18L, 19L, 20L, 21L, 22L, 23L, 24L, 25L,
26L, 27L, 28L, 29L, 30L, 34L, 35L, 36L, 37L, 38L, 39L, 40L, 41L,
42L, 43L, 44L, 45L
), class = "data.frame"), sale = structure(list(
row = c(
"AMC Javelin", "AMC Javelin", "AMC Javelin", "Camaro Z28",
"Camaro Z28", "Chrysler Imperial", "Duster 360", "Duster 360",
"Duster 360", "Duster 360", "Merc 230", "Merc 230", "Merc 230"
), redcap_repeat_instrument = c(
"sale", "sale", "sale", "sale",
"sale", "sale", "sale", "sale", "sale", "sale", "sale", "sale",
"sale"
), redcap_repeat_instance = c(
"1", "2", "3", "1", "2",
"1", "1", "2", "3", "4", "1", "2", "3"
), price = c(
"12000.50",
"13750.77", "15004.57", "7800.00", "8000.00", "7500.00",
"8756.40", "6800.88", "8888.88", "970.00", "7800.98", "7954.00",
"6800.55"
), color = c(
"1", "3", "2", "2", "3", "1", "4",
"2", "1", "4", "2", "1", "3"
), customer = c(
"Bob", "Sue",
"Kim", "Janice", "Tim", "Jim", "Sarah", "Pablo", "Erica",
"Juan", "Ted", "Quentin", "Sharon"
), sale_complete = c(
"0",
"2", "0", "2", "0", "2", "1", "0", "0", "0", "0", "0", "2"
)
), row.names = c(
2L, 3L, 4L, 7L, 8L, 10L, 14L, 15L, 16L,
17L, 31L, 32L, 33L
), class = "data.frame"))
)
expect_known_hash(redcap_output_json1, "2c8b6531597182af1248f92124161e0c")
})

56
tests/testthat/test-as_factor.R
View file

@ -1,56 +0,0 @@
# library(testthat)
test_that("fct2num works", {
expect_equal(2 * 2, 4)
expect_equal(
c(1, 4, 3, "A", 7, 8, 1) |>
as_factor() |> # named_levels()
fct2num(),
c(1, 2, 3, 4, 5, 6, 1)
)
expect_equal(
structure(c(1, 2, 3, 2, 10, 9),
labels = c(Unknown = 9, Refused = 10),
class = "haven_labelled"
) |>
as_factor() |>
fct2num(),
c(1, 2, 3, 2, 10, 9)
)
expect_equal(
structure(c(1, 2, 3, 2, 10, 9),
labels = c(Unknown = 9, Refused = 10),
class = "labelled"
) |>
as_factor() |>
fct2num(),
c(1, 2, 3, 2, 10, 9)
)
expect_equal(
structure(c(1, 2, 3, 2, 10, 9),
labels = c(Unknown = 9, Refused = 10)
) |>
as_factor.labelled() |>
fct2num(),
c(1, 2, 3, 2, 10, 9)
)
expect_equal(
structure(c(1, 2, 3, 2, 10, 9),
labels = c(Unknown = 9, Refused = 10),
class = "labelled"
) |>
as_factor() |> dput(),
structure(c(1L, 2L, 3L, 2L, 5L, 4L), levels = c(
"1", "2", "3",
"Unknown", "Refused"
), class = "factor", labels = c(
Unknown = 9,
Refused = 10
))
)
})

509
tests/testthat/test-csv-exports.R
View file

@ -13,174 +13,7 @@ redcap_output_csv1 <- REDCap_split(records, metadata)
# Test that basic CSV export matches reference ------------------------------
test_that("CSV export matches reference", {
# expect_known_hash(redcap_output_csv1, "cb5074a06e1abcf659d60be1016965d2")
# dput(redcap_output_csv1)
expect_identical(
redcap_output_csv1,
list(
structure(list(
row = structure(1:32, levels = c(
"AMC Javelin",
"Cadillac Fleetwood", "Camaro Z28", "Chrysler Imperial", "Datsun 710",
"Dodge Challenger", "Duster 360", "Ferrari Dino", "Fiat 128",
"Fiat X1-9", "Ford Pantera L", "Honda Civic", "Hornet 4 Drive",
"Hornet Sportabout", "Lincoln Continental", "Lotus Europa", "Maserati Bora",
"Mazda RX4", "Mazda RX4 Wag", "Merc 230", "Merc 240D", "Merc 280",
"Merc 280C", "Merc 450SE", "Merc 450SL", "Merc 450SLC", "Pontiac Firebird",
"Porsche 914-2", "Toyota Corolla", "Toyota Corona", "Valiant",
"Volvo 142E"
), class = "factor"), mpg = c(
15.2, 10.4, 13.3, 14.7,
22.8, 15.5, 14.3, 19.7, 32.4, 27.3, 15.8, 30.4, 21.4, 18.7, 10.4,
30.4, 15, 21, 21, 22.8, 24.4, 19.2, 17.8, 16.4, 17.3, 15.2, 19.2,
26, 33.9, 21.5, 18.1, 21.4
), cyl = c(
8L, 8L, 8L, 8L, 4L, 8L,
8L, 6L, 4L, 4L, 8L, 4L, 6L, 8L, 8L, 4L, 8L, 6L, 6L, 4L, 4L, 6L,
6L, 8L, 8L, 8L, 8L, 4L, 4L, 4L, 6L, 4L
), disp = c(
304, 472, 350,
440, 108, 318, 360, 145, 78.7, 79, 351, 75.7, 258, 360, 460,
95.1, 301, 160, 160, 140.8, 146.7, 167.6, 167.6, 275.8, 275.8,
275.8, 400, 120.3, 71.1, 120.1, 225, 121
), hp = c(
150L, 205L,
245L, 230L, 93L, 150L, 245L, 175L, 66L, 66L, 264L, 52L, 110L,
175L, 215L, 113L, 335L, 110L, 110L, 95L, 62L, 123L, 123L, 180L,
180L, 180L, 175L, 91L, 65L, 97L, 105L, 109L
), drat = c(
3.15,
2.93, 3.73, 3.23, 3.85, 2.76, 3.21, 3.62, 4.08, 4.08, 4.22, 4.93,
3.08, 3.15, 3, 3.77, 3.54, 3.9, 3.9, 3.92, 3.69, 3.92, 3.92,
3.07, 3.07, 3.07, 3.08, 4.43, 4.22, 3.7, 2.76, 4.11
), wt = c(
3.435,
5.25, 3.84, 5.345, 2.32, 3.52, 3.57, 2.77, 2.2, 1.935, 3.17,
1.615, 3.215, 3.44, 5.424, 1.513, 3.57, 2.62, 2.875, 3.15, 3.19,
3.44, 3.44, 4.07, 3.73, 3.78, 3.845, 2.14, 1.835, 2.465, 3.46,
2.78
), qsec = c(
17.3, 17.98, 15.41, 17.42, 18.61, 16.87, 15.84,
15.5, 19.47, 18.9, 14.5, 18.52, 19.44, 17.02, 17.82, 16.9, 14.6,
16.46, 17.02, 22.9, 20, 18.3, 18.9, 17.4, 17.6, 18, 17.05, 16.7,
19.9, 20.01, 20.22, 18.6
), vs = c(
0L, 0L, 0L, 0L, 1L, 0L, 0L,
0L, 1L, 1L, 0L, 1L, 1L, 0L, 0L, 1L, 0L, 0L, 0L, 1L, 1L, 1L, 1L,
0L, 0L, 0L, 0L, 0L, 1L, 1L, 1L, 1L
), am = c(
0L, 0L, 0L, 0L, 1L,
0L, 0L, 1L, 1L, 1L, 1L, 1L, 0L, 0L, 0L, 1L, 1L, 1L, 1L, 0L, 0L,
0L, 0L, 0L, 0L, 0L, 0L, 1L, 1L, 0L, 0L, 1L
), gear = c(
3L, 3L,
3L, 3L, 4L, 3L, 3L, 5L, 4L, 4L, 5L, 4L, 3L, 3L, 3L, 5L, 5L, 4L,
4L, 4L, 4L, 4L, 4L, 3L, 3L, 3L, 3L, 5L, 4L, 3L, 3L, 4L
), carb = c(
2L,
4L, 4L, 4L, 1L, 2L, 4L, 6L, 1L, 1L, 4L, 2L, 1L, 2L, 4L, 2L, 8L,
4L, 4L, 2L, 2L, 4L, 4L, 3L, 3L, 3L, 2L, 2L, 1L, 1L, 1L, 2L
),
color_available___red = c(
1L, 0L, 0L, 0L, 0L, 0L, 0L, 0L,
0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L,
0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L
), color_available___green = c(
1L,
0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L,
0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L,
0L
), color_available___blue = c(
1L, 0L, 0L, 0L, 0L, 0L, 0L,
0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L,
0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L
), color_available___black = c(
0L,
0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L,
0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L,
0L
), motor_trend_cars_complete = c(
1L, 0L, 0L, 0L, 0L, 0L,
0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L,
0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L
), letter_group___a = c(
1L,
0L, 1L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L,
0L, 0L, 1L, 1L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L,
0L
), letter_group___b = c(
1L, 0L, 0L, 1L, 1L, 0L, 1L, 0L,
0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 1L, 1L, 0L, 0L, 0L,
0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L
), letter_group___c = c(
0L,
0L, 1L, 1L, 1L, 0L, 1L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L,
0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L,
0L
), choice = structure(c(
3L, 1L, 2L, 2L, 1L, 1L, 2L, 1L,
1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 3L, 1L, 1L, 1L,
1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L
), levels = c(
"", "choice1",
"choice2"
), class = "factor"), grouping_complete = c(
2L,
0L, 2L, 2L, 0L, 0L, 1L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L,
0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L,
0L
)
), row.names = c(
1L, 5L, 6L, 9L, 11L, 12L, 13L, 18L, 19L,
20L, 21L, 22L, 23L, 24L, 25L, 26L, 27L, 28L, 29L, 30L, 34L, 35L,
36L, 37L, 38L, 39L, 40L, 41L, 42L, 43L, 44L, 45L
), class = "data.frame"),
sale = structure(list(
row = structure(c(
1L, 1L, 1L, 3L, 3L,
4L, 7L, 7L, 7L, 7L, 20L, 20L, 20L
), levels = c(
"AMC Javelin",
"Cadillac Fleetwood", "Camaro Z28", "Chrysler Imperial",
"Datsun 710", "Dodge Challenger", "Duster 360", "Ferrari Dino",
"Fiat 128", "Fiat X1-9", "Ford Pantera L", "Honda Civic",
"Hornet 4 Drive", "Hornet Sportabout", "Lincoln Continental",
"Lotus Europa", "Maserati Bora", "Mazda RX4", "Mazda RX4 Wag",
"Merc 230", "Merc 240D", "Merc 280", "Merc 280C", "Merc 450SE",
"Merc 450SL", "Merc 450SLC", "Pontiac Firebird", "Porsche 914-2",
"Toyota Corolla", "Toyota Corona", "Valiant", "Volvo 142E"
), class = "factor"), redcap_repeat_instrument = c(
"sale",
"sale", "sale", "sale", "sale", "sale", "sale", "sale", "sale",
"sale", "sale", "sale", "sale"
), redcap_repeat_instance = c(
1L,
2L, 3L, 1L, 2L, 1L, 1L, 2L, 3L, 4L, 1L, 2L, 3L
), price = c(
12000.5,
13750.77, 15004.57, 7800, 8000, 7500, 8756.4, 6800.88, 8888.88,
970, 7800.98, 7954, 6800.55
), color = c(
1L, 3L, 2L, 2L, 3L,
1L, 4L, 2L, 1L, 4L, 2L, 1L, 3L
), customer = structure(c(
2L,
12L, 7L, 4L, 14L, 5L, 10L, 8L, 3L, 6L, 13L, 9L, 11L
), levels = c(
"",
"Bob", "Erica", "Janice", "Jim", "Juan", "Kim", "Pablo",
"Quentin", "Sarah", "Sharon", "Sue", "Ted", "Tim"
), class = "factor"),
sale_complete = c(
0L, 2L, 0L, 2L, 0L, 2L, 1L, 0L, 0L,
0L, 0L, 0L, 2L
)
), row.names = c(
2L, 3L, 4L, 7L, 8L, 10L,
14L, 15L, 16L, 17L, 31L, 32L, 33L
), class = "data.frame")
)
)
expect_known_hash(redcap_output_csv1, "cb5074a06e1abcf659d60be1016965d2")
})
# Test that REDCap_split can handle a focused dataset
@ -208,345 +41,7 @@ if (requireNamespace("Hmisc", quietly = TRUE)) {
redcap_output_csv2 <-
REDCap_split(REDCap_process_csv(records), metadata)
# expect_known_hash(redcap_output_csv2, "578dc054e59ec92a21e950042e08ee37")
# dput(redcap_output_csv2)
expect_identical(
redcap_output_csv2,
list(structure(list(
row = structure(1:32, levels = c(
"AMC Javelin",
"Cadillac Fleetwood", "Camaro Z28", "Chrysler Imperial", "Datsun 710",
"Dodge Challenger", "Duster 360", "Ferrari Dino", "Fiat 128",
"Fiat X1-9", "Ford Pantera L", "Honda Civic", "Hornet 4 Drive",
"Hornet Sportabout", "Lincoln Continental", "Lotus Europa", "Maserati Bora",
"Mazda RX4", "Mazda RX4 Wag", "Merc 230", "Merc 240D", "Merc 280",
"Merc 280C", "Merc 450SE", "Merc 450SL", "Merc 450SLC", "Pontiac Firebird",
"Porsche 914-2", "Toyota Corolla", "Toyota Corona", "Valiant",
"Volvo 142E"
), class = c("labelled", "factor"), label = "Name"),
mpg = structure(c(
15.2, 10.4, 13.3, 14.7, 22.8, 15.5, 14.3,
19.7, 32.4, 27.3, 15.8, 30.4, 21.4, 18.7, 10.4, 30.4, 15,
21, 21, 22.8, 24.4, 19.2, 17.8, 16.4, 17.3, 15.2, 19.2, 26,
33.9, 21.5, 18.1, 21.4
), label = "Miles/(US) gallon", class = c(
"labelled",
"numeric"
)), cyl = structure(c(
8L, 8L, 8L, 8L, 4L, 8L, 8L,
6L, 4L, 4L, 8L, 4L, 6L, 8L, 8L, 4L, 8L, 6L, 6L, 4L, 4L, 6L,
6L, 8L, 8L, 8L, 8L, 4L, 4L, 4L, 6L, 4L
), label = "Number of cylinders", class = c(
"labelled",
"integer"
)), disp = structure(c(
304, 472, 350, 440, 108,
318, 360, 145, 78.7, 79, 351, 75.7, 258, 360, 460, 95.1,
301, 160, 160, 140.8, 146.7, 167.6, 167.6, 275.8, 275.8,
275.8, 400, 120.3, 71.1, 120.1, 225, 121
), label = "Displacement", class = c(
"labelled",
"numeric"
)), hp = structure(c(
150L, 205L, 245L, 230L, 93L,
150L, 245L, 175L, 66L, 66L, 264L, 52L, 110L, 175L, 215L,
113L, 335L, 110L, 110L, 95L, 62L, 123L, 123L, 180L, 180L,
180L, 175L, 91L, 65L, 97L, 105L, 109L
), label = "Gross horsepower", class = c(
"labelled",
"integer"
)), drat = structure(c(
3.15, 2.93, 3.73, 3.23, 3.85,
2.76, 3.21, 3.62, 4.08, 4.08, 4.22, 4.93, 3.08, 3.15, 3,
3.77, 3.54, 3.9, 3.9, 3.92, 3.69, 3.92, 3.92, 3.07, 3.07,
3.07, 3.08, 4.43, 4.22, 3.7, 2.76, 4.11
), label = "Rear axle ratio", class = c(
"labelled",
"numeric"
)), wt = structure(c(
3.435, 5.25, 3.84, 5.345, 2.32,
3.52, 3.57, 2.77, 2.2, 1.935, 3.17, 1.615, 3.215, 3.44, 5.424,
1.513, 3.57, 2.62, 2.875, 3.15, 3.19, 3.44, 3.44, 4.07, 3.73,
3.78, 3.845, 2.14, 1.835, 2.465, 3.46, 2.78
), label = "Weight", class = c(
"labelled",
"numeric"
)), qsec = structure(c(
17.3, 17.98, 15.41, 17.42,
18.61, 16.87, 15.84, 15.5, 19.47, 18.9, 14.5, 18.52, 19.44,
17.02, 17.82, 16.9, 14.6, 16.46, 17.02, 22.9, 20, 18.3, 18.9,
17.4, 17.6, 18, 17.05, 16.7, 19.9, 20.01, 20.22, 18.6
), label = "1/4 mile time", class = c(
"labelled",
"numeric"
)), vs = structure(c(
0L, 0L, 0L, 0L, 1L, 0L, 0L,
0L, 1L, 1L, 0L, 1L, 1L, 0L, 0L, 1L, 0L, 0L, 0L, 1L, 1L, 1L,
1L, 0L, 0L, 0L, 0L, 0L, 1L, 1L, 1L, 1L
), label = "V engine?", class = c(
"labelled",
"integer"
)), am = structure(c(
0L, 0L, 0L, 0L, 1L, 0L, 0L,
1L, 1L, 1L, 1L, 1L, 0L, 0L, 0L, 1L, 1L, 1L, 1L, 0L, 0L, 0L,
0L, 0L, 0L, 0L, 0L, 1L, 1L, 0L, 0L, 1L
), label = "Transmission", class = c(
"labelled",
"integer"
)), gear = structure(c(
3L, 3L, 3L, 3L, 4L, 3L, 3L,
5L, 4L, 4L, 5L, 4L, 3L, 3L, 3L, 5L, 5L, 4L, 4L, 4L, 4L, 4L,
4L, 3L, 3L, 3L, 3L, 5L, 4L, 3L, 3L, 4L
), label = "Number of forward gears", class = c(
"labelled",
"integer"
)), carb = structure(c(
2L, 4L, 4L, 4L, 1L, 2L, 4L,
6L, 1L, 1L, 4L, 2L, 1L, 2L, 4L, 2L, 8L, 4L, 4L, 2L, 2L, 4L,
4L, 3L, 3L, 3L, 2L, 2L, 1L, 1L, 1L, 2L
), label = "Number of carburetors", class = c(
"labelled",
"integer"
)), color_available___red = structure(c(
1L, 0L,
0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L,
0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L
), label = "Colors Available (choice<-Red)", class = c(
"labelled",
"integer"
)), color_available___green = structure(c(
1L, 0L,
0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L,
0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L
), label = "Colors Available (choice<-Green)", class = c(
"labelled",
"integer"
)), color_available___blue = structure(c(
1L, 0L,
0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L,
0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L
), label = "Colors Available (choice<-Blue)", class = c(
"labelled",
"integer"
)), color_available___black = structure(c(
0L, 0L,
0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L,
0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L
), label = "Colors Available (choice<-Black)", class = c(
"labelled",
"integer"
)), motor_trend_cars_complete = structure(c(
1L,
0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L,
0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L,
0L
), label = "Complete?", class = c("labelled", "integer")), letter_group___a = structure(c(
1L, 0L, 1L, 0L, 0L, 0L,
0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 1L, 1L, 0L,
0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L
), label = "Which group? (choice<-A)", class = c(
"labelled",
"integer"
)), letter_group___b = structure(c(
1L, 0L, 0L, 1L,
1L, 0L, 1L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 1L,
1L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L
), label = "Which group? (choice<-B)", class = c(
"labelled",
"integer"
)), letter_group___c = structure(c(
0L, 0L, 1L, 1L,
1L, 0L, 1L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L,
0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L
), label = "Which group? (choice<-C)", class = c(
"labelled",
"integer"
)), choice = structure(c(
3L, 1L, 2L, 2L, 1L, 1L,
2L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 3L, 1L,
1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L
), levels = c(
"",
"choice1", "choice2"
), class = c("labelled", "factor"), label = "Choose one"),
grouping_complete = structure(c(
2L, 0L, 2L, 2L, 0L, 0L, 1L,
0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L,
0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L
), label = "Complete?", class = c(
"labelled",
"integer"
)), cyl.factor = structure(c(
6L, 6L, 6L, 6L, 2L,
6L, 6L, 4L, 2L, 2L, 6L, 2L, 4L, 6L, 6L, 2L, 6L, 4L, 4L, 2L,
2L, 4L, 4L, 6L, 6L, 6L, 6L, 2L, 2L, 2L, 4L, 2L
), levels = c(
"3",
"4", "5", "6", "7", "8"
), class = "factor"), vs.factor = structure(c(
2L,
2L, 2L, 2L, 1L, 2L, 2L, 2L, 1L, 1L, 2L, 1L, 1L, 2L, 2L, 1L,
2L, 2L, 2L, 1L, 1L, 1L, 1L, 2L, 2L, 2L, 2L, 2L, 1L, 1L, 1L,
1L
), levels = c("Yes", "No"), class = "factor"), am.factor = structure(c(
1L,
1L, 1L, 1L, 2L, 1L, 1L, 2L, 2L, 2L, 2L, 2L, 1L, 1L, 1L, 2L,
2L, 2L, 2L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 2L, 2L, 1L, 1L,
2L
), levels = c("Automatic", "Manual"), class = "factor"),
gear.factor = structure(c(
1L, 1L, 1L, 1L, 2L, 1L, 1L, 3L,
2L, 2L, 3L, 2L, 1L, 1L, 1L, 3L, 3L, 2L, 2L, 2L, 2L, 2L, 2L,
1L, 1L, 1L, 1L, 3L, 2L, 1L, 1L, 2L
), levels = c(
"3", "4",
"5"
), class = "factor"), carb.factor = structure(c(
2L, 4L,
4L, 4L, 1L, 2L, 4L, 6L, 1L, 1L, 4L, 2L, 1L, 2L, 4L, 2L, 8L,
4L, 4L, 2L, 2L, 4L, 4L, 3L, 3L, 3L, 2L, 2L, 1L, 1L, 1L, 2L
), levels = c("1", "2", "3", "4", "5", "6", "7", "8"), class = "factor"),
color_available___red.factor = structure(c(
2L, 1L, 1L, 1L,
1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L
), levels = c(
"Unchecked",
"Checked"
), class = "factor"), color_available___green.factor = structure(c(
2L,
1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
1L
), levels = c("Unchecked", "Checked"), class = "factor"),
color_available___blue.factor = structure(c(
2L, 1L, 1L, 1L,
1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L
), levels = c(
"Unchecked",
"Checked"
), class = "factor"), color_available___black.factor = structure(c(
1L,
1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
1L
), levels = c("Unchecked", "Checked"), class = "factor"),
motor_trend_cars_complete.factor = structure(c(
2L, 1L, 1L,
1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L
), levels = c(
"Incomplete",
"Unverified", "Complete"
), class = "factor"), letter_group___a.factor = structure(c(
2L,
1L, 2L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
1L, 1L, 2L, 2L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
1L
), levels = c("Unchecked", "Checked"), class = "factor"),
letter_group___b.factor = structure(c(
2L, 1L, 1L, 2L, 2L,
1L, 2L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 2L, 2L,
1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L
), levels = c(
"Unchecked",
"Checked"
), class = "factor"), letter_group___c.factor = structure(c(
1L,
1L, 2L, 2L, 2L, 1L, 2L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
1L
), levels = c("Unchecked", "Checked"), class = "factor"),
choice.factor = structure(c(
2L, NA, 1L, 1L, NA, NA, 1L, NA,
NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, 2L, NA, NA, NA,
NA, NA, NA, NA, NA, NA, NA, NA, NA
), levels = c(
"Choice 1",
"Choice 2"
), class = "factor"), grouping_complete.factor = structure(c(
3L,
1L, 3L, 3L, 1L, 1L, 2L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
1L
), levels = c("Incomplete", "Unverified", "Complete"), class = "factor")
), row.names = c(
1L,
5L, 6L, 9L, 11L, 12L, 13L, 18L, 19L, 20L, 21L, 22L, 23L, 24L,
25L, 26L, 27L, 28L, 29L, 30L, 34L, 35L, 36L, 37L, 38L, 39L, 40L,
41L, 42L, 43L, 44L, 45L
), class = "data.frame"), sale = structure(list(
row = structure(c(
1L, 1L, 1L, 3L, 3L, 4L, 7L, 7L, 7L, 7L,
20L, 20L, 20L
), levels = c(
"AMC Javelin", "Cadillac Fleetwood",
"Camaro Z28", "Chrysler Imperial", "Datsun 710", "Dodge Challenger",
"Duster 360", "Ferrari Dino", "Fiat 128", "Fiat X1-9", "Ford Pantera L",
"Honda Civic", "Hornet 4 Drive", "Hornet Sportabout", "Lincoln Continental",
"Lotus Europa", "Maserati Bora", "Mazda RX4", "Mazda RX4 Wag",
"Merc 230", "Merc 240D", "Merc 280", "Merc 280C", "Merc 450SE",
"Merc 450SL", "Merc 450SLC", "Pontiac Firebird", "Porsche 914-2",
"Toyota Corolla", "Toyota Corona", "Valiant", "Volvo 142E"
), class = c("labelled", "factor"), label = "Name"), redcap_repeat_instrument = c(
"sale",
"sale", "sale", "sale", "sale", "sale", "sale", "sale", "sale",
"sale", "sale", "sale", "sale"
), redcap_repeat_instance = structure(c(
1L,
2L, 3L, 1L, 2L, 1L, 1L, 2L, 3L, 4L, 1L, 2L, 3L
), label = "Repeat Instance", class = c(
"labelled",
"integer"
)), price = structure(c(
12000.5, 13750.77, 15004.57,
7800, 8000, 7500, 8756.4, 6800.88, 8888.88, 970, 7800.98,
7954, 6800.55
), label = "Sale price", class = c(
"labelled",
"numeric"
)), color = structure(c(
1L, 3L, 2L, 2L, 3L, 1L,
4L, 2L, 1L, 4L, 2L, 1L, 3L
), label = "Color", class = c(
"labelled",
"integer"
)), customer = structure(c(
2L, 12L, 7L, 4L, 14L,
5L, 10L, 8L, 3L, 6L, 13L, 9L, 11L
), levels = c(
"", "Bob",
"Erica", "Janice", "Jim", "Juan", "Kim", "Pablo", "Quentin",
"Sarah", "Sharon", "Sue", "Ted", "Tim"
), class = c(
"labelled",
"factor"
), label = "Customer Name"), sale_complete = structure(c(
0L,
2L, 0L, 2L, 0L, 2L, 1L, 0L, 0L, 0L, 0L, 0L, 2L
), label = "Complete?", class = c(
"labelled",
"integer"
)), redcap_repeat_instrument.factor = structure(c(
1L,
1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L
), levels = "Sale", class = "factor"),
color.factor = structure(c(
1L, 3L, 2L, 2L, 3L, 1L, 4L, 2L,
1L, 4L, 2L, 1L, 3L
), levels = c("red", "green", "blue", "black"), class = "factor"), sale_complete.factor = structure(c(
1L,
3L, 1L, 3L, 1L, 3L, 2L, 1L, 1L, 1L, 1L, 1L, 3L
), levels = c(
"Incomplete",
"Unverified", "Complete"
), class = "factor")
), row.names = c(
2L,
3L, 4L, 7L, 8L, 10L, 14L, 15L, 16L, 17L, 31L, 32L, 33L
), class = "data.frame"))
)
expect_known_hash(redcap_output_csv2, "578dc054e59ec92a21e950042e08ee37")
})
}

40
tests/testthat/test-ds2dd.R
View file

@ -1,40 +0,0 @@
mtcars$id <- seq_len(nrow(mtcars))
metadata_names <- function(...) {
c(
"field_name", "form_name", "section_header", "field_type",
"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"
)
}
test_that("ds2dd gives desired output", {
expect_equal(ncol(ds2dd(mtcars, record.id = "id",metadata = metadata_names())), 18)
expect_s3_class(ds2dd(mtcars, record.id = "id",metadata = metadata_names()), "data.frame")
expect_s3_class(ds2dd(mtcars, record.id = 12,metadata = metadata_names()), "data.frame")
})
test_that("ds2dd gives output with list of length two", {
expect_equal(length(ds2dd(
mtcars,
record.id = "id",
include.column.names = TRUE,metadata = metadata_names()
)), 2)
})
test_that("ds2dd gives correct errors", {
expect_error(ds2dd(mtcars,metadata = metadata_names()))
expect_error(ds2dd(mtcars, form.name = c("basis", "incl"),metadata = metadata_names()))
expect_error(ds2dd(mtcars, field.type = c("text", "dropdown"),metadata = metadata_names()))
expect_error(ds2dd(mtcars, field.label = c("Name", "Age"),metadata = metadata_names()))
})
test_that("ds2dd correctly renames", {
expect_equal(ncol(ds2dd(mtcars, record.id = "id",metadata = metadata_names())), 18)
expect_s3_class(ds2dd(mtcars, record.id = "id",metadata = metadata_names()), "data.frame")
})

184
tests/testthat/test-longitudinal.R
View file

@ -5,191 +5,13 @@ test_that("CSV export matches reference", {
c(
records = "WARRIORtestForSoftwa_DATA_2018-06-21_1431.csv",
metadata = "WARRIORtestForSoftwareUpgrades_DataDictionary_2018-06-21.csv"
), get_data_location,
FUN.VALUE = "character"
), get_data_location, FUN.VALUE = "character"
)
redcap <- lapply(file_paths, read.csv, stringsAsFactors = FALSE)
redcap[["metadata"]] <- with(redcap, metadata[metadata[, 1] > "", ])
redcap[["metadata"]] <- with(redcap, metadata[metadata[,1] > "",])
redcap_output <- with(redcap, REDCap_split(records, metadata))
# expect_known_hash(redcap_output, "0934bcb292")
expect_identical(redcap_output
,
list(
structure(list(record_id = c(
"806-1", "806-1", "806-2",
"806-2"
), redcap_event_name = c(
"baseline_arm_1", "followup_month_3_arm_1",
"baseline_arm_1", "followup_month_3_arm_1"
), redcap_data_access_group = c(
"uf_test",
"uf_test", "uf_test", "uf_test"
), redcap_survey_identifier = c(
NA,
NA, NA, NA
), signed_consent_1 = c(
"[document]", "", "[document]",
""
), signed_consent_2 = c(NA, NA, NA, NA), signed_consent_3 = c(
NA,
NA, NA, NA
), signed_addendum1 = c(
"[document]", "", "[document]",
""
), signed_addendum2 = c(NA, NA, NA, NA), signed_addendum3 = c(
NA,
NA, NA, NA
), upload_of_signed_icfs_complete = c(2L, NA, 2L, NA), demo_date = c("2018-05-08", "", "2018-05-08", ""), demo_name_first = c(
"Philip",
"", "afadgs", ""
), demo_name_init = c("B", "", "afd", ""), demo_name_last = c(
"Chase",
"", "afdsgfd", ""
), demo_date_birth = c(
"1964-04-09", "", "1977-06-26",
""
), demo_street_ad = c("5959 NW 13th Ave", "", "24325543", ""), demo_city_ad = c("Gainesville", "", "2352453", ""), demo_state_ad = c(
"FL",
"", "fwef", ""
), demo_zip = c(32605L, NA, 32601L, NA), demo_daytime = c(
"(352) 555-0760",
"", "(352) 294-5299", ""
), demo_email = c(
"bobsyouruncle@example.org",
"", "", ""
), demo_ethnic = c(2L, NA, 2L, NA), demo_racial = c(
5L,
NA, 89L, NA
), demo_racial_oth = c(NA, NA, NA, NA), demo_military_mrn = c(
2L,
NA, NA, NA
), demo_ssn = c("111-22-3333", "", "123-45-6789", ""), demographics_complete = c(2L, NA, 2L, NA), elig_icf = c(
1L,
NA, 1L, NA
), elig_ischem = c(1L, NA, 1L, NA), elig_signs___1 = c(
1L,
NA, 0L, NA
), elig_signs___2 = c(0L, NA, 1L, NA), elig_signs___3 = c(
0L,
NA, 0L, NA
), elig_signs___4 = c(0L, NA, 0L, NA), elig_card_cath = c(
1L,
NA, 0L, NA
), elig_card_cath_details = c(1L, NA, NA, NA), elig_cath_disease_severity = c(
NA,
NA, NA, NA
), elig_cath_vessel = c(NA, NA, NA, NA), elig_ejection_fraction = c(
60L,
NA, NA, NA
), elig_cath_ffr = c(1L, NA, NA, NA), elig_ccta = c(
1L,
NA, 0L, NA
), elig_card_cath_details_2 = c(1L, NA, NA, NA), elig_cath_disease_severity_2 = c(
NA,
NA, NA, NA
), elig_ejection_fraction_2 = c(60L, NA, NA, NA), elig_cta_score = c(
24L,
NA, NA, NA
), elig_nocom_med = c(0L, NA, 0L, NA), elig_ischemia_dilated = c(
0L,
NA, 0L, NA
), elig_doc_acs = c(0L, NA, 0L, NA), elig_lvef = c(
0L,
NA, 0L, NA
), elig_nyha_class = c(0L, NA, 0L, NA), elig_hos_hfref = c(
0L,
NA, 0L, NA
), elig_stroke = c(0L, NA, 0L, NA), elig_carnial_hemo = c(
0L,
NA, 0L, NA
), elig_renal = c(0L, NA, 0L, NA), elig_valvular = c(
0L,
NA, 0L, NA
), elig_life_expect = c(0L, NA, 0L, NA), elig_enroll_clinic = c(
0L,
NA, 0L, NA
), elig_intol_ace = c(0L, NA, 0L, NA), elig_intol_arb = c(
0L,
NA, 0L, NA
), elig_intol_statin = c(0L, NA, 0L, NA), elig_intol_pcsk = c(
NA,
NA, NA, NA
), elig_preg = c(0L, NA, 0L, NA), elig_liver_dis = c(
0L,
NA, 0L, NA
), elig_hist_rhab = c(0L, NA, 0L, NA), elig_high_dose = c(
0L,
NA, 0L, NA
), elig_study_yes = c(1L, NA, 1L, NA), elig_date = c(
"2018-05-08",
"", "2018-05-08", ""
), elig_study_no = c(NA, NA, NA, NA), eligibility_complete = c(
2L,
NA, 2L, NA
)), row.names = c(1L, 2L, 7L, 8L), class = "data.frame"),
informed_consent = structure(list(record_id = c(
"806-1",
"806-2"
), redcap_event_name = c("baseline_arm_1", "baseline_arm_1"), redcap_repeat_instrument = c("informed_consent", "informed_consent"), redcap_repeat_instance = c(1L, 1L), redcap_data_access_group = c(
"uf_test",
"uf_test"
), redcap_survey_identifier = c(NA, NA)), row.names = c(
3L,
9L
), class = "data.frame"), informed_consent_and_addendum = structure(list(
record_id = c("806-1", "806-1", "806-1", "806-2"), redcap_event_name = c(
"baseline_arm_1",
"baseline_arm_1", "baseline_arm_1", "baseline_arm_1"
),
redcap_repeat_instrument = c(
"informed_consent_and_addendum",
"informed_consent_and_addendum", "informed_consent_and_addendum",
"informed_consent_and_addendum"
), redcap_repeat_instance = c(
1L,
2L, 3L, 1L
), redcap_data_access_group = c(
"uf_test",
"uf_test", "uf_test", "uf_test"
), redcap_survey_identifier = c(
NA,
NA, NA, NA
), informed_consent_and_addendum_timestamp = c(
"2018-05-08 21:15:12",
"", "", "2018-05-08 21:02:39"
), icf_first_name = c(
"Philip",
"Bobs", "Bobs", "test"
), icf_last_name = c(
"Chase", "Youruncle",
"Youruncle", "test"
), icf_date = c(
"2018-05-08", "2018-06-21",
"2018-06-21", "2018-05-08"
), icf_sign = c(
"[document]",
"[document]", "[document]", "[document]"
), icf_consenter_name = c(
"Philip B Chase",
"Yo Mama", "zsdf", "taryn"
), icf_consentee_info = c(
"UF",
"Anywhere she wants", "DF", "stoffs"
), icf_consentee_sign = c(
"[document]",
"[document]", "[document]", "[document]"
), icf_consentee_date = c(
"2018-05-08",
"2018-06-21", "2018-06-21", "2018-05-08"
), informed_consent_and_addendum_complete = c(
2L,
2L, 2L, 2L
)
), row.names = c(4L, 5L, 6L, 10L), class = "data.frame")
)
)
expect_known_hash(redcap_output, "0934bcb292")
})

347
tests/testthat/test-primary-table-name.R
View file

@ -8,360 +8,23 @@ metadata <-
records <-
jsonlite::fromJSON(get_data_location("ExampleProject_records.json"))
# ref_hash <- "2c8b6531597182af1248f92124161e0c"
ref_hash <- "2c8b6531597182af1248f92124161e0c"
# Tests -------------------------------------------------------------------
test_that("Will not use a repeating instrument name for primary table", {
# local_edition(3)
#
expect_warning(
REDCap_split(records, metadata, "sale"),
"primary table"
)
redcap_output_json1 <-
suppressWarnings(REDCap_split(records, metadata, "sale"))
expect_warning(REDCap_split(records, metadata, "sale"),
"primary table")
# dput(redcap_output_json1)
expect_identical(
redcap_output_json1,
list(structure(list(
row = c(
"AMC Javelin", "Cadillac Fleetwood",
"Camaro Z28", "Chrysler Imperial", "Datsun 710", "Dodge Challenger",
"Duster 360", "Ferrari Dino", "Fiat 128", "Fiat X1-9", "Ford Pantera L",
"Honda Civic", "Hornet 4 Drive", "Hornet Sportabout", "Lincoln Continental",
"Lotus Europa", "Maserati Bora", "Mazda RX4", "Mazda RX4 Wag",
"Merc 230", "Merc 240D", "Merc 280", "Merc 280C", "Merc 450SE",
"Merc 450SL", "Merc 450SLC", "Pontiac Firebird", "Porsche 914-2",
"Toyota Corolla", "Toyota Corona", "Valiant", "Volvo 142E"
),
mpg = c(
"15.2", "10.4", "13.3", "14.7", "22.8", "15.5", "14.3",
"19.7", "32.4", "27.3", "15.8", "30.4", "21.4", "18.7", "10.4",
"30.4", "15", "21", "21", "22.8", "24.4", "19.2", "17.8",
"16.4", "17.3", "15.2", "19.2", "26", "33.9", "21.5", "18.1",
"21.4"
), cyl = c(
"8", "8", "8", "8", "4", "8", "8", "6",
"4", "4", "8", "4", "6", "8", "8", "4", "8", "6", "6", "4",
"4", "6", "6", "8", "8", "8", "8", "4", "4", "4", "6", "4"
), disp = c(
"304", "472", "350", "440", "108", "318", "360",
"145", "78.7", "79", "351", "75.7", "258", "360", "460",
"95.1", "301", "160", "160", "140.8", "146.7", "167.6", "167.6",
"275.8", "275.8", "275.8", "400", "120.3", "71.1", "120.1",
"225", "121"
), hp = c(
"150", "205", "245", "230", "93", "150",
"245", "175", "66", "66", "264", "52", "110", "175", "215",
"113", "335", "110", "110", "95", "62", "123", "123", "180",
"180", "180", "175", "91", "65", "97", "105", "109"
), drat = c(
"3.15",
"2.93", "3.73", "3.23", "3.85", "2.76", "3.21", "3.62", "4.08",
"4.08", "4.22", "4.93", "3.08", "3.15", "3", "3.77", "3.54",
"3.9", "3.9", "3.92", "3.69", "3.92", "3.92", "3.07", "3.07",
"3.07", "3.08", "4.43", "4.22", "3.7", "2.76", "4.11"
), wt = c(
"3.435",
"5.25", "3.84", "5.345", "2.32", "3.52", "3.57", "2.77",
"2.2", "1.935", "3.17", "1.615", "3.215", "3.44", "5.424",
"1.513", "3.57", "2.62", "2.875", "3.15", "3.19", "3.44",
"3.44", "4.07", "3.73", "3.78", "3.845", "2.14", "1.835",
"2.465", "3.46", "2.78"
), qsec = c(
"17.3", "17.98", "15.41",
"17.42", "18.61", "16.87", "15.84", "15.5", "19.47", "18.9",
"14.5", "18.52", "19.44", "17.02", "17.82", "16.9", "14.6",
"16.46", "17.02", "22.9", "20", "18.3", "18.9", "17.4", "17.6",
"18", "17.05", "16.7", "19.9", "20.01", "20.22", "18.6"
),
vs = c(
"0", "0", "0", "0", "1", "0", "0", "0", "1", "1",
"0", "1", "1", "0", "0", "1", "0", "0", "0", "1", "1", "1",
"1", "0", "0", "0", "0", "0", "1", "1", "1", "1"
), am = c(
"0",
"0", "0", "0", "1", "0", "0", "1", "1", "1", "1", "1", "0",
"0", "0", "1", "1", "1", "1", "0", "0", "0", "0", "0", "0",
"0", "0", "1", "1", "0", "0", "1"
), gear = c(
"3", "3", "3",
"3", "4", "3", "3", "5", "4", "4", "5", "4", "3", "3", "3",
"5", "5", "4", "4", "4", "4", "4", "4", "3", "3", "3", "3",
"5", "4", "3", "3", "4"
), carb = c(
"2", "4", "4", "4", "1",
"2", "4", "6", "1", "1", "4", "2", "1", "2", "4", "2", "8",
"4", "4", "2", "2", "4", "4", "3", "3", "3", "2", "2", "1",
"1", "1", "2"
), color_available___red = c(
"1", "0", "0",
"0", "0", "0", "0", "0", "0", "0", "0", "0", "0", "0", "0",
"0", "0", "0", "0", "0", "0", "0", "0", "0", "0", "0", "0",
"0", "0", "0", "0", "0"
), color_available___green = c(
"1",
"0", "0", "0", "0", "0", "0", "0", "0", "0", "0", "0", "0",
"0", "0", "0", "0", "0", "0", "0", "0", "0", "0", "0", "0",
"0", "0", "0", "0", "0", "0", "0"
), color_available___blue = c(
"1",
"0", "0", "0", "0", "0", "0", "0", "0", "0", "0", "0", "0",
"0", "0", "0", "0", "0", "0", "0", "0", "0", "0", "0", "0",
"0", "0", "0", "0", "0", "0", "0"
), color_available___black = c(
"0",
"0", "0", "0", "0", "0", "0", "0", "0", "0", "0", "0", "0",
"0", "0", "0", "0", "0", "0", "0", "0", "0", "0", "0", "0",
"0", "0", "0", "0", "0", "0", "0"
), motor_trend_cars_complete = c(
"1",
"0", "0", "0", "0", "0", "0", "0", "0", "0", "0", "0", "0",
"0", "0", "0", "0", "0", "0", "0", "0", "0", "0", "0", "0",
"0", "0", "0", "0", "0", "0", "0"
), letter_group___a = c(
"1",
"0", "1", "0", "0", "0", "0", "0", "0", "0", "0", "0", "0",
"0", "0", "0", "0", "0", "1", "1", "0", "0", "0", "0", "0",
"0", "0", "0", "0", "0", "0", "0"
), letter_group___b = c(
"1",
"0", "0", "1", "1", "0", "1", "0", "0", "0", "0", "0", "0",
"0", "0", "0", "0", "0", "1", "1", "0", "0", "0", "0", "0",
"0", "0", "0", "0", "0", "0", "0"
), letter_group___c = c(
"0",
"0", "1", "1", "1", "0", "1", "0", "0", "0", "0", "0", "0",
"0", "0", "0", "0", "0", "0", "0", "0", "0", "0", "0", "0",
"0", "0", "0", "0", "0", "0", "0"
), choice = c(
"choice2",
"", "choice1", "choice1", "", "", "choice1", "", "", "",
"", "", "", "", "", "", "", "", "", "choice2", "", "", "",
"", "", "", "", "", "", "", "", ""
), grouping_complete = c(
"2",
"0", "2", "2", "0", "0", "1", "0", "0", "0", "0", "0", "0",
"0", "0", "0", "0", "0", "0", "0", "0", "0", "0", "0", "0",
"0", "0", "0", "0", "0", "0", "0"
)
), row.names = c(
1L, 5L,
6L, 9L, 11L, 12L, 13L, 18L, 19L, 20L, 21L, 22L, 23L, 24L, 25L,
26L, 27L, 28L, 29L, 30L, 34L, 35L, 36L, 37L, 38L, 39L, 40L, 41L,
42L, 43L, 44L, 45L
), class = "data.frame"), sale = structure(list(
row = c(
"AMC Javelin", "AMC Javelin", "AMC Javelin", "Camaro Z28",
"Camaro Z28", "Chrysler Imperial", "Duster 360", "Duster 360",
"Duster 360", "Duster 360", "Merc 230", "Merc 230", "Merc 230"
), redcap_repeat_instrument = c(
"sale", "sale", "sale", "sale",
"sale", "sale", "sale", "sale", "sale", "sale", "sale", "sale",
"sale"
), redcap_repeat_instance = c(
"1", "2", "3", "1", "2",
"1", "1", "2", "3", "4", "1", "2", "3"
), price = c(
"12000.50",
"13750.77", "15004.57", "7800.00", "8000.00", "7500.00",
"8756.40", "6800.88", "8888.88", "970.00", "7800.98", "7954.00",
"6800.55"
), color = c(
"1", "3", "2", "2", "3", "1", "4",
"2", "1", "4", "2", "1", "3"
), customer = c(
"Bob", "Sue",
"Kim", "Janice", "Tim", "Jim", "Sarah", "Pablo", "Erica",
"Juan", "Ted", "Quentin", "Sharon"
), sale_complete = c(
"0",
"2", "0", "2", "0", "2", "1", "0", "0", "0", "0", "0", "2"
)
), row.names = c(
2L, 3L, 4L, 7L, 8L, 10L, 14L, 15L, 16L,
17L, 31L, 32L, 33L
), class = "data.frame"))
)
expect_known_hash(redcap_output_json1, ref_hash)
# expect_snapshot(redcap_output_json1)
# expect_known_hash(redcap_output_json1, ref_hash)
})
test_that("Names are set correctly and output is identical", {
# local_edition(3)
redcap_output_json2 <- REDCap_split(records, metadata, "main")
expect_identical(names(redcap_output_json2), c("main", "sale"))
# expect_known_hash(setNames(redcap_output_json2, c("", "sale")), ref_hash)
expect_known_hash(setNames(redcap_output_json2, c("", "sale")), ref_hash)
# dput(redcap_output_json2)
expect_identical(
redcap_output_json2,
list(main = structure(list(
row = c(
"AMC Javelin", "Cadillac Fleetwood",
"Camaro Z28", "Chrysler Imperial", "Datsun 710", "Dodge Challenger",
"Duster 360", "Ferrari Dino", "Fiat 128", "Fiat X1-9", "Ford Pantera L",
"Honda Civic", "Hornet 4 Drive", "Hornet Sportabout", "Lincoln Continental",
"Lotus Europa", "Maserati Bora", "Mazda RX4", "Mazda RX4 Wag",
"Merc 230", "Merc 240D", "Merc 280", "Merc 280C", "Merc 450SE",
"Merc 450SL", "Merc 450SLC", "Pontiac Firebird", "Porsche 914-2",
"Toyota Corolla", "Toyota Corona", "Valiant", "Volvo 142E"
),
mpg = c(
"15.2", "10.4", "13.3", "14.7", "22.8", "15.5", "14.3",
"19.7", "32.4", "27.3", "15.8", "30.4", "21.4", "18.7", "10.4",
"30.4", "15", "21", "21", "22.8", "24.4", "19.2", "17.8",
"16.4", "17.3", "15.2", "19.2", "26", "33.9", "21.5", "18.1",
"21.4"
), cyl = c(
"8", "8", "8", "8", "4", "8", "8", "6",
"4", "4", "8", "4", "6", "8", "8", "4", "8", "6", "6", "4",
"4", "6", "6", "8", "8", "8", "8", "4", "4", "4", "6", "4"
), disp = c(
"304", "472", "350", "440", "108", "318", "360",
"145", "78.7", "79", "351", "75.7", "258", "360", "460",
"95.1", "301", "160", "160", "140.8", "146.7", "167.6", "167.6",
"275.8", "275.8", "275.8", "400", "120.3", "71.1", "120.1",
"225", "121"
), hp = c(
"150", "205", "245", "230", "93", "150",
"245", "175", "66", "66", "264", "52", "110", "175", "215",
"113", "335", "110", "110", "95", "62", "123", "123", "180",
"180", "180", "175", "91", "65", "97", "105", "109"
), drat = c(
"3.15",
"2.93", "3.73", "3.23", "3.85", "2.76", "3.21", "3.62", "4.08",
"4.08", "4.22", "4.93", "3.08", "3.15", "3", "3.77", "3.54",
"3.9", "3.9", "3.92", "3.69", "3.92", "3.92", "3.07", "3.07",
"3.07", "3.08", "4.43", "4.22", "3.7", "2.76", "4.11"
), wt = c(
"3.435",
"5.25", "3.84", "5.345", "2.32", "3.52", "3.57", "2.77",
"2.2", "1.935", "3.17", "1.615", "3.215", "3.44", "5.424",
"1.513", "3.57", "2.62", "2.875", "3.15", "3.19", "3.44",
"3.44", "4.07", "3.73", "3.78", "3.845", "2.14", "1.835",
"2.465", "3.46", "2.78"
), qsec = c(
"17.3", "17.98", "15.41",
"17.42", "18.61", "16.87", "15.84", "15.5", "19.47", "18.9",
"14.5", "18.52", "19.44", "17.02", "17.82", "16.9", "14.6",
"16.46", "17.02", "22.9", "20", "18.3", "18.9", "17.4", "17.6",
"18", "17.05", "16.7", "19.9", "20.01", "20.22", "18.6"
),
vs = c(
"0", "0", "0", "0", "1", "0", "0", "0", "1", "1",
"0", "1", "1", "0", "0", "1", "0", "0", "0", "1", "1", "1",
"1", "0", "0", "0", "0", "0", "1", "1", "1", "1"
), am = c(
"0",
"0", "0", "0", "1", "0", "0", "1", "1", "1", "1", "1", "0",
"0", "0", "1", "1", "1", "1", "0", "0", "0", "0", "0", "0",
"0", "0", "1", "1", "0", "0", "1"
), gear = c(
"3", "3", "3",
"3", "4", "3", "3", "5", "4", "4", "5", "4", "3", "3", "3",
"5", "5", "4", "4", "4", "4", "4", "4", "3", "3", "3", "3",
"5", "4", "3", "3", "4"
), carb = c(
"2", "4", "4", "4", "1",
"2", "4", "6", "1", "1", "4", "2", "1", "2", "4", "2", "8",
"4", "4", "2", "2", "4", "4", "3", "3", "3", "2", "2", "1",
"1", "1", "2"
), color_available___red = c(
"1", "0", "0",
"0", "0", "0", "0", "0", "0", "0", "0", "0", "0", "0", "0",
"0", "0", "0", "0", "0", "0", "0", "0", "0", "0", "0", "0",
"0", "0", "0", "0", "0"
), color_available___green = c(
"1",
"0", "0", "0", "0", "0", "0", "0", "0", "0", "0", "0", "0",
"0", "0", "0", "0", "0", "0", "0", "0", "0", "0", "0", "0",
"0", "0", "0", "0", "0", "0", "0"
), color_available___blue = c(
"1",
"0", "0", "0", "0", "0", "0", "0", "0", "0", "0", "0", "0",
"0", "0", "0", "0", "0", "0", "0", "0", "0", "0", "0", "0",
"0", "0", "0", "0", "0", "0", "0"
), color_available___black = c(
"0",
"0", "0", "0", "0", "0", "0", "0", "0", "0", "0", "0", "0",
"0", "0", "0", "0", "0", "0", "0", "0", "0", "0", "0", "0",
"0", "0", "0", "0", "0", "0", "0"
), motor_trend_cars_complete = c(
"1",
"0", "0", "0", "0", "0", "0", "0", "0", "0", "0", "0", "0",
"0", "0", "0", "0", "0", "0", "0", "0", "0", "0", "0", "0",
"0", "0", "0", "0", "0", "0", "0"
), letter_group___a = c(
"1",
"0", "1", "0", "0", "0", "0", "0", "0", "0", "0", "0", "0",
"0", "0", "0", "0", "0", "1", "1", "0", "0", "0", "0", "0",
"0", "0", "0", "0", "0", "0", "0"
), letter_group___b = c(
"1",
"0", "0", "1", "1", "0", "1", "0", "0", "0", "0", "0", "0",
"0", "0", "0", "0", "0", "1", "1", "0", "0", "0", "0", "0",
"0", "0", "0", "0", "0", "0", "0"
), letter_group___c = c(
"0",
"0", "1", "1", "1", "0", "1", "0", "0", "0", "0", "0", "0",
"0", "0", "0", "0", "0", "0", "0", "0", "0", "0", "0", "0",
"0", "0", "0", "0", "0", "0", "0"
), choice = c(
"choice2",
"", "choice1", "choice1", "", "", "choice1", "", "", "",
"", "", "", "", "", "", "", "", "", "choice2", "", "", "",
"", "", "", "", "", "", "", "", ""
), grouping_complete = c(
"2",
"0", "2", "2", "0", "0", "1", "0", "0", "0", "0", "0", "0",
"0", "0", "0", "0", "0", "0", "0", "0", "0", "0", "0", "0",
"0", "0", "0", "0", "0", "0", "0"
)
), row.names = c(
1L, 5L,
6L, 9L, 11L, 12L, 13L, 18L, 19L, 20L, 21L, 22L, 23L, 24L, 25L,
26L, 27L, 28L, 29L, 30L, 34L, 35L, 36L, 37L, 38L, 39L, 40L, 41L,
42L, 43L, 44L, 45L
), class = "data.frame"), sale = structure(list(
row = c(
"AMC Javelin", "AMC Javelin", "AMC Javelin", "Camaro Z28",
"Camaro Z28", "Chrysler Imperial", "Duster 360", "Duster 360",
"Duster 360", "Duster 360", "Merc 230", "Merc 230", "Merc 230"
), redcap_repeat_instrument = c(
"sale", "sale", "sale", "sale",
"sale", "sale", "sale", "sale", "sale", "sale", "sale", "sale",
"sale"
), redcap_repeat_instance = c(
"1", "2", "3", "1", "2",
"1", "1", "2", "3", "4", "1", "2", "3"
), price = c(
"12000.50",
"13750.77", "15004.57", "7800.00", "8000.00", "7500.00",
"8756.40", "6800.88", "8888.88", "970.00", "7800.98", "7954.00",
"6800.55"
), color = c(
"1", "3", "2", "2", "3", "1", "4",
"2", "1", "4", "2", "1", "3"
), customer = c(
"Bob", "Sue",
"Kim", "Janice", "Tim", "Jim", "Sarah", "Pablo", "Erica",
"Juan", "Ted", "Quentin", "Sharon"
), sale_complete = c(
"0",
"2", "0", "2", "0", "2", "1", "0", "0", "0", "0", "0", "2"
)
), row.names = c(
2L, 3L, 4L, 7L, 8L, 10L, 14L, 15L, 16L,
17L, 31L, 32L, 33L
), class = "data.frame"))
)
})

16
tests/testthat/test-redcap_wider.R
View file

@ -1,26 +1,25 @@
# library(testthat)
test_that("redcap_wider() returns expected output", {
list <-
list(
dplyr::tibble(
data.frame(
record_id = c(1, 2, 1, 2),
redcap_event_name = c("baseline", "baseline", "followup", "followup"),
age = c(25, 26, 27, 28)
),
dplyr::tibble(
data.frame(
record_id = c(1, 2),
redcap_event_name = c("baseline", "baseline"),
sex = c("male", "female")
gender = c("male", "female")
)
)
expect_equal(
redcap_wider(list),
dplyr::tibble(
data.frame(
record_id = c(1, 2),
age____baseline = c(25, 26),
age____followup = c(27, 28),
sex = c("male", "female")
age_baseline = c(25, 26),
age_followup = c(27, 28),
gender = c("male", "female")
)
)
})
@ -29,7 +28,6 @@ test_that("redcap_wider() returns expected output", {
# Using test data
# Set up the path and data -------------------------------------------------
file_paths <- lapply(
c(records = "WARRIORtestForSoftwa_DATA_2018-06-21_1431.csv",
metadata = "WARRIORtestForSoftwareUpgrades_DataDictionary_2018-06-21.csv"),

4
vignettes/Database-creation.Rmd
View file

@ -32,7 +32,7 @@ In the following I will try to come with a few suggestions on how to use these a
The first iteration of a dataset to data dictionary function is the `ds2dd()`, which creates a very basic data dictionary with all variables stored as text. This is sufficient for just storing old datasets/spreadsheets securely in REDCap.
```{r eval=FALSE}
```{r eval=TRUE}
d1 <- mtcars |>
dplyr::mutate(record_id = seq_len(dplyr::n())) |>
ds2dd()
@ -45,7 +45,7 @@ The more advanced `ds2dd_detailed()` is a natural development. It will try to ap
The dataset should be correctly formatted for the data dictionary to preserve as much information as possible.
```{r eval=FALSE}
```{r eval=TRUE}
d2 <- REDCapCAST::redcapcast_data |>
dplyr::mutate(record_id = seq_len(dplyr::n()),
region=factor(region)) |>

Some files were not shown because too many files have changed in this diff Show more