Compare commits

..

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

68 changed files with 559 additions and 1981 deletions

View file

@ -16,8 +16,7 @@
^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$

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

2
.gitignore vendored
View file

@ -13,5 +13,3 @@ drafting
cran-comments.md
~/REDCapCAST/inst/shiny-examples/casting/rsconnect
~/REDCapCAST/inst/shiny-examples/casting/rsconnect/
inst/shiny-examples/casting/functions.R
functions.R

3
CRAN-SUBMISSION Normal file
View file

@ -0,0 +1,3 @@
Version: 24.11.2
Date: 2024-11-22 12:08:45 UTC
SHA: a8f8fac245b06fef4a5e191d046bc4e9a345bf2b

View file

@ -1,6 +1,6 @@
Package: REDCapCAST
Title: REDCap Metadata Casting and Castellated Data Handling
Version: 25.3.2
Version: 24.11.3
Authors@R: c(
person("Andreas Gammelgaard", "Damsbo", email = "agdamsbo@clin.au.dk",
role = c("aut", "cre"),comment = c(ORCID = "0000-0002-7559-1154")),
@ -21,7 +21,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,
@ -33,9 +33,7 @@ Suggests:
devtools,
roxygen2,
spelling,
rhub,
rsconnect,
pkgconfig
rhub
License: GPL (>= 3)
Encoding: UTF-8
LazyData: true
@ -51,33 +49,29 @@ Imports:
purrr,
readr,
stats,
shiny,
haven,
zip,
assertthat,
openxlsx2,
readODS,
forcats,
vctrs,
gt,
bslib,
here,
glue,
gtsummary,
shiny,
haven,
openxlsx2,
readODS
Language: en-US
VignetteBuilder: knitr
glue
Collate:
'REDCapCAST-package.R'
'utils.r'
'process_user_input.r'
'REDCap_split.r'
'as_factor.R'
'as_logical.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 +80,5 @@ Collate:
'redcapcast_data.R'
'redcapcast_meta.R'
'shiny_cast.R'
Language: en-US
VignetteBuilder: knitr

View file

@ -1,37 +1,27 @@
# 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)
@ -39,10 +29,8 @@ 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)
@ -50,14 +38,12 @@ 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)
@ -69,23 +55,17 @@ export(set_attr)
export(shiny_cast)
export(split_non_repeating_forms)
export(strsplitx)
export(suffix2label)
export(var2fct)
export(vec2choice)
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)

38
NEWS.md
View file

