restructuring

.Rbuildignore

@@ -20,3 +20,5 @@ app
 ^\.lintr$
 ^CODE_OF_CONDUCT\.md$
 ^~/REDCapCAST/inst/shiny-examples/casting/rsconnect$
+^inst/shiny-examples/casting/functions\.R$
+^functions\.R$

.gitignore

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

CRAN-SUBMISSION

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

DESCRIPTION

@@ -1,6 +1,6 @@
 Package: REDCapCAST
 Title: REDCap Metadata Casting and Castellated Data Handling
-Version: 24.11.3
+Version: 24.11.4
 Authors@R: c(
     person("Andreas Gammelgaard", "Damsbo", email = "agdamsbo@clin.au.dk", 
     role = c("aut", "cre"),comment = c(ORCID = "0000-0002-7559-1154")), 
@@ -68,7 +68,6 @@ Collate:
     'REDCap_split.r'
     'as_factor.R'
     'doc2dd.R'
-    'ds2dd.R'
     'ds2dd_detailed.R'
     'easy_redcap.R'
     'export_redcap_instrument.R'

NAMESPACE

@@ -18,6 +18,7 @@ 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)
@@ -48,7 +49,9 @@ export(possibly_roman)
 export(process_user_input)
 export(read_input)
 export(read_redcap_instrument)
+export(read_redcap_labelled)
 export(read_redcap_tables)
+export(redcap_meta_default)
 export(redcap_wider)
 export(sanitize_split)
 export(set_attr)

NEWS.md

@@ -1,3 +1,9 @@
+# REDCapCAST 24.11.4
+
+The hosting on shinyapps.io has given a lot of trouble recently. Modyfied 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.
+
+* read_readcap_labelled(): 
+
 # REDCapCAST 24.11.3
 
 * BUG: shiny_cast() fails to load as I missed loading REDCapCAST library in ui.r. Fixed. Tests would be great.

R/as_factor.R

@@ -16,7 +16,8 @@
 #' structure(c(1, 2, 3, 2, 10, 9),
 #'   labels = c(Unknown = 9, Refused = 10)
 #' ) |>
-#'   as_factor() |> dput()
+#'   as_factor() |>
+#'   dput()
 #'
 #' structure(c(1, 2, 3, 2, 10, 9),
 #'   labels = c(Unknown = 9, Refused = 10),
@@ -56,13 +57,13 @@ as_factor.numeric <- function(x, ...) {
 #' @export
 as_factor.character <- function(x, ...) {
   labels <- get_attr(x)
-  if (possibly_roman(x)){
+  if (possibly_roman(x)) {
     x <- factor(x)
   } else {
-  x <- structure(
-    forcats::fct_inorder(x),
-    label = attr(x, "label", exact = TRUE)
-  )
+    x <- structure(
+      forcats::fct_inorder(x),
+      label = attr(x, "label", exact = TRUE)
+    )
   }
   set_attr(x, labels, overwrite = FALSE)
 }
@@ -202,8 +203,9 @@ named_levels <- function(data, label = "labels", na.label = NULL, na.value = 99)
     )
   }
 
+
   # Handle empty factors
