new comment on build

.Rbuildignore

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

.github/workflows/test-coverage.yaml

@@ -4,9 +4,10 @@ on:
   push:
     branches: [main, master]
   pull_request:
-    branches: [main, master]
 
-name: test-coverage
+name: test-coverage.yaml
+
+permissions: read-all
 
 jobs:
   test-coverage:
@@ -15,38 +16,47 @@ jobs:
       GITHUB_PAT: ${{ secrets.GITHUB_TOKEN }}
 
     steps:
-      - uses: actions/checkout@v3
+      - uses: actions/checkout@v4
 
       - 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
+          extra-packages: any::covr, any::xml2
           needs: coverage
 
       - name: Test coverage
         run: |
-          covr::codecov(
+          cov <- covr::package_coverage(
             quiet = FALSE,
             clean = FALSE,
-            install_path = file.path(Sys.getenv("RUNNER_TEMP"), "package")
+            install_path = file.path(normalizePath(Sys.getenv("RUNNER_TEMP"), winslash = "/"), "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@v3
+        uses: actions/upload-artifact@v4
         with:
           name: coverage-test-failures
           path: ${{ runner.temp }}/package

.gitignore

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

CRAN-SUBMISSION

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

DESCRIPTION

@@ -1,6 +1,6 @@
 Package: REDCapCAST
 Title: REDCap Metadata Casting and Castellated Data Handling
-Version: 24.11.3
+Version: 25.3.2
 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 (>= 3.4.0)
+Depends: R (>= 4.1.0)
 Suggests:
     httr,
     jsonlite,
@@ -33,7 +33,9 @@ Suggests:
     devtools,
     roxygen2,
     spelling,
-    rhub
+    rhub,
+    rsconnect,
+    pkgconfig
 License: GPL (>= 3)
 Encoding: UTF-8
 LazyData: true
@@ -49,29 +51,33 @@ Imports:
     purrr,
     readr,
     stats,
-    shiny,
-    haven,
     zip,
     assertthat,
-    openxlsx2,
-    readODS,
     forcats,
     vctrs,
     gt,
     bslib,
     here,
-    glue
+    glue,
+    gtsummary,
+    shiny,
+    haven,
+    openxlsx2,
+    readODS
+Language: en-US
+VignetteBuilder: knitr
 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'
@@ -80,5 +86,3 @@ Collate:
     'redcapcast_data.R'
     'redcapcast_meta.R'
     'shiny_cast.R'
-Language: en-US
-VignetteBuilder: knitr

NAMESPACE

@@ -1,27 +1,37 @@
 # 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)
@@ -29,8 +39,10 @@ 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)
@@ -38,12 +50,14 @@ 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)
@@ -55,17 +69,23 @@ 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)

NEWS.md

