new comment on build

Update README.md

.Rbuildignore

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

.Renviron

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

.Rprofile

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

.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

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

DESCRIPTION

@@ -1,16 +1,18 @@
 Package: REDCapCAST
-Title: REDCap Castellated Data Handling
+Title: REDCap Metadata Casting and Castellated Data Handling
-Version: 24.6.1
+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")), 
     person("Paul", "Egeler", email = "paulegeler@gmail.com", role = c("aut"), 
     comment = c(ORCID = "0000-0001-6948-9498")))
-Description: Originally forked from the R part of 'REDCapRITS' by Paul Egeler. 
+Description: Casting metadata for REDCap database creation and handling of 
+    castellated data using repeated instruments and longitudinal projects in 
+    'REDCap'. Keeps a focused data export approach, by allowing to only export 
+    required data from the database. Also for casting new REDCap databases based 
+    on datasets from other sources.
+    Originally forked from the R part of 'REDCapRITS' by Paul Egeler. 
     See <https://github.com/pegeler/REDCapRITS>.
-    'REDCap' database casting and handling of castellated data when using 
-    repeated instruments and longitudinal projects. Keeps a focused data export 
-    approach, by allowing to only export required data from the database.
     'REDCap' (Research Electronic Data Capture) is a secure, web-based software
     platform designed to support data capture for research studies, providing
     1) an intuitive interface for validated data capture; 2) audit trails for
@@ -19,7 +21,7 @@ Description: Originally forked from the R part of 'REDCapRITS' by Paul Egeler.
     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,
@@ -27,20 +29,17 @@ Suggests:
     Hmisc,
     knitr,
     rmarkdown,
-    gt,
-    ggplot2,
-    here,
     styler,
     devtools,
     roxygen2,
     spelling,
-    glue,
     rhub,
-    shinythemes
+    rsconnect,
+    pkgconfig
 License: GPL (>= 3)
 Encoding: UTF-8
 LazyData: true
-RoxygenNote: 7.3.1
+RoxygenNote: 7.3.2
 URL: https://github.com/agdamsbo/REDCapCAST, https://agdamsbo.github.io/REDCapCAST/
 BugReports: https://github.com/agdamsbo/REDCapCAST/issues
 Imports: 
@@ -52,21 +51,33 @@ Imports:
     purrr,
     readr,
     stats,
-    shiny,
-    openxlsx2,
-    haven,
-    readODS,
     zip,
-    assertthat
+    assertthat,
+    forcats,
+    vctrs,
+    gt,
+    bslib,
+    here,
+    glue,
+    gtsummary,
+    shiny,
+    haven,
+    openxlsx2,
+    readODS
+Language: en-US
+VignetteBuilder: knitr
 Collate: 
+    'REDCapCAST-package.R'
     'utils.r'
     'process_user_input.r'
     'REDCap_split.r'
-    'create_instrument_meta.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'
@@ -75,5 +86,3 @@ Collate:
     'redcapcast_data.R'
     'redcapcast_meta.R'
     'shiny_cast.R'
-Language: en-US
-VignetteBuilder: knitr

NAMESPACE

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

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

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
+#'   output table. Ignored if \code{forms = 'all'}.
-#'   \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

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

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/create_instrument_meta.R

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

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

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)
+#' \link[keyring]{key_set}, using the default keyring)
-#' @param widen.data argument to widen the exported data
+#' @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) {
+  # For now, long data format is just legacy REDCap
-    out <- out |> redcap_wider()
+  # 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

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

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
+#' @description
-#' REDCapR::redcap_read and only downloading specified fields, forms and/or
+#' Implementation of passed on to \link[REDCapCAST]{REDCap_split} with a focused
-#' events using the built-in focused_metadata including some clean-up.
+#' 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",
+                               raw_or_label = c("raw", "label", "both"),
-                               split_forms = "all") {
+                               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: ",
+      print(paste0(
-                   paste(fields[!fields_test], collapse = ", "), "."))
+        "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: ",
+      print(paste0(
-                   paste(forms[!forms_test], collapse = ", "), "."))
+        "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: ",
+      print(paste0(
-                   paste(events[!event_test], collapse = ", "), "."))
+        "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,
+  if (split_forms != "none") {
+    REDCap_split(d,
       m,
       forms = split_forms,
       primary_table_name = ""
-  )
+    ) |> sanitize_split()
-
+  } else {
-  sanitize_split(out)
+    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
+#' 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.
+#'
-#' Handles longitudinal projects, but not yet repeated instruments.
+#' @description Converts a list of REDCap data.frames from long to wide format.
-#' @param data A list of data frames.
+#' In essence it is a wrapper for the \link[tidyr]{pivot_wider} function applied
-#' @param event.glue A dplyr::glue string for repeated events naming
+#' on a REDCap output (from \link[REDCapCAST]{read_redcap_tables}) or manually
-#' @param inst.glue A dplyr::glue string for repeated instruments naming
+#' split by \link[REDCapCAST]{REDCap_split}.
-#' @return The list of data frames in wide format.
+#'
+#' @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}",
+           event.glue = "{.value}____{redcap_event_name}",
-           inst.glue = "{.value}_{redcap_repeat_instance}") {
+           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(
+              cname[!cname %in% generic_names]
-                id.name,
-                "redcap_event_name",
-                "redcap_repeat_instrument",
-                "redcap_repeat_instance"
-              )]
             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_data.R

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

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

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

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

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