-  if (all_na(data)){
+  if (all_na(data)) {
     d <- data.frame(
       name = levels(data),
       value = seq_along(levels(data))
@@ -213,15 +215,19 @@ named_levels <- function(data, label = "labels", na.label = NULL, na.value = 99)
       name = levels(data)[data],
       value = as.numeric(data)
     ) |>
-      unique()
+      unique() |>
+      stats::na.omit()
   }
 
   ## Applying labels
   attr_l <- attr(x = data, which = label, exact = TRUE)
   if (length(attr_l) != 0) {
-    if (all(names(attr_l) %in% d$name)){
+    if (all(names(attr_l) %in% d$name)) {
       d$value[match(names(attr_l), d$name)] <- unname(attr_l)
-    }else {
+    } else if (all(d$name %in% names(attr_l)) && nrow(d) < length(attr_l)){
+      d <- data.frame(name = names(attr_l),
+                      value=unname(attr_l))
+    } else {
       d$name[match(attr_l, d$name)] <- names(attr_l)
       d$value[match(names(attr_l), d$name)] <- unname(attr_l)
     }
@@ -244,13 +250,17 @@ named_levels <- function(data, label = "labels", na.label = NULL, na.value = 99)
 #' @export
 #'
 #' @examples
-#' sample(1:100,10) |> as.roman() |> possibly_roman()
-#' sample(c(TRUE,FALSE),10,TRUE)|> possibly_roman()
-#' rep(NA,10)|> possibly_roman()
-possibly_roman <- function(data){
+#' sample(1:100, 10) |>
+#'   as.roman() |>
+#'   possibly_roman()
+#' sample(c(TRUE, FALSE), 10, TRUE) |> possibly_roman()
+#' rep(NA, 10) |> possibly_roman()
+possibly_roman <- function(data) {
   # browser()
-  if (all(is.na(data))) return(FALSE)
-  identical(as.character(data),as.character(utils::as.roman(data)))
+  if (all(is.na(data))) {
+    return(FALSE)
+  }
+  identical(as.character(data), as.character(utils::as.roman(data)))
 }
 
 
@@ -287,13 +297,13 @@ possibly_roman <- function(data){
 #' #   as_factor() |>
 #' #   fct2num()
 #'
-#' v <- sample(6:19,20,TRUE) |> factor()
+#' v <- sample(6:19, 20, TRUE) |> factor()
 #' dput(v)
 #' named_levels(v)
 #' fct2num(v)
 fct2num <- function(data) {
   stopifnot(is.factor(data))
-  if (is.character(named_levels(data))){
+  if (is.character(named_levels(data))) {
     values <- as.numeric(named_levels(data))
   } else {
     values <- named_levels(data)
@@ -309,7 +319,7 @@ fct2num <- function(data) {
   unname(out)
 }
 
-possibly_numeric <- function(data){
+possibly_numeric <- function(data) {
   length(stats::na.omit(suppressWarnings(as.numeric(names(data))))) ==
     length(data)
 }
@@ -369,7 +379,6 @@ set_attr <- function(data, label, attr = NULL, overwrite = FALSE) {
       label <- label[!names(label) %in% names(attributes(data))]
     }
     attributes(data) <- c(attributes(data), label)
-
   } else {
     attr(data, attr) <- label
   }

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

@@ -98,6 +98,116 @@ hms2character <- function(data) {
     dplyr::bind_cols()
 }
 
+
+#' Default column names of a REDCap data dictionary
+#'
+#' @param ... ignored for now
+#'
+#' @return character vector
+#' @export
+#'
+#' @examples
+#' dput(redcap_meta_default())
+redcap_meta_default <- 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"
+  )
+}
+
+#' (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::redcap_meta_default.
+#'
+#' @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 = REDCapCAST::redcap_meta_default()
+           ) {
+    dd <- data.frame(matrix(ncol = length(metadata), nrow = ncol(ds)))
+    colnames(dd) <- metadata
+
+    if (is.character(record.id) && !record.id %in% colnames(ds)) {
+      stop("Provided record.id is not a variable name in provided data set.")
+    }
+
+    # renaming to lower case and substitute spaces with underscore
+    field.name <- gsub(" ", "_", tolower(colnames(ds)))
+
+    # handles both character and integer
+    colsel <-
+      colnames(ds) == colnames(ds[record.id])
+
+    if (summary(colsel)[3] != 1) {
+      stop("Provided record.id has to be or refer to a uniquely named column.")
+    }
+
+    dd[, "field_name"] <-
+      c(field.name[colsel], field.name[!colsel])
+
+    if (length(form.name) > 1 && length(form.name) != ncol(ds)) {
+      stop(
+        "Provided form.name should be of length 1 (value is reused) or equal
+        length as number of variables in data set."
+      )
+    }
+    dd[, "form_name"] <- form.name
+
+    if (length(field.type) > 1 && length(field.type) != ncol(ds)) {
+      stop(
+        "Provided field.type should be of length 1 (value is reused) or equal
+        length as number of variables in data set."
+      )
+    }
+
+    dd[, "field_type"] <- field.type
+
+    if (is.null(field.label)) {
+      dd[, "field_label"] <- dd[, "field_name"]
+    } else
+      dd[, "field_label"] <- field.label
+
+    if (include.column.names){
+      list("DataDictionary"=dd,"Column names"=field.name)
+    } else dd
+  }
+
+
 #' Extract data from stata file for data dictionary
 #'
 #' @details
@@ -134,7 +244,7 @@ hms2character <- function(data) {
 #' or attribute `factor.labels.attr` for haven_labelled data set (imported .dta
 #' file with `haven::read_dta()`).
 #' @param metadata redcap metadata headings. Default is
-#' REDCapCAST:::metadata_names.
+#' REDCapCAST::redcap_meta_default().
 #' @param convert.logicals convert logicals to factor. Default is TRUE.
 #'
 #' @return list of length 2
@@ -142,7 +252,8 @@ hms2character <- function(data) {
 #'
 #' @examples
 #' ## Basic parsing with default options
-#' REDCapCAST::redcapcast_data |>
+#' requireNamespace("REDCapCAST")
+#' redcapcast_data |>
 #'   dplyr::select(-dplyr::starts_with("redcap_")) |>
 #'   ds2dd_detailed()
 #'
@@ -175,15 +286,8 @@ ds2dd_detailed <- function(data,
                            field.label = NULL,
                            field.label.attr = "label",
                            field.validation = NULL,
-                           metadata = names(REDCapCAST::redcapcast_meta),
+                           metadata = REDCapCAST::redcap_meta_default(),
                            convert.logicals = TRUE) {
-  # Repair empty columns
-  # These where sometimes classed as factors or
-  # if (any(sapply(data,all_na))){
-  #   data <- data |>
-  #     ## Converts logical to factor, which overwrites attributes
-  #     dplyr::mutate(dplyr::across(dplyr::where(all_na), as.character))
-  # }
 
   if (convert.logicals) {
     data <- data |>
@@ -357,8 +461,8 @@ ds2dd_detailed <- function(data,
 #' @export
 #'
 #' @examples
-#' rep(NA,4) |> all_na()
-all_na <- function(data){
+#' rep(NA, 4) |> all_na()
+all_na <- function(data) {
   all(is.na(data))
 }
 
@@ -561,7 +665,7 @@ numchar2fct <- function(data, numeric.threshold = 6, character.throshold = 6) {
 #'   sort() |>
 #'   vec2choice()
 vec2choice <- function(data) {
-  compact_vec(data,nm.sep = ", ",val.sep = " | ")
+  compact_vec(data, nm.sep = ", ", val.sep = " | ")
 }
 
 #' Compacting a vector of any length with or without names
@@ -582,7 +686,7 @@ vec2choice <- function(data) {
 #' 1:6 |> compact_vec()
 #' "test" |> compact_vec()
 #' sample(letters[1:9], 20, TRUE) |> compact_vec()
-compact_vec <- function(data,nm.sep=": ",val.sep="; ") {
+compact_vec <- function(data, nm.sep = ": ", val.sep = "; ") {
   # browser()
   if (all(is.na(data))) {
     return(data)

R/easy_redcap.R

@@ -40,3 +40,167 @@ easy_redcap <- function(project.name, widen.data = TRUE, uri, ...) {
 
   out
 }
+
+
+#' REDCap read function to preserve field labels and all factor levels
+#'
+#' @description
+#' This works very much as `read_redcap_tables()` and might end up there
+#'
+#'
+#' @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 split_forms Whether to split "repeating" or "all" forms, default is
+#' "all".
+#'
+#' @return data.frame or list
+#' @export
+#'
+read_redcap_labelled <- function(uri,
+                                 token,
+                                 records = NULL,
+                                 fields = NULL,
+                                 events = NULL,
+                                 forms = NULL,
+                                 split_forms = "all") {
+  m <-
+    REDCapR::redcap_metadata_read(redcap_uri = uri, token = token)[["data"]]
+
+  # Tests
+  if (!is.null(fields)) {
+    fields_test <- fields %in% c(m$field_name, paste0(unique(m$form_name), "_complete"))
+
+    if (any(!fields_test)) {
+      print(paste0(
+        "The following field names are invalid: ",
+        paste(fields[!fields_test], collapse = ", "), "."
+      ))
+      stop("Not all supplied field names are valid")
+    }
+  }
+
+
+  if (!is.null(forms)) {
+    forms_test <- forms %in% unique(m$form_name)
+
+    if (any(!forms_test)) {
+      print(paste0(
+        "The following form names are invalid: ",
+        paste(forms[!forms_test], collapse = ", "), "."
+      ))
+      stop("Not all supplied form names are valid")
+    }
+  }
+
+  if (!is.null(events)) {
+    arm_event_inst <- REDCapR::redcap_event_instruments(
+      redcap_uri = uri,
+      token = token
+    )
+
+    event_test <- events %in% unique(arm_event_inst$data$unique_event_name)
+
+    if (any(!event_test)) {
+      print(paste0(
+        "The following event names are invalid: ",
+        paste(events[!event_test], collapse = ", "), "."
+      ))
+      stop("Not all supplied event names are valid")
+    }
+  }
+
+  # Getting dataset
+  d <- REDCapR::redcap_read(
+    redcap_uri = uri,
+    token = token,
+    fields = fields,
+    events = events,
+    forms = forms,
+    records = records,
+    raw_or_label = "raw"
+  )[["data"]]
+
+  # Applying labels
+  d <- purrr::imap(d, \(.x, .i){
+    if (.i %in% m$field_name) {
+      # Does not handle checkboxes
+      out <- set_attr(.x,
+        label = clean_field_label(m$field_label[m$field_name == .i]),
+        attr = "label"
+      )
+      out
+    } else {
+      .x
+    }
+  }) |> dplyr::bind_cols()
+
+  d <- purrr::imap(d, \(.x, .i){
+    if (any(c("radio", "dropdown") %in% m$field_type[m$field_name == .i])) {
+      format_redcap_factor(.x, m$select_choices_or_calculations[m$field_name == .i])
+    } else {
+      .x
+    }
+  }) |> dplyr::bind_cols()
+
+  # Process repeat instrument naming
+  # Removes any extra characters other than a-z, 0-9 and "_", to mimic raw
+  # instrument names.
+  if ("redcap_repeat_instrument" %in% names(d)) {
+    d$redcap_repeat_instrument <- clean_redcap_name(d$redcap_repeat_instrument)
+  }
+
+  # Processing metadata to reflect focused dataset
+  m <- focused_metadata(m, names(d))
+
+  # Splitting
+  out <- REDCap_split(d,
+    m,
+    forms = split_forms,
+    primary_table_name = ""
+  )
+
+  sanitize_split(out)
+}
+
+
+#' 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)
+}
+
+
+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") |>
+    as_factor()
+}

R/export_redcap_instrument.R

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

R/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{

data-raw/metadata_names.R

@@ -7,9 +7,9 @@
 #   "matrix_ranking", "field_annotation"
 # )
 
-metadata_names <- REDCapR::redcap_metadata_read(
-  redcap_uri = keyring::key_get("DB_URI"),
-  token = keyring::key_get("cast_api")
-)$data |> names()
-
-usethis::use_data(metadata_names, overwrite = TRUE, internal = TRUE)
+# metadata_names <- REDCapR::redcap_metadata_read(
+#   redcap_uri = keyring::key_get("DB_URI"),
+#   token = keyring::key_get("cast_api")
+# )$data |> names()
+#
+# usethis::use_data(metadata_names, overwrite = TRUE, internal = TRUE)

data-raw/redcapcast_data.R

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

inst/shiny-examples/casting/app.R

@@ -5,12 +5,25 @@ library(haven)
 library(readODS)
 library(readr)
 library(dplyr)
+library(gt)
 library(devtools)
+
 if (!requireNamespace("REDCapCAST")) {
-  devtools::install_github("agdamsbo/REDCapCAST", quiet = TRUE, upgrade = "never")
+  install.packages("REDCapCAST")
 }
 library(REDCapCAST)
 
+## Load merged files for shinyapps.io hosting
+if (file.exists(here::here("functions.R"))) {
+  source(here::here("functions.R"))
+}
+
+ui <-
+  bslib::page(
+    theme = bslib::bs_theme(preset = "united"),
+    title = "REDCap database creator",
+    nav_bar_page()
+  )
 
 server <- function(input, output, session) {
   v <- shiny::reactiveValues(
@@ -178,3 +191,5 @@ server <- function(input, output, session) {
   #   unlink("www",recursive = TRUE)
   # })
 }
+
+shiny::shinyApp(ui = ui, server = server)

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

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

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

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

inst/shiny-examples/casting/ui.R

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

man/REDCapCAST-package.Rd

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

man/all_na.Rd

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

man/as_factor.Rd

@@ -65,7 +65,8 @@ c(1, 4, 3, "A", 7, 8, 1) |> as_factor()
 structure(c(1, 2, 3, 2, 10, 9),
   labels = c(Unknown = 9, Refused = 10)
 ) |>
-  as_factor() |> dput()
+  as_factor() |>
+  dput()
 
 structure(c(1, 2, 3, 2, 10, 9),
   labels = c(Unknown = 9, Refused = 10),

man/clean_field_label.Rd

@@ -0,0 +1,22 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/easy_redcap.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/create_instrument_meta.Rd

@@ -26,6 +26,7 @@ function can be used to create (an) instrument(s) to add to a project in
 production.
 }
 \examples{
+\dontrun{
 data <- iris |>
   ds2dd_detailed(
     add.auto.id = TRUE,
@@ -44,7 +45,8 @@ iris |>
   setNames(glue::glue("{sample(x = c('a','b'),size = length(ncol(iris)),
 replace=TRUE,prob = rep(x=.5,2))}__{names(iris)}")) |>
   ds2dd_detailed(form.sep = "__")
-# data |>
-#   purrr::pluck("meta") |>
-#   create_instrument_meta(record.id = FALSE)
+data |>
+  purrr::pluck("meta") |>
+  create_instrument_meta(record.id = FALSE)
+}
 }

man/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 = REDCapCAST::redcap_meta_default()
 )
 }
 \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.}
+REDCapCAST::redcap_meta_default.}
 }
 \value{
 data.frame or list of data.frame and vector

man/ds2dd_detailed.Rd

@@ -15,7 +15,7 @@ ds2dd_detailed(
   field.label = NULL,
   field.label.attr = "label",
   field.validation = NULL,
-  metadata = names(REDCapCAST::redcapcast_meta),
+  metadata = REDCapCAST::redcap_meta_default(),
   convert.logicals = TRUE
 )
 }
@@ -55,7 +55,7 @@ or attribute `factor.labels.attr` for haven_labelled data set (imported .dta
 file with `haven::read_dta()`).}
 
 \item{metadata}{redcap metadata headings. Default is
-REDCapCAST:::metadata_names.}
+REDCapCAST::redcap_meta_default().}
 
 \item{convert.logicals}{convert logicals to factor. Default is TRUE.}
 }
@@ -76,7 +76,8 @@ Ensure, that the data set is formatted with as much information as possible.
 }
 \examples{
 ## Basic parsing with default options
-REDCapCAST::redcapcast_data |>
+requireNamespace("REDCapCAST")
+redcapcast_data |>
   dplyr::select(-dplyr::starts_with("redcap_")) |>
   ds2dd_detailed()
 

man/export_redcap_instrument.Rd

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

man/fct2num.Rd

@@ -41,7 +41,7 @@ structure(c(1, 2, 3, 2, 10, 9),
 #   as_factor() |>
 #   fct2num()
 
-v <- sample(6:19,20,TRUE) |> factor()
+v <- sample(6:19, 20, TRUE) |> factor()
 dput(v)
 named_levels(v)
 fct2num(v)

man/possibly_roman.Rd

@@ -16,7 +16,9 @@ logical
 Test if vector can be interpreted as roman numerals
 }
 \examples{
-sample(1:100,10) |> as.roman() |> possibly_roman()
-sample(c(TRUE,FALSE),10,TRUE)|> possibly_roman()
-rep(NA,10)|> possibly_roman()
+sample(1:100, 10) |>
+  as.roman() |>
+  possibly_roman()
+sample(c(TRUE, FALSE), 10, TRUE) |> possibly_roman()
+rep(NA, 10) |> possibly_roman()
 }

man/read_redcap_labelled.Rd

@@ -0,0 +1,38 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/easy_redcap.R
+\name{read_redcap_labelled}
+\alias{read_redcap_labelled}
+\title{REDCap read function to preserve field labels and all factor levels}
+\usage{
+read_redcap_labelled(
+  uri,
+  token,
+  records = NULL,
+  fields = NULL,
+  events = NULL,
+  forms = NULL,
+  split_forms = "all"
+)
+}
+\arguments{
+\item{uri}{REDCap database API uri}
+
+\item{token}{API token}
+
+\item{records}{records to download}
+
+\item{fields}{fields to download}
+
+\item{events}{events to download}
+
+\item{forms}{forms to download}
+
+\item{split_forms}{Whether to split "repeating" or "all" forms, default is
+"all".}
+}
+\value{
+data.frame or list
+}
+\description{
+This works very much as `read_redcap_tables()` and might end up there
+}

man/redcap_meta_default.Rd

@@ -0,0 +1,20 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/ds2dd_detailed.R
+\name{redcap_meta_default}
+\alias{redcap_meta_default}
+\title{Default column names of a REDCap data dictionary}
+\usage{
+redcap_meta_default(...)
+}
+\arguments{
+\item{...}{ignored for now}
+}
+\value{
+character vector
+}
+\description{
+Default column names of a REDCap data dictionary
+}
+\examples{
+dput(redcap_meta_default())
+}

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}

tests/testthat/test-ds2dd.R

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

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