@@ -1,3 +1,39 @@
+# 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.
@@ -149,7 +185,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::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.
+* `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.
 
 * `redcap_wider()` **NEW**: this function pivots the long data frames from `read_redcap_tables()` using `tidyr::pivot_wider()`.
 

R/REDCap_split.r

@@ -11,11 +11,10 @@
 #'   \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 (as described in \emph{README.md}). Ignored if
-#'   \code{forms = 'all'}.
+#'   output table. 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, M.S., GStat
+#' @author Paul W. Egeler
 #' @examples
 #' \dontrun{
 #' # Using an API call -------------------------------------------------------
@@ -40,7 +39,7 @@
 #' )
 #'
 #' # Convert exported JSON strings into a list of data.frames
-#' REDCapRITS::REDCap_split(records, metadata)
+#' REDCapCAST::REDCap_split(records, metadata)
 #'
 #' # Using a raw data export -------------------------------------------------
 #'
@@ -53,7 +52,7 @@
 #' )
 #'
 #' # Split the tables
-#' REDCapRITS::REDCap_split(records, metadata)
+#' REDCapCAST::REDCap_split(records, metadata)
 #'
 #' # In conjunction with the R export script ---------------------------------
 #'
@@ -70,7 +69,7 @@
 #' metadata <- read.csv("ExampleProject_DataDictionary_2018-06-03.csv")
 #'
 #' # Split the tables
-#' REDCapRITS::REDCap_split(data, metadata)
+#' REDCapCAST::REDCap_split(data, metadata)
 #' setwd(old)
 #' }
 #' @return A list of \code{"data.frame"}s. The number of tables will differ
@@ -87,6 +86,11 @@ 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 <-

R/as_factor.R

@@ -1,14 +1,17 @@
 #' Convert labelled vectors to factors while preserving attributes
 #'
-#' This extends [forcats::as_factor()] as well as [haven::as_factor()], by appending
+#' This extends \link[forcats]{as_factor} as well as \link[haven]{as_factor}, by appending
 #' original attributes except for "class" after converting to factor to avoid
 #' ta loss in case of rich formatted and labelled data.
 #'
 #' Please refer to parent functions for extended documentation.
 #' To avoid redundancy calls and errors, functions are copy-pasted here
 #'
+#' Empty variables with empty levels attribute are interpreted as logicals
+#'
 #' @param x Object to coerce to a factor.
 #' @param ... Other arguments passed down to method.
+#' @param only_labelled Only apply to labelled columns?
 #' @export
 #' @examples
 #' # will preserve all attributes
@@ -16,13 +19,21 @@
 #' 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()
+#'   as_factor() |> class()
+#' structure(rep(NA,10),
+#'   class = c("labelled")
+#' ) |>
+#'   as_factor() |> summary()
+#'
+#' rep(NA,10) |> as_factor()
+#'
 #' @importFrom forcats as_factor
 #' @export
 #' @name as_factor
@@ -56,13 +67,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)
 }
@@ -117,13 +128,53 @@ as_factor.haven_labelled <- function(x, levels = c("default", "labels", "values"
 
   x <- structure(x, label = label)
 
-  set_attr(x, labels_all, overwrite = FALSE)
+  out <- set_attr(x, labels_all, overwrite = FALSE)
+
+  if (all_na(out) & length(levels(out))==0){
+    as_factor.logical(out)
+  } else {
+    out
+  }
 }
 
 #' @export
 #' @rdname as_factor
 as_factor.labelled <- as_factor.haven_labelled
 
+#' @rdname as_factor
+#' @export
+as_factor.data.frame <- function(x, ..., only_labelled = TRUE) {
+  if (only_labelled) {
+    labelled <- vapply(x, is.labelled, logical(1))
+    x[labelled] <- lapply(x[labelled], as_factor, ...)
+  } else {
+    x[] <- lapply(x, as_factor, ...)
+  }
+
+  x
+}
+
+#' Tests for multiple label classes
+#'
+#' @param x data
+#' @param classes classes to test
+#'
+#' @return logical
+#' @export
+#'
+#' @examples
+#' structure(c(1, 2, 3, 2, 10, 9),
+#'   labels = c(Unknown = 9, Refused = 10),
+#'   class = "haven_labelled"
+#' ) |> is.labelled()
+is.labelled <- function(x, classes = c("haven_labelled", "labelled")) {
+  classes |>
+    sapply(\(.class){
+      inherits(x, .class)
+    }) |>
+    any()
+}
+
 replace_with <- function(x, from, to) {
   stopifnot(length(from) == length(to))
 
@@ -157,20 +208,25 @@ 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()
-#' }
-named_levels <- function(data, label = "labels", na.label = NULL, na.value = 99) {
+#' structure(c(1, 2, 3, 2, 10, 9),
+#'   labels = c(Unknown = 9, Refused = 10),
+#'   class = "labelled"
+#' ) |>
+#'   as_factor() |>
+#'   named_levels()
+named_levels <- function(data, label = "labels", na.label = NULL, na.value = 99, sort.numeric=TRUE) {
   stopifnot(is.factor(data))
   if (!is.null(na.label)) {
     attrs <- attributes(data)
@@ -203,7 +259,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))
@@ -213,15 +269,21 @@ named_levels <- function(data, label = "labels", na.label = NULL, na.value = 99)
       name = levels(data)[data],
       value = as.numeric(data)
     ) |>
-      unique()
+      unique() |>
+      stats::na.omit()
   }
 
   ## Applying labels
   attr_l <- attr(x = data, which = label, exact = TRUE)
   if (length(attr_l) != 0) {
-    if (all(names(attr_l) %in% d$name)){
+    if (all(names(attr_l) %in% d$name)) {
       d$value[match(names(attr_l), d$name)] <- unname(attr_l)
-    }else {
+    } else if (all(d$name %in% names(attr_l)) && nrow(d) < length(attr_l)) {
+      d <- data.frame(
+        name = names(attr_l),
+        value = unname(attr_l)
+      )
+    } else {
       d$name[match(attr_l, d$name)] <- names(attr_l)
       d$value[match(names(attr_l), d$name)] <- unname(attr_l)
     }
@@ -230,7 +292,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))) {
+  if (possibly_numeric(levels(data)) && sort.numeric) {
     out <- out |> sort()
   }
   out
@@ -244,13 +306,17 @@ 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){
-  # browser()
-  if (all(is.na(data))) return(FALSE)
-  identical(as.character(data),as.character(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) {
+  if (all(is.na(data))) {
+    return(FALSE)
+  }
+  identical(as.character(data),
+            as.character(suppressWarnings(utils::as.roman(data))))
 }
 
 
@@ -280,20 +346,15 @@ possibly_roman <- function(data){
 #'   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)
+#' structure(c(1, 2, 3, 2, 10, 9),
+#'   labels = c(Unknown = 9, Refused = 10)
+#' ) |>
+#'   as_factor() |>
+#'   fct2num()
 fct2num <- function(data) {
   stopifnot(is.factor(data))
-  if (is.character(named_levels(data))){
+
+  if (is.character(named_levels(data))) {
     values <- as.numeric(named_levels(data))
   } else {
     values <- named_levels(data)
@@ -303,15 +364,28 @@ fct2num <- function(data) {
 
   ## If no NA on numeric coercion, of original names, then return
   ## original numeric names, else values
-  if (possibly_numeric(out)) {
+  if (possibly_numeric(names(out))) {
     out <- as.numeric(names(out))
   }
   unname(out)
 }
 
-possibly_numeric <- function(data){
-  length(stats::na.omit(suppressWarnings(as.numeric(names(data))))) ==
+#' Tests if vector can be interpreted as numeric without introducing NAs by
+#' coercion
+#'
+#' @param data vector
+#'
+#' @return logical
+#' @export
+#'
+#' @examples
+#' c("1","5") |> possibly_numeric()
+#' c("1","5","e") |> possibly_numeric()
+possibly_numeric <- function(data) {
+  suppressWarnings(
+  length(stats::na.omit(as.numeric(data))) ==
     length(data)
+  )
 }
 
 #' Extract attribute. Returns NA if none
@@ -369,7 +443,6 @@ 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
   }

R/as_logical.R

@@ -0,0 +1,116 @@
+#' 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
+}

R/ds2dd.R

@@ -1,89 +0,0 @@
-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
-  }
-
-

R/ds2dd_detailed.R

@@ -1,5 +1,4 @@
 utils::globalVariables(c(
-  "stats::setNames",
   "field_name",
   "field_type",
   "select_choices_or_calculations",
@@ -98,6 +97,97 @@ 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
@@ -134,7 +224,7 @@ hms2character <- function(data) {
 #' or attribute `factor.labels.attr` for haven_labelled data set (imported .dta
 #' file with `haven::read_dta()`).
 #' @param metadata redcap metadata headings. Default is
-#' REDCapCAST:::metadata_names.
+#' names(REDCapCAST::redcapcast_meta).
 #' @param convert.logicals convert logicals to factor. Default is TRUE.
 #'
 #' @return list of length 2
@@ -142,7 +232,8 @@ hms2character <- function(data) {
 #'
 #' @examples
 #' ## Basic parsing with default options
-#' REDCapCAST::redcapcast_data |>
+#' requireNamespace("REDCapCAST")
+#' redcapcast_data |>
 #'   dplyr::select(-dplyr::starts_with("redcap_")) |>
 #'   ds2dd_detailed()
 #'
@@ -156,7 +247,10 @@ hms2character <- function(data) {
 #'     form.name = sample(c("b", "c"), size = 6, replace = TRUE, prob = rep(.5, 2))
 #'   ) |>
 #'   purrr::pluck("meta")
-#' mtcars |> ds2dd_detailed(add.auto.id = TRUE)
+#' mtcars |>
+#'   dplyr::mutate(unknown = NA) |>
+#'   numchar2fct() |>
+#'   ds2dd_detailed(add.auto.id = TRUE)
 #'
 #' ## Using column name suffix to carry form name
 #' data <- iris |>
@@ -176,19 +270,21 @@ ds2dd_detailed <- function(data,
                            field.label.attr = "label",
                            field.validation = NULL,
                            metadata = names(REDCapCAST::redcapcast_meta),
-                           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))
-  # }
+                           convert.logicals = FALSE) {
+  short_names <- colnames(data) |>
+    lapply(\(.x) cut_string_length(.x, l = 90)) |>
+    purrr::reduce(c)
+
+  data <- stats::setNames(data, short_names)
 
   if (convert.logicals) {
     data <- data |>
       ## Converts logical to factor, which overwrites attributes
       dplyr::mutate(dplyr::across(dplyr::where(is.logical), as_factor))
+    ## Problematic example:
+    ## as.logical(sample(0:1,10,TRUE)) |> as.factor() |> as.numeric()
+    ## Possible solution would be to subtract values by 1, so
+    ## "0, FALSE | 1, TRUE" like native REDCap
   }
 
   ## Handles the odd case of no id column present
@@ -210,7 +306,6 @@ 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)
@@ -229,11 +324,14 @@ 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 <- gsub(" ", "_", tolower(colnames(data)))
+      dd$field_name <- clean_redcap_name(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 <- gsub(" ", "_", tolower(colnames(data)))
+    dd$field_name <- clean_redcap_name(colnames(data))
 
     if (is.null(form.name)) {
       dd$form_name <- "data"
@@ -280,9 +378,14 @@ ds2dd_detailed <- function(data,
     dd$field_type <- "text"
 
     dd <-
-      dd |> dplyr::mutate(field_type = dplyr::if_else(data_classes == "factor",
-        "radio", field_type
-      ))
+      dd |> dplyr::mutate(
+        field_type = dplyr::case_match(
+          data_classes,
+          "factor"~"radio",
+          "logical"~"truefalse",
+          .default = field_type
+        )
+        )
   } else {
     if (length(field.type) == 1 || length(field.type) == nrow(dd)) {
       dd$field_type <- field.type
@@ -341,7 +444,14 @@ ds2dd_detailed <- function(data,
   out <- list(
     data = data |>
       hms2character() |>
-      stats::setNames(dd$field_name),
+      stats::setNames(dd$field_name) |>
+      lapply(\(.x){
+        if (identical("factor", class(.x))) {
+          as.numeric(.x)
+        } else {
+          .x
+        }
+      }) |> dplyr::bind_cols(),
     meta = dd
   )
 
@@ -357,8 +467,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))
 }
 
@@ -561,7 +671,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
@@ -582,8 +692,7 @@ 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="; ") {
-  # browser()
+compact_vec <- function(data, nm.sep = ": ", val.sep = "; ") {
   if (all(is.na(data))) {
     return(data)
   }

R/easy_redcap.R

@@ -1,15 +1,22 @@
 #' 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, prompt = "Provide REDCap API key:")
+    keyring::key_set(service = key.name, ...)
     keyring::key_get(service = key.name)
   }
 }
@@ -18,25 +25,72 @@ 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
-#' `keyring::key_set()`, using the default keyring)
-#' @param widen.data argument to widen the exported data
+#' \link[keyring]{key_set}, using the default keyring)
+#' @param widen.data argument to widen the exported data. [DEPRECATED], use
+#' `data_format`instead
 #' @param uri REDCap database API uri
-#' @param ... arguments passed on to `REDCapCAST::read_redcap_tables()`
+#' @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}.
 #'
 #' @return data.frame or list depending on widen.data
 #' @export
-easy_redcap <- function(project.name, widen.data = TRUE, uri, ...) {
-  key <- get_api_key(key.name = paste0(project.name, "_REDCAP_API"))
+#'
+#' @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)
 
-  out <- read_redcap_tables(
+  # 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(
     uri = uri,
     token = key,
+    raw_or_label = raw_or_label,
+    split_forms = split_action,
     ...
   )
 
-  if (widen.data) {
-    out <- out |> redcap_wider()
+  # 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
   }
 
   out
 }
+
+

R/export_redcap_instrument.R

@@ -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,6 +82,7 @@ export_redcap_instrument <- function(data,
 #' @export
 #'
 #' @examples
+#' \dontrun{
 #' data <- iris |>
 #'   ds2dd_detailed(
 #'     add.auto.id = TRUE,
@@ -100,9 +101,10 @@ 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) {

R/fct_drop.R

@@ -0,0 +1,45 @@
+#' 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, ...)
+}

R/read_redcap_tables.R

@@ -1,19 +1,33 @@
 #' Download REDCap data
 #'
-#' 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.
+#' @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.
 #' 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
+#' @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 split_forms Whether to split "repeating" or "all" forms, default is
-#' all.
+#' all. Give "none" to export native semi-long REDCap format
+#' @param ... passed on to \link[REDCapR]{redcap_read}
 #'
 #' @return list of instruments
 #' @importFrom REDCapR redcap_metadata_read redcap_read redcap_event_instruments
@@ -28,18 +42,24 @@ read_redcap_tables <- function(uri,
                                fields = NULL,
                                events = NULL,
                                forms = NULL,
-                               raw_or_label = "label",
-                               split_forms = "all") {
+                               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)
+
   # 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")
     }
   }
@@ -49,8 +69,10 @@ 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")
     }
   }
@@ -64,12 +86,20 @@ 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,
@@ -78,9 +108,17 @@ read_redcap_tables <- function(uri,
     events = events,
     forms = forms,
     records = records,
-    raw_or_label = raw_or_label
+    raw_or_label = rorl,
+    ...
   )[["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.
@@ -91,13 +129,115 @@ read_redcap_tables <- function(uri,
   # Processing metadata to reflect focused dataset
   m <- focused_metadata(m, names(d))
 
-
   # Splitting
-  out <- REDCap_split(d,
-    m,
-    forms = split_forms,
-    primary_table_name = ""
-  )
-
-  sanitize_split(out)
+  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()
 }

R/redcap_wider.R

@@ -4,14 +4,20 @@ utils::globalVariables(c(
   "inst.glue"
 ))
 
-#' @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.
+#' 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
 #' @export
+#'
 #' @importFrom tidyr pivot_wider
 #' @importFrom tidyselect all_of
 #' @importFrom purrr reduce
@@ -73,10 +79,35 @@ 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) {
@@ -88,7 +119,28 @@ redcap_wider <-
         out <- data
       }
     } else {
-      id.name <- do.call(c, lapply(data, names))[[1]]
+
+      ## 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]
 
       l <- lapply(data, function(i) {
         rep_inst <- "redcap_repeat_instrument" %in% names(i)
@@ -97,12 +149,7 @@ redcap_wider <-
           k <- lapply(split(i, f = i[[id.name]]), function(j) {
             cname <- colnames(j)
             vals <-
-              cname[!cname %in% c(
-                id.name,
-                "redcap_event_name",
-                "redcap_repeat_instrument",
-                "redcap_repeat_instance"
-              )]
+              cname[!cname %in% generic_names]
             s <- tidyr::pivot_wider(
               j,
               names_from = "redcap_repeat_instance",
@@ -111,7 +158,15 @@ redcap_wider <-
             )
             s[!colnames(s) %in% c("redcap_repeat_instrument")]
           })
-          i <- Reduce(dplyr::bind_rows, k)
+
+          # 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)
         }
 
         event <- "redcap_event_name" %in% names(i)
@@ -141,8 +196,82 @@ redcap_wider <-
         }
       })
 
-      out <- data.frame(Reduce(f = dplyr::full_join, x = l))
+      # out <- Reduce(f = dplyr::full_join, x = l)
+      out <- purrr::reduce(.x = l, .f = dplyr::full_join)
     }
 
     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()
+}

R/redcapcast_meta.R

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

R/shiny_cast.R

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

R/utils.r

@@ -97,7 +97,10 @@ 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(
@@ -108,14 +111,19 @@ 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.
 #'
@@ -127,21 +135,34 @@ 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,
-    paste0(names(l), "_complete")
+    generic.names
   )
 
-  lapply(l, function(i) {
+  if (drop.complete){
+    generic.names <- c(
+      generic.names,
+      paste0(names(l), "_complete")
+    )
+  }
+
+  out <- lapply(l, function(i) {
     if (ncol(i) > 2) {
-      s <- data.frame(i[, !colnames(i) %in% generic.names])
+      s <- i[!colnames(i) %in% generic.names]
+      if (drop.empty){
       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]
 }
 
 
@@ -496,5 +517,27 @@ 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
+  }
+}

README.md

@@ -1,7 +1,6 @@
 <!-- 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) [![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)
-
+[![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)
 <!-- badges: end -->
 
 # REDCapCAST package <img src="man/figures/logo.png" align="right"/>

REDCapCAST.Rproj

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

cran-comments.md

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

data-raw/redcapcast_data.R

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

inst/WORDLIST

@@ -5,22 +5,21 @@ 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
@@ -41,6 +40,8 @@ dmy
 docx
 doi
 dplyr
+dropdown
+droplevels
 ds
 dta
 et
@@ -49,6 +50,7 @@ factorising
 fct
 forcats
 github
+gtsummary
 gues
 hms
 https
@@ -59,7 +61,6 @@ labelled
 labelling
 mRS
 matadata
-md
 mdy
 mis
 mrs
@@ -69,6 +70,7 @@ natively
 ncol
 og
 param
+params
 pegeler
 perl
 pos
@@ -77,6 +79,7 @@ rds
 readr
 realising
 redcapAPI
+redcapcast
 renv
 runApp
 sel

inst/shiny-examples/casting/app.R

@@ -0,0 +1,372 @@
+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)

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

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

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

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

inst/shiny-examples/casting/server.R

@@ -1,180 +0,0 @@
-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)
-  # })
-}

inst/shiny-examples/casting/ui.R

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

man/REDCapCAST-package.Rd

@@ -4,10 +4,8 @@
 \name{REDCapCAST-package}
 \alias{REDCapCAST}
 \alias{REDCapCAST-package}
-\title{REDCapCAST: REDCap Castellated Data Handling and Metadata Casting}
+\title{REDCapCAST: REDCap Metadata Casting and Castellated Data Handling}
 \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{

man/REDCap_split.Rd

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

man/all_na.Rd

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

man/apply_factor_labels.Rd

@@ -0,0 +1,19 @@
+% 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
+}

man/apply_field_label.Rd

@@ -0,0 +1,19 @@
+% 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
+}

man/as_factor.Rd

@@ -8,6 +8,7 @@
 \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, ...)
@@ -33,6 +34,8 @@ as_factor(x, ...)
   ordered = FALSE,
   ...
 )
+
+\method{as_factor}{data.frame}(x, ..., only_labelled = TRUE)
 }
 \arguments{
 \item{x}{Object to coerce to a factor.}
@@ -49,15 +52,19 @@ 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 [forcats::as_factor()] as well as [haven::as_factor()], by appending
+This extends \link[forcats]{as_factor} as well as \link[haven]{as_factor}, by appending
 original attributes except for "class" after converting to factor to avoid
 ta loss in case of rich formatted and labelled data.
 }
 \details{
 Please refer to parent functions for extended documentation.
 To avoid redundancy calls and errors, functions are copy-pasted here
+
+Empty variables with empty levels attribute are interpreted as logicals
 }
 \examples{
 # will preserve all attributes
@@ -65,11 +72,19 @@ 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()
+  as_factor() |> class()
+structure(rep(NA,10),
+  class = c("labelled")
+) |>
+  as_factor() |> summary()
+
+rep(NA,10) |> as_factor()
+
 }

man/as_logical.Rd

@@ -0,0 +1,58 @@
+% 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)
+}

man/clean_field_label.Rd

@@ -0,0 +1,22 @@
+% 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>")
+}

man/clean_redcap_name.Rd

@@ -17,3 +17,6 @@ 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()
+}

man/create_instrument_meta.Rd

@@ -26,6 +26,7 @@ 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,
@@ -44,7 +45,8 @@ 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)
+}
 }

man/cut_string_length.Rd

@@ -0,0 +1,22 @@
+% 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)
+}

man/ds2dd.Rd

@@ -1,5 +1,5 @@
 % Generated by roxygen2: do not edit by hand
-% Please edit documentation in R/ds2dd.R
+% Please edit documentation in R/ds2dd_detailed.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 = metadata_names
+  metadata = names(REDCapCAST::redcapcast_meta)
 )
 }
 \arguments{
@@ -34,7 +34,7 @@ names.}
 column names for original data set for upload.}
 
 \item{metadata}{Metadata column names. Default is the included
-REDCapCAST::metadata_names.}
+names(REDCapCAST::redcapcast_meta).}
 }
 \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)
 }

man/ds2dd_detailed.Rd

@@ -16,7 +16,7 @@ ds2dd_detailed(
   field.label.attr = "label",
   field.validation = NULL,
   metadata = names(REDCapCAST::redcapcast_meta),
-  convert.logicals = TRUE
+  convert.logicals = FALSE
 )
 }
 \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
-REDCapCAST:::metadata_names.}
+names(REDCapCAST::redcapcast_meta).}
 
 \item{convert.logicals}{convert logicals to factor. Default is TRUE.}
 }
@@ -76,7 +76,8 @@ Ensure, that the data set is formatted with as much information as possible.
 }
 \examples{
 ## Basic parsing with default options
-REDCapCAST::redcapcast_data |>
+requireNamespace("REDCapCAST")
+redcapcast_data |>
   dplyr::select(-dplyr::starts_with("redcap_")) |>
   ds2dd_detailed()
 
@@ -90,7 +91,10 @@ iris |>
     form.name = sample(c("b", "c"), size = 6, replace = TRUE, prob = rep(.5, 2))
   ) |>
   purrr::pluck("meta")
-mtcars |> ds2dd_detailed(add.auto.id = TRUE)
+mtcars |>
+  dplyr::mutate(unknown = NA) |>
+  numchar2fct() |>
+  ds2dd_detailed(add.auto.id = TRUE)
 
 ## Using column name suffix to carry form name
 data <- iris |>

man/easy_redcap.Rd

@@ -4,17 +4,31 @@
 \alias{easy_redcap}
 \title{Secure API key storage and data acquisition in one}
 \usage{
-easy_redcap(project.name, widen.data = TRUE, uri, ...)
+easy_redcap(
+  project.name,
+  uri,
+  raw_or_label = "both",
+  data_format = c("wide", "list", "redcap", "long"),
+  widen.data = NULL,
+  ...
+)
 }
 \arguments{
 \item{project.name}{The name of the current project (for key storage with
-`keyring::key_set()`, using the default keyring)}
-
-\item{widen.data}{argument to widen the exported data}
+\link[keyring]{key_set}, using the default keyring)}
 
 \item{uri}{REDCap database API uri}
 
-\item{...}{arguments passed on to `REDCapCAST::read_redcap_tables()`}
+\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}.}
 }
 \value{
 data.frame or list depending on widen.data
@@ -22,3 +36,8 @@ 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"))
+}
+}

man/export_redcap_instrument.Rd

@@ -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
 #  ) |>

man/fct2num.Rd

@@ -34,15 +34,9 @@ structure(c(1, 2, 3, 2, 10, 9),
   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)
+structure(c(1, 2, 3, 2, 10, 9),
+  labels = c(Unknown = 9, Refused = 10)
+) |>
+  as_factor() |>
+  fct2num()
 }

man/fct_drop.Rd

@@ -0,0 +1,31 @@
+% 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))
+}

man/format_redcap_factor.Rd

@@ -0,0 +1,23 @@
+% 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")
+}

man/get_api_key.Rd

@@ -4,14 +4,18 @@
 \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{
-Retrieve project API key if stored, if not, set and retrieve
+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.
 }

man/is.labelled.Rd

@@ -0,0 +1,25 @@
+% 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()
+}

man/named_levels.Rd

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

man/possibly_numeric.Rd

@@ -0,0 +1,23 @@
+% 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()
+}

man/possibly_roman.Rd

@@ -16,7 +16,9 @@ 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()
 }

man/read_redcap_tables.Rd

@@ -11,8 +11,9 @@ read_redcap_tables(
   fields = NULL,
   events = NULL,
   forms = NULL,
-  raw_or_label = "label",
-  split_forms = "all"
+  raw_or_label = c("raw", "label", "both"),
+  split_forms = c("all", "repeating", "none"),
+  ...
 )
 }
 \arguments{
@@ -28,20 +29,32 @@ read_redcap_tables(
 
 \item{forms}{forms to download}
 
-\item{raw_or_label}{raw or label tags}
+\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{split_forms}{Whether to split "repeating" or "all" forms, default is
-all.}
+all. Give "none" to export native semi-long REDCap format}
+
+\item{...}{passed on to \link[REDCapR]{redcap_read}}
 }
 \value{
 list of instruments
 }
 \description{
-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.
+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.
 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

man/redcap_wider.Rd

@@ -2,27 +2,29 @@
 % Please edit documentation in R/redcap_wider.R
 \name{redcap_wider}
 \alias{redcap_wider}
-\title{Redcap Wider}
+\title{Transforms list of REDCap data.frames to a single wide data.frame}
 \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 dplyr::glue string for repeated events naming}
+\item{event.glue}{A \link[glue]{glue} string for repeated events naming}
 
-\item{inst.glue}{A dplyr::glue string for repeated instruments naming}
+\item{inst.glue}{A \link[glue]{glue} string for repeated instruments naming}
 }
 \value{
-The list of data frames in wide format.
+data.frame in wide format
 }
 \description{
-Converts a list of REDCap data frames from long to wide format.
-Handles longitudinal projects, but not yet repeated instruments.
+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}.
 }
 \examples{
 # Longitudinal
@@ -81,4 +83,27 @@ 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)
 }

man/redcapcast_meta.Rd

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

man/sanitize_split.Rd

@@ -7,13 +7,20 @@
 sanitize_split(
   l,
   generic.names = c("redcap_event_name", "redcap_repeat_instrument",
-    "redcap_repeat_instance")
+    "redcap_repeat_instance"),
+  drop.complete = TRUE,
+  drop.empty = TRUE
 )
 }
 \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.

man/suffix2label.Rd

@@ -0,0 +1,29 @@
+% 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
+}

renv.lock

@@ -187,6 +187,22 @@
       ],
       "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",
@@ -456,6 +472,25 @@
       ],
       "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",

tests/testthat/test-as_factor.R

@@ -0,0 +1,56 @@
+# 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
+    ))
+  )
+})

tests/testthat/test-ds2dd.R

@@ -1,9 +1,20 @@
 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")), 18)
-  expect_s3_class(ds2dd(mtcars, record.id = "id"), "data.frame")
-  expect_s3_class(ds2dd(mtcars, record.id = 12), "data.frame")
+  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")
 })
 
 
@@ -11,19 +22,19 @@ test_that("ds2dd gives output with list of length two", {
   expect_equal(length(ds2dd(
     mtcars,
     record.id = "id",
-    include.column.names = TRUE
+    include.column.names = TRUE,metadata = metadata_names()
   )), 2)
 })
 
 
 test_that("ds2dd gives correct errors", {
-  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")))
+  expect_error(ds2dd(mtcars,metadata = metadata_names()))
+  expect_error(ds2dd(mtcars, form.name = c("basis", "incl"),metadata = metadata_names()))
+  expect_error(ds2dd(mtcars, field.type = c("text", "dropdown"),metadata = metadata_names()))
+  expect_error(ds2dd(mtcars, field.label = c("Name", "Age"),metadata = metadata_names()))
 })
 
 test_that("ds2dd correctly renames", {
-  expect_equal(ncol(ds2dd(mtcars, record.id = "id")), 18)
-  expect_s3_class(ds2dd(mtcars, record.id = "id"), "data.frame")
+  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")
 })

tests/testthat/test-redcap_wider.R

@@ -1,25 +1,26 @@
+# library(testthat)
 test_that("redcap_wider() returns expected output", {
   list <-
     list(
-      data.frame(
+      dplyr::tibble(
         record_id = c(1, 2, 1, 2),
         redcap_event_name = c("baseline", "baseline", "followup", "followup"),
         age = c(25, 26, 27, 28)
       ),
-      data.frame(
+      dplyr::tibble(
         record_id = c(1, 2),
         redcap_event_name = c("baseline", "baseline"),
-        gender = c("male", "female")
+        sex = c("male", "female")
       )
     )
 
   expect_equal(
     redcap_wider(list),
-    data.frame(
+    dplyr::tibble(
       record_id = c(1, 2),
-      age_baseline = c(25, 26),
-      age_followup = c(27, 28),
-      gender = c("male", "female")
+      age____baseline = c(25, 26),
+      age____followup = c(27, 28),
+      sex = c("male", "female")
     )
   )
 })
@@ -28,6 +29,7 @@ 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"),

vignettes/Database-creation.Rmd

@@ -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=TRUE}
+```{r eval=FALSE}
 d1 <- mtcars |>
   dplyr::mutate(record_id = seq_len(dplyr::n())) |>
   ds2dd() 

vignettes/REDCapCAST.Rmd

@@ -18,12 +18,46 @@ knitr::opts_chunk$set(
 library(REDCapCAST)
 ```
 
-This vignette covers the included functions and basic functionality.
+This vignette covers the basics to get you started with the two basic features of REDCapCAST:
 
-A dataset and a meta data file are provided with the package for demonstration of the functions.
+-   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")
+)
+```
 
 ## 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()
 ```
@@ -32,29 +66,52 @@ 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 = redcapcast_data,
+    records = labelled_data,
     metadata = redcapcast_meta,
     forms = "all"
   ) |>
+  # Next steps cleans up and removes generic columns
   sanitize_split()
 str(list)
 ```
 
-## Reading data from REDCap
-
-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")
-```
-
-## Pivotting to wider format
+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):
 
 ```{r}
-redcap_wider(list) |> str()
+wide_data <- redcap_wider(list,
+  event.glue = "{.value}____{redcap_event_name}",
+  inst.glue = "{.value}____{redcap_repeat_instance}"
+)
+wide_data |> str()
+```
+
+Transfer suffixes to labels:
+
+```{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")
 ```

vignettes/Shiny-app.Rmd

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