app/server.R

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

app/ui.R

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

cran-comments.md

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

data-raw/data-upload-examples.R

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

data-raw/redcapcast_data.R

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

data/redcapcast_data.csv

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

inst/WORDLIST

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

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

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

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

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

inst/shiny-examples/casting/www/SHINYCAST.md

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

man/REDCapCAST-package.Rd

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

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
+output table. Ignored if \code{forms = 'all'}.}
-\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

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

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

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

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/cast_data_overview.Rd

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

man/cast_meta_overview.Rd

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

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/compact_vec.Rd

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

man/create_instrument_meta.Rd

@@ -1,8 +1,8 @@
 % Generated by roxygen2: do not edit by hand
-% Please edit documentation in R/create_instrument_meta.R
+% Please edit documentation in R/export_redcap_instrument.R
 \name{create_instrument_meta}
 \alias{create_instrument_meta}
-\title{Create zips file with necessary content based on data set}
+\title{DEPRICATED Create zips file with necessary content based on data set}
 \usage{
 create_instrument_meta(data, dir = here::here(""), record.id = TRUE)
 }
@@ -21,23 +21,32 @@ list
 }
 \description{
 Metadata can be added by editing the data dictionary of a project in the
-initial design phase. If you want to later add new instruments, this can be
+initial design phase. If you want to later add new instruments, this
-used to add instrument(s) to a project in production.
+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,
+  ds2dd_detailed(
-  form.name=sample(c("b","c"),size = 6,replace = TRUE,prob=rep(.5,2))) |>
+    add.auto.id = TRUE,
+    form.name = sample(c("b", "c"),
+      size = 6,
+      replace = TRUE, prob = rep(.5, 2)
+    )
+  ) |>
   purrr::pluck("meta")
 # data |> create_instrument_meta()
 
 data <- iris |>
   ds2dd_detailed(add.auto.id = FALSE) |>
   purrr::pluck("data")
-names(data) <- glue::glue("{sample(x = c('a','b'),size = length(names(data)),
+iris |>
-replace=TRUE,prob = rep(x=.5,2))}__{names(data)}")
+  setNames(glue::glue("{sample(x = c('a','b'),size = length(ncol(iris)),
-data <- data |> ds2dd_detailed(form.sep="__")
+replace=TRUE,prob = rep(x=.5,2))}__{names(iris)}")) |>
-# data |>
+  ds2dd_detailed(form.sep = "__")
-#   purrr::pluck("meta") |>
+data |>
-#   create_instrument_meta(record.id = FALSE)
+  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,9 +16,7 @@ ds2dd_detailed(
   field.label.attr = "label",
   field.validation = NULL,
   metadata = names(REDCapCAST::redcapcast_meta),
-  validate.time = FALSE,
+  convert.logicals = FALSE
-  time.var.sel.pos = "[Tt]i[d(me)]",
-  time.var.sel.neg = "[Dd]at[eo]"
 )
 }
 \arguments{
@@ -34,7 +32,7 @@ ncol(data). Default is NULL and "data" is used.}
 
 \item{form.sep}{If supplied dataset has form names as suffix or prefix to the
 column/variable names, the seperator can be specified. If supplied, the
-form.sep is ignored. Default is NULL.}
+form.name is ignored. Default is NULL.}
 
 \item{form.prefix}{Flag to set if form is prefix (TRUE) or suffix (FALSE) to
 the column names. Assumes all columns have pre- or suffix if specified.}
@@ -57,15 +55,9 @@ 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{validate.time}{Flag to validate guessed time columns}
+\item{convert.logicals}{convert logicals to factor. Default is TRUE.}
-
-\item{time.var.sel.pos}{Positive selection regex string passed to
-`gues_time_only_filter()` as sel.pos.}
-
-\item{time.var.sel.neg}{Negative selection regex string passed to
-`gues_time_only_filter()` as sel.neg.}
 }
 \value{
 list of length 2
@@ -83,15 +75,32 @@ Ensure, that the data set is formatted with as much information as possible.
 `field.type` can be supplied
 }
 \examples{
-data <- REDCapCAST::redcapcast_data
+## Basic parsing with default options
-data |> ds2dd_detailed(validate.time = TRUE)
+requireNamespace("REDCapCAST")
-data |> ds2dd_detailed()
+redcapcast_data |>
+  dplyr::select(-dplyr::starts_with("redcap_")) |>
+  ds2dd_detailed()
+
+## Adding a record_id field
 iris |> ds2dd_detailed(add.auto.id = TRUE)
-mtcars |> ds2dd_detailed(add.auto.id = TRUE)
+
+## Passing form name information to function
+iris |>
+  ds2dd_detailed(
+    add.auto.id = TRUE,
+    form.name = sample(c("b", "c"), size = 6, replace = TRUE, prob = rep(.5, 2))
+  ) |>
+  purrr::pluck("meta")
+mtcars |>
+  dplyr::mutate(unknown = NA) |>
+  numchar2fct() |>
+  ds2dd_detailed(add.auto.id = TRUE)
+
+## Using column name suffix to carry form name
 data <- iris |>
   ds2dd_detailed(add.auto.id = TRUE) |>
   purrr::pluck("data")
 names(data) <- glue::glue("{sample(x = c('a','b'),size = length(names(data)),
 replace=TRUE,prob = rep(x=.5,2))}__{names(data)}")