@ -1,39 +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.
@ -185,7 +149,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()`.

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 <-

View file

@ -1,17 +1,14 @@
#' Convert labelled vectors to factors while preserving attributes
#'
#' This extends \link[forcats]{as_factor} as well as \link[haven]{as_factor}, by appending
#' This extends [forcats::as_factor()] as well as [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
@ -19,21 +16,13 @@
#' structure(c(1, 2, 3, 2, 10, 9),
#' labels = c(Unknown = 9, Refused = 10)
#' ) |>
#' as_factor() |>
#' dput()
#' 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()
#'
#' as_factor()
#' @importFrom forcats as_factor
#' @export
#' @name as_factor
@ -67,13 +56,13 @@ as_factor.numeric <- function(x, ...) {
#' @export
as_factor.character <- function(x, ...) {
labels <- get_attr(x)
if (possibly_roman(x)) {
if (possibly_roman(x)){
x <- factor(x)
} else {
x <- structure(
forcats::fct_inorder(x),
label = attr(x, "label", exact = TRUE)
)
x <- structure(
forcats::fct_inorder(x),
label = attr(x, "label", exact = TRUE)
)
}
set_attr(x, labels, overwrite = FALSE)
}
@ -128,53 +117,13 @@ as_factor.haven_labelled <- function(x, levels = c("default", "labels", "values"
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
}
set_attr(x, labels_all, overwrite = FALSE)
}
#' @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))
@ -208,25 +157,20 @@ replace_with <- function(x, from, to) {
#' @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
#' \dontrun{
#' 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) {
#' }
named_levels <- function(data, label = "labels", na.label = NULL, na.value = 99) {
stopifnot(is.factor(data))
if (!is.null(na.label)) {
attrs <- attributes(data)
@ -259,7 +203,7 @@ named_levels <- function(data, label = "labels", na.label = NULL, na.value = 99,
}
# Handle empty factors
if (all_na(data)) {
if (all_na(data)){
d <- data.frame(
name = levels(data),
value = seq_along(levels(data))
@ -269,21 +213,15 @@ named_levels <- function(data, label = "labels", na.label = NULL, na.value = 99,
name = levels(data)[data],
value = as.numeric(data)
) |>
unique() |>
stats::na.omit()
unique()
}
## Applying labels
attr_l <- attr(x = data, which = label, exact = TRUE)
if (length(attr_l) != 0) {
if (all(names(attr_l) %in% d$name)) {
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 {
}else {
d$name[match(attr_l, d$name)] <- names(attr_l)
d$value[match(names(attr_l), d$name)] <- unname(attr_l)
}
@ -292,7 +230,7 @@ named_levels <- function(data, label = "labels", na.label = NULL, na.value = 99,
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) {
if (possibly_numeric(levels(data))) {
out <- out |> sort()
}
out
@ -306,17 +244,13 @@ named_levels <- function(data, label = "labels", na.label = NULL, na.value = 99,
#' @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))))
#' 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){
# browser()
if (all(is.na(data))) return(FALSE)
identical(as.character(data),as.character(utils::as.roman(data)))
}
@ -346,15 +280,20 @@ possibly_roman <- function(data) {
#' as_factor() |>
#' fct2num()
#'
#' structure(c(1, 2, 3, 2, 10, 9),
#' labels = c(Unknown = 9, Refused = 10)
#' ) |>
#' as_factor() |>
#' fct2num()
#' # Outlier with labels, but no class of origin, handled like numeric vector
#' # structure(c(1, 2, 3, 2, 10, 9),
#' # labels = c(Unknown = 9, Refused = 10)
#' # ) |>
#' # as_factor() |>
#' # fct2num()
#'
#' v <- sample(6:19,20,TRUE) |> factor()
#' dput(v)
#' named_levels(v)
#' fct2num(v)
fct2num <- function(data) {
stopifnot(is.factor(data))
if (is.character(named_levels(data))) {
if (is.character(named_levels(data))){
values <- as.numeric(named_levels(data))
} else {
values <- named_levels(data)
@ -364,28 +303,15 @@ fct2num <- function(data) {
## If no NA on numeric coercion, of original names, then return
## original numeric names, else values
if (possibly_numeric(names(out))) {
if (possibly_numeric(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))) ==
possibly_numeric <- function(data){
length(stats::na.omit(suppressWarnings(as.numeric(names(data))))) ==
length(data)
)
}
#' Extract attribute. Returns NA if none
@ -443,6 +369,7 @@ set_attr <- function(data, label, attr = NULL, overwrite = FALSE) {
label <- label[!names(label) %in% names(attributes(data))]
}
attributes(data) <- c(attributes(data), label)
} else {
attr(data, attr) <- label
}

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
}

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
}

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
@ -224,7 +134,7 @@ 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).
#' REDCapCAST:::metadata_names.
#' @param convert.logicals convert logicals to factor. Default is TRUE.
#'
#' @return list of length 2
@ -232,8 +142,7 @@ ds2dd <-
#'
#' @examples
#' ## Basic parsing with default options
#' requireNamespace("REDCapCAST")
#' redcapcast_data |>
#' REDCapCAST::redcapcast_data |>
#' dplyr::select(-dplyr::starts_with("redcap_")) |>
#' ds2dd_detailed()
#'
@ -247,10 +156,7 @@ ds2dd <-
#' 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)
#' mtcars |> ds2dd_detailed(add.auto.id = TRUE)
#'
#' ## Using column name suffix to carry form name
#' data <- iris |>
@ -270,21 +176,19 @@ 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)
convert.logicals = TRUE) {
# Repair empty columns
# These where sometimes classed as factors or
# if (any(sapply(data,all_na))){
# data <- data |>
# ## Converts logical to factor, which overwrites attributes
# dplyr::mutate(dplyr::across(dplyr::where(all_na), as.character))
# }
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
}
## Handles the odd case of no id column present
@ -306,6 +210,7 @@ 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)
@ -324,14 +229,11 @@ ds2dd_detailed <- function(data,
dd$field_name <- tolower(dd$field_name)
} 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 {
## 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))
dd$field_name <- gsub(" ", "_", tolower(colnames(data)))
if (is.null(form.name)) {
dd$form_name <- "data"
@ -378,14 +280,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
@ -444,14 +341,7 @@ ds2dd_detailed <- function(data,
out <- list(
data = data |>
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
)
@ -467,8 +357,8 @@ ds2dd_detailed <- function(data,
#' @export
#'
#' @examples
#' rep(NA, 4) |> all_na()
all_na <- function(data) {
#' rep(NA,4) |> all_na()
all_na <- function(data){
all(is.na(data))
}
@ -671,7 +561,7 @@ numchar2fct <- function(data, numeric.threshold = 6, character.throshold = 6) {
#' sort() |>
#' vec2choice()
vec2choice <- function(data) {
compact_vec(data, nm.sep = ", ", val.sep = " | ")
compact_vec(data,nm.sep = ", ",val.sep = " | ")
}
#' Compacting a vector of any length with or without names
@ -692,7 +582,8 @@ vec2choice <- function(data) {
#' 1:6 |> compact_vec()
#' "test" |> compact_vec()
#' sample(letters[1:9], 20, TRUE) |> compact_vec()
compact_vec <- function(data, nm.sep = ": ", val.sep = "; ") {
compact_vec <- function(data,nm.sep=": ",val.sep="; ") {
# browser()
if (all(is.na(data))) {
return(data)
}

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
}

View file

@ -17,7 +17,7 @@
#' @export
#'
#' @examples
#' # iris |>
#' #iris |>
#' # ds2dd_detailed(
#' # add.auto.id = TRUE,
#' # form.name = sample(c("b", "c"), size = 6, replace = TRUE, prob = rep(.5, 2))
@ -30,7 +30,7 @@
#' # export_redcap_instrument(.x,file=here::here(paste0(.i,Sys.Date(),".zip")))
#' # })
#'
#' # iris |>
#' #iris |>
#' # ds2dd_detailed(
#' # add.auto.id = TRUE
#' # ) |>
@ -38,18 +38,18 @@
#' # export_redcap_instrument(file=here::here(paste0("instrument",Sys.Date(),".zip")))
export_redcap_instrument <- function(data,
file,
force = FALSE,
force=FALSE,
record.id = "record_id") {
# Ensure form name is the same
if (force) {
if (force){
data$form_name <- data$form_name[1]
} else if (length(unique(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"]]), ]
if (!is.na(record.id) && record.id %in% data[["field_name"]]){
data <- data[-match(record.id,data[["field_name"]]),]
}
temp_dir <- tempdir()
@ -82,7 +82,6 @@ export_redcap_instrument <- function(data,
#' @export
#'
#' @examples
#' \dontrun{
#' data <- iris |>
#' ds2dd_detailed(
#' add.auto.id = TRUE,
@ -101,10 +100,9 @@ export_redcap_instrument <- function(data,
#' 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)
#' }
#' # data |>
#' # purrr::pluck("meta") |>
#' # create_instrument_meta(record.id = FALSE)
create_instrument_meta <- function(data,
dir = here::here(""),
record.id = TRUE) {

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, ...)
}

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)
}

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()
}

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{

View file

@ -47,12 +47,6 @@ 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", '""', "")) {
@ -61,15 +55,15 @@ read_input <- function(file, consider.na = c("NA", '""', "")) {
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)
df <- readODS::read_ods(path = file)
} else if (ext == "rds") {
df <- read_rds(file = file)
df <- readr::read_rds(file = file)
}else {
stop("Input file format has to be on of:
'.csv', '.xls', '.xlsx', '.dta', '.ods' or '.rds'")

Binary file not shown.

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
}
}

View file

@ -1,6 +1,7 @@
<!-- 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"/>

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

View file

@ -1,10 +1,8 @@
── R CMD check results ───────────────────────────────────────────────────────────────────────────────── REDCapCAST 25.3.2 ────
Duration: 37.1s
── R CMD check results ─────────────────────────────────────────────────────────────────────────────── REDCapCAST 24.11.1 ────
Duration: 23.8s
0 errors ✔ | 0 warnings ✔ | 0 notes ✔
R CMD check succeeded
## Test environments
Rhubv2 runs and checks out.

View file

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

View file

@ -5,21 +5,22 @@ Codecov
DEPRICATED
DOI
DataDictionary
GStat
Gammelgaard
Github
GithubActions
JSON
Lifecycle
METACRAN
MMRM
Nav
ORCID
POSIXct
Pivotting
README
REDCap
REDCapR
REDCapRITS
REDCapTidieR
Stackoverflow
WD
al
api
@ -40,8 +41,6 @@ dmy
docx
doi
dplyr
dropdown
droplevels
ds
dta
et
@ -50,7 +49,6 @@ factorising
fct
forcats
github
gtsummary
gues
hms
https
@ -61,6 +59,7 @@ labelled
labelling
mRS
matadata
md
mdy
mis
mrs
@ -70,7 +69,6 @@ natively
ncol
og
param
params
pegeler
perl
pos
@ -79,7 +77,6 @@ rds
readr
realising
redcapAPI
redcapcast
renv
runApp
sel

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)

View file

@ -1,10 +1,10 @@
name: redcapcast-dev
name: redcapcast-latest
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/
appId: 13442058
bundleId: 9412341
url: https://agdamsbo.shinyapps.io/redcapcast-latest/
version: 1

View file

@ -5,6 +5,6 @@ account: agdamsbo
server: shinyapps.io
hostUrl: https://api.shinyapps.io/v1
appId: 11351429
bundleId: 9642648
bundleId: 9412329
url: https://agdamsbo.shinyapps.io/redcapcast/
version: 1

View file

@ -0,0 +1,180 @@
library(bslib)
library(shiny)
library(openxlsx2)
library(haven)
library(readODS)
library(readr)
library(dplyr)
library(devtools)
if (!requireNamespace("REDCapCAST")) {
devtools::install_github("agdamsbo/REDCapCAST", quiet = TRUE, upgrade = "never")
}
library(REDCapCAST)
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
)
)
}
out
})
# 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"
)
})
output$uploaded <- shiny::reactive({
if (is.null(v$file)) {
"no"
} else {
"yes"
}
})
shiny::outputOptions(output, "uploaded", suspendWhenHidden = FALSE)
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 <- 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)
# session$onSessionEnded(function() {
# # cat("Session Ended\n")
# unlink("www",recursive = TRUE)
# })
}

View file

@ -0,0 +1,7 @@
library(REDCapCAST)
ui <-
bslib::page(
theme = bslib::bs_theme(preset = "united"),
title = "REDCap database creator",
REDCapCAST::nav_bar_page()
)

View file

@ -4,8 +4,10 @@
\name{REDCapCAST-package}
\alias{REDCapCAST}
\alias{REDCapCAST-package}
\title{REDCapCAST: REDCap Metadata Casting and Castellated Data Handling}
\title{REDCapCAST: REDCap Castellated Data Handling and Metadata Casting}
\description{
\if{html}{\figure{logo.png}{options: style='float: right' alt='logo' width='120'}}
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{

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
}

View file

@ -16,5 +16,5 @@ logical
Check if vector is all NA
}
\examples{
rep(NA, 4) |> all_na()
rep(NA,4) |> all_na()
}

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
}

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
}

View file

@ -8,7 +8,6 @@
\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, ...)
@ -34,8 +33,6 @@ as_factor(x, ...)
ordered = FALSE,
...
)
\method{as_factor}{data.frame}(x, ..., only_labelled = TRUE)
}
\arguments{
\item{x}{Object to coerce to a factor.}
@ -52,19 +49,15 @@ as_factor(x, ...)
\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
This extends [forcats::as_factor()] as well as [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
@ -72,19 +65,11 @@ 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()
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()
as_factor()
}

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)
}

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>")
}

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()
}

View file

@ -26,7 +26,6 @@ function can be used to create (an) instrument(s) to add to a project in
production.
}
\examples{
\dontrun{
data <- iris |>
ds2dd_detailed(
add.auto.id = TRUE,
@ -45,8 +44,7 @@ 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)
}
# data |>
# purrr::pluck("meta") |>
# create_instrument_meta(record.id = FALSE)
}

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)
}

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)
}

View file

@ -16,7 +16,7 @@ ds2dd_detailed(
field.label.attr = "label",
field.validation = NULL,
metadata = names(REDCapCAST::redcapcast_meta),
convert.logicals = FALSE
convert.logicals = TRUE
)
}
\arguments{
@ -55,7 +55,7 @@ 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.}
}
@ -76,8 +76,7 @@ Ensure, that the data set is formatted with as much information as possible.
}
\examples{
## Basic parsing with default options
requireNamespace("REDCapCAST")
redcapcast_data |>
REDCapCAST::redcapcast_data |>
dplyr::select(-dplyr::starts_with("redcap_")) |>
ds2dd_detailed()
@ -91,10 +90,7 @@ iris |>
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)
mtcars |> ds2dd_detailed(add.auto.id = TRUE)
## Using column name suffix to carry form name
data <- iris |>

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"))
}
}

View file

@ -27,7 +27,7 @@ function can be used to create (an) instrument(s) to add to a project in
production.
}
\examples{
# iris |>
#iris |>
# ds2dd_detailed(
# add.auto.id = TRUE,
# form.name = sample(c("b", "c"), size = 6, replace = TRUE, prob = rep(.5, 2))
@ -40,7 +40,7 @@ production.
# export_redcap_instrument(.x,file=here::here(paste0(.i,Sys.Date(),".zip")))
# })
# iris |>
#iris |>
# ds2dd_detailed(
# add.auto.id = TRUE
# ) |>

View file

@ -34,9 +34,15 @@ structure(c(1, 2, 3, 2, 10, 9),
as_factor() |>
fct2num()
structure(c(1, 2, 3, 2, 10, 9),
labels = c(Unknown = 9, Refused = 10)
) |>
as_factor() |>
fct2num()
# Outlier with labels, but no class of origin, handled like numeric vector
# structure(c(1, 2, 3, 2, 10, 9),
# labels = c(Unknown = 9, Refused = 10)
# ) |>
# as_factor() |>
# fct2num()
v <- sample(6:19,20,TRUE) |> factor()
dput(v)
named_levels(v)
fct2num(v)
}

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

Binary file not shown.

After

Width:  |  Height:  |  Size: 9.8 KiB

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

Binary file not shown.

After

Width:  |  Height:  |  Size: 8.6 KiB

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")
}

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
}

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()
}

View file

@ -4,13 +4,7 @@
\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
)
named_levels(data, label = "labels", na.label = NULL, na.value = 99)
}
\arguments{
\item{data}{factor}
@ -21,8 +15,6 @@ named_levels(
\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
@ -31,16 +23,12 @@ named vector
Get named vector of factor levels and values
}
\examples{
\dontrun{
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()
}
}

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()
}

View file

@ -16,9 +16,7 @@ logical
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()
sample(1:100,10) |> as.roman() |> possibly_roman()
sample(c(TRUE,FALSE),10,TRUE)|> possibly_roman()
rep(NA,10)|> possibly_roman()
}

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

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)
}

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}

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.

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
}

View file

@ -187,22 +187,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",
@ -472,25 +456,6 @@
],
"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"
},
"haven": {
"Package": "haven",
"Version": "2.5.4",

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
))
)
})

View file

@ -1,20 +1,9 @@
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")
expect_equal(ncol(ds2dd(mtcars, record.id = "id")), 18)
expect_s3_class(ds2dd(mtcars, record.id = "id"), "data.frame")
expect_s3_class(ds2dd(mtcars, record.id = 12), "data.frame")
})
@ -22,19 +11,19 @@ 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()
include.column.names = TRUE
)), 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()))
expect_error(ds2dd(mtcars))
expect_error(ds2dd(mtcars, form.name = c("basis", "incl")))
expect_error(ds2dd(mtcars, field.type = c("text", "dropdown")))
expect_error(ds2dd(mtcars, field.label = c("Name", "Age")))
})
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")
expect_equal(ncol(ds2dd(mtcars, record.id = "id")), 18)
expect_s3_class(ds2dd(mtcars, record.id = "id"), "data.frame")
})

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"),

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()

View file

@ -18,46 +18,12 @@ knitr::opts_chunk$set(
library(REDCapCAST)
```
This vignette covers the basics to get you started with the two basic features of REDCapCAST:
This vignette covers the included functions and basic functionality.
- Casting REDCap metadata to create a new REDCap database or extend an existing with a new instrument
- Reading REDCap data in a convenient and focused way, by only getting the data you need, while preserving as much metadata as possible.
## Casting meta data
The easiest way is to use the `shiny_cast()`. You can access a [hosted version here](https://agdamsbo.shinyapps.io/redcapcast/) or launch it locally like this:
```{r eval=FALSE}
shiny_cast()
```
## Reading data from REDCap
To get you started, the easiest way possible, you can use the `easy_redcap()` function (example below).
You will need an API-key for your REDCap server, the uri/URL/address for the API connection (usually the address used for accessing your institutions REDCap server, with an appended "/api/").
This function includes a few convenience features to ease your further work.
If your project uses repeating instruments possible as a longitudinal project, you can choose to widen the data. If not, the result will be a list of each instrument you have chosen to extract data from. Make sure to specify only the fields or instruments you need, and avoid to save any of the data locally, but always source from REDCap to avoid possibly insecure local storage of sensitive data.
```{r eval=FALSE}
easy_redcap(
uri = "YOUR URI",
project.name = "MY_PROJECT",
widen.data = TRUE,
fields = c("record_id", "OTHER FIELDS")
)
```
A dataset and a meta data file are provided with the package for demonstration of the functions.
## Splitting the dataset
The `easy_redcap()` function does a few things under the hood. Below are a few examples to show how the nicely formatted output is achieved.
A sample dataset and Data Dictionary/metadata is provided for this demonstration:
```{r}
redcapcast_data |> gt::gt()
```
@ -66,52 +32,29 @@ redcapcast_data |> gt::gt()
redcapcast_meta |> gt::gt()
```
To save the metadata as labels in the dataset, we can save field labels and the choices from radio buttons and dropdown features:
```{r}
labelled_data <-
apply_field_label(
data = redcapcast_data,
meta = redcapcast_meta
) |>
apply_factor_labels(meta = redcapcast_meta)
```
The `REDCap_split` function splits the data set into a list of data.frames.
```{r}
list <-
REDCap_split(
records = labelled_data,
records = redcapcast_data,
metadata = redcapcast_meta,
forms = "all"
) |>
# Next steps cleans up and removes generic columns
) |>
sanitize_split()
str(list)
```
The `easy_redcap()` will then (optionally) continue to widen the data, by transforming the list of data.frames to a single data.frame with one row for each subject/record_id (wide data format):
## Reading data from REDCap
```{r}
wide_data <- redcap_wider(list,
event.glue = "{.value}____{redcap_event_name}",
inst.glue = "{.value}____{redcap_repeat_instance}"
)
wide_data |> str()
This function wraps all the above demonstrated function to get the dataset, the metadata, apply the `REDCap_split`function and then a bit of cleaning. It just cuts outs all the steps for an easier approach.
The function works very similar to the `REDCapR::redcap_read()` in allowing to specify fields, events and forms for export instead of exporting the whole database and filtering afterwards. I believe this is a better and safer, focused approach.
```{r eval=FALSE}
# read_redcap_tables(uri = "YOUR URI", token = "YOUR TOKEN")
```
Transfer suffixes to labels:
## Pivotting to wider format
```{r}
wide_data_suffixes <- wide_data |> suffix2label()
```
## Creating a nice table
```{r}
wide_data_suffixes |>
as_factor()|>
dplyr::select(sex, hypertension, diabetes,mrs_score____follow2) |>
gtsummary::tbl_summary(type = gtsummary::all_dichotomous() ~ "categorical")
redcap_wider(list) |> str()
```

View file

@ -36,14 +36,14 @@ str(ds)
```{r}
ds|>
ds2dd_detailed(metadata = names(REDCapCAST::redcapcast_meta))|>
ds2dd_detailed()|>
purrr::pluck("data") |>
str()
```
```{r}
ds|>
ds2dd_detailed(metadata = names(REDCapCAST::redcapcast_meta))|>
ds2dd_detailed()|>
purrr::pluck("meta") |>
head(10)
```