-data |> ds2dd_detailed(form.sep="__")
+data |> ds2dd_detailed(form.sep = "__")
 }

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)}
+\link[keyring]{key_set}, using the default keyring)}
-
-\item{widen.data}{argument to widen the exported data}
 
 \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

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

man/fct2num.Rd

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

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/file_extension.Rd

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

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/get_attr.Rd

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

man/guess_time_only.Rd

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

man/haven_all_levels.Rd

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

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

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

man/nav_bar_page.Rd

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

man/numchar2fct.Rd

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

man/parse_data.Rd

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

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

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

man/read_redcap_tables.Rd

@@ -11,8 +11,9 @@ read_redcap_tables(
   fields = NULL,
   events = NULL,
   forms = NULL,
-  raw_or_label = "label",
+  raw_or_label = c("raw", "label", "both"),
-  split_forms = "all"
+  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
+Implementation of passed on to \link[REDCapCAST]{REDCap_split} with a focused
-REDCapR::redcap_read and only downloading specified fields, forms and/or
+data acquisition approach using passed on to \link[REDCapR]{redcap_read} and
-events using the built-in focused_metadata including some clean-up.
+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}",
+  event.glue = "{.value}____{redcap_event_name}",
-  inst.glue = "{.value}_{redcap_repeat_instance}"
+  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.
+Converts a list of REDCap data.frames from long to wide format.
-Handles longitudinal projects, but not yet repeated instruments.
+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_data.Rd

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

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/server_factory.Rd

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

man/set_attr.Rd

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

man/shiny_cast.Rd

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

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

man/ui_factory.Rd

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

man/var2fct.Rd

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

man/vec2choice.Rd

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

renv.lock

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

renv/activate.R

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

tests/spelling.R

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

tests/spelling.Rout.save

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

tests/testthat/test-API.R

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

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-csv-exports.R

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

tests/testthat/test-ds2dd.R

@@ -0,0 +1,40 @@
+mtcars$id <- seq_len(nrow(mtcars))
+
+metadata_names <- function(...) {
+  c(
+    "field_name", "form_name", "section_header", "field_type",
+    "field_label", "select_choices_or_calculations", "field_note",
+    "text_validation_type_or_show_slider_number", "text_validation_min",
+    "text_validation_max", "identifier", "branching_logic", "required_field",
+    "custom_alignment", "question_number", "matrix_group_name", "matrix_ranking",
+    "field_annotation"
+  )
+}
+
+test_that("ds2dd gives desired output", {
+  expect_equal(ncol(ds2dd(mtcars, record.id = "id",metadata = metadata_names())), 18)
+  expect_s3_class(ds2dd(mtcars, record.id = "id",metadata = metadata_names()), "data.frame")
+  expect_s3_class(ds2dd(mtcars, record.id = 12,metadata = metadata_names()), "data.frame")
+})
+
+
+test_that("ds2dd gives output with list of length two", {
+  expect_equal(length(ds2dd(
+    mtcars,
+    record.id = "id",
+    include.column.names = TRUE,metadata = metadata_names()
+  )), 2)
+})
+
+
+test_that("ds2dd gives correct errors", {
+  expect_error(ds2dd(mtcars,metadata = metadata_names()))
+  expect_error(ds2dd(mtcars, form.name = c("basis", "incl"),metadata = metadata_names()))
+  expect_error(ds2dd(mtcars, field.type = c("text", "dropdown"),metadata = metadata_names()))
+  expect_error(ds2dd(mtcars, field.label = c("Name", "Age"),metadata = metadata_names()))
+})
+
+test_that("ds2dd correctly renames", {
+  expect_equal(ncol(ds2dd(mtcars, record.id = "id",metadata = metadata_names())), 18)
+  expect_s3_class(ds2dd(mtcars, record.id = "id",metadata = metadata_names()), "data.frame")
+})

tests/testthat/test-longitudinal.R

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

tests/testthat/test-primary-table-name.R

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

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____baseline = c(25, 26),
-      age_followup = c(27, 28),
+      age____followup = c(27, 28),
-      gender = c("male", "female")
+      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() 
@@ -45,7 +45,7 @@ The more advanced `ds2dd_detailed()` is a natural development. It will try to ap
 
 The dataset should be correctly formatted for the data dictionary to preserve as much information as possible.
 
-```{r eval=TRUE}
+```{r eval=FALSE}
 d2 <- REDCapCAST::redcapcast_data |> 
   dplyr::mutate(record_id = seq_len(dplyr::n()),
                 region=factor(region)) |>