adjusted docs

R/as_factor.R

@@ -1,6 +1,6 @@
 #' Convert labelled vectors to factors while preserving attributes
 #'
-#' This extends [forcats::as_factor()] as well as [haven::as_factor()], by appending
+#' This extends \link[forcats]{as_factor} as well as \link[haven]{as_factor}, by appending
 #' original attributes except for "class" after converting to factor to avoid
 #' ta loss in case of rich formatted and labelled data.
 #'
@@ -128,10 +128,6 @@ as_factor.haven_labelled <- function(x, levels = c("default", "labels", "values"
 #' @rdname as_factor
 as_factor.labelled <- as_factor.haven_labelled
 
-#' @export
-#' @rdname as_factor
-as_factor.redcapcast_labelled <- as_factor.haven_labelled
-
 #' @rdname as_factor
 #' @export
 as_factor.data.frame <- function(x, ..., only_labelled = TRUE) {
@@ -158,7 +154,7 @@ as_factor.data.frame <- function(x, ..., only_labelled = TRUE) {
 #'   labels = c(Unknown = 9, Refused = 10),
 #'   class = "haven_labelled"
 #' ) |> is.labelled()
-is.labelled <- function(x, classes = c("redcapcast_labelled", "haven_labelled", "labelled")) {
+is.labelled <- function(x, classes = c("haven_labelled", "labelled")) {
   classes |>
     sapply(\(.class){
       inherits(x, .class)
@@ -166,7 +162,6 @@ is.labelled <- function(x, classes = c("redcapcast_labelled", "haven_labelled",
     any()
 }
 
-
 replace_with <- function(x, from, to) {
   stopifnot(length(from) == length(to))
 
@@ -200,20 +195,25 @@ replace_with <- function(x, from, to) {
 #' @param na.label character string to refactor NA values. Default is NULL.
 #' @param na.value new value for NA strings. Ignored if na.label is NULL.
 #' Default is 99.
+#' @param sort.numeric sort factor levels if levels are numeric. Default is TRUE
 #'
 #' @return named vector
 #' @export
 #'
 #' @examples
-#' \dontrun{
 #' structure(c(1, 2, 3, 2, 10, 9),
 #'   labels = c(Unknown = 9, Refused = 10),
 #'   class = "haven_labelled"
 #' ) |>
 #'   as_factor() |>
 #'   named_levels()
-#' }
+#' structure(c(1, 2, 3, 2, 10, 9),
-named_levels <- function(data, label = "labels", na.label = NULL, na.value = 99) {
+#'   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)
@@ -245,7 +245,6 @@ named_levels <- function(data, label = "labels", na.label = NULL, na.value = 99)
     )
   }
 
-
   # Handle empty factors
   if (all_na(data)) {
     d <- data.frame(
@@ -280,7 +279,7 @@ named_levels <- function(data, label = "labels", na.label = NULL, na.value = 99)
   out <- stats::setNames(d$value, d$name)
   ## Sort if levels are numeric
   ## Else, they appear in order of appearance
-  if (possibly_numeric(levels(data))) {
+  if (possibly_numeric(levels(data)) && sort.numeric) {
     out <- out |> sort()
   }
   out
@@ -334,19 +333,14 @@ possibly_roman <- function(data) {
 #'   as_factor() |>
 #'   fct2num()
 #'
-#' # Outlier with labels, but no class of origin, handled like numeric vector
+#' structure(c(1, 2, 3, 2, 10, 9),
-#' # structure(c(1, 2, 3, 2, 10, 9),
+#'   labels = c(Unknown = 9, Refused = 10)
-#' #   labels = c(Unknown = 9, Refused = 10)
+#' ) |>
-#' # ) |>
+#'   as_factor() |>
-#' #   as_factor() |>
+#'   fct2num()
-#' #   fct2num()
-#'
-#' v <- sample(6:19, 20, TRUE) |> factor()
-#' dput(v)
-#' named_levels(v)
-#' fct2num(v)
 fct2num <- function(data) {
   stopifnot(is.factor(data))
+
   if (is.character(named_levels(data))) {
     values <- as.numeric(named_levels(data))
   } else {
@@ -357,15 +351,28 @@ fct2num <- function(data) {
 
   ## If no NA on numeric coercion, of original names, then return
   ## original numeric names, else values
-  if (possibly_numeric(out)) {
+  if (possibly_numeric(names(out))) {
     out <- as.numeric(names(out))
   }
   unname(out)
 }
 
+#' 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) {
-  length(stats::na.omit(suppressWarnings(as.numeric(names(data))))) ==
+  suppressWarnings(
+  length(stats::na.omit(as.numeric(data))) ==
     length(data)
+  )
 }
 
 #' Extract attribute. Returns NA if none

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,15 +25,21 @@ 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 uri REDCap database API uri
-#' @param ... arguments passed on to `REDCapCAST::read_redcap_tables()`
+#' @param ... arguments passed on to \link[REDCapCAST]{read_redcap_tables}.
 #'
 #' @return data.frame or list depending on widen.data
 #' @export
+#'
+#' @examples
+#' \dontrun{
+#' easy_redcap("My_new_project",fields=c("record_id","age","hypertension"))
+#' }
 easy_redcap <- function(project.name, widen.data = TRUE, uri, ...) {
-  key <- get_api_key(key.name = paste0(project.name, "_REDCAP_API"))
+  key <- get_api_key(key.name = paste0(project.name, "_REDCAP_API"),
+                     prompt = "Provide REDCap API key:")
 
   out <- read_redcap_tables(
     uri = uri,

R/read_redcap_tables.R

@@ -1,27 +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. Can be
+#' @param raw_or_label raw or label tags. Can be "raw", "label" or "both".
 #'
-#'   * "raw": Standard [REDCapR] method to get raw values.
+#'   * "raw": Standard \link[REDCapR]{redcap_read} method to get raw values.
-#'   * "label": Standard [REDCapR] method to get label values.
+#'   * "label": Standard \link[REDCapR]{redcap_read} method to get label values.
 #'   * "both": Get raw values with REDCap labels applied as labels. Use
-#'   [as_factor()] to format factors with original labels and use the
+#'   \link[REDCapCAST]{as_factor} to format factors with original labels and use
-#'   [gtsummary] package to easily get beautiful tables with original labels
+#'   the  `gtsummary` package functions like \link[gtsummary]{tbl_summary} to
-#'   from REDCap. Use [fct_drop()] to drop empty levels.
+#'   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.
+#' @param ... passed on to \link[REDCapR]{redcap_read}
 #'
 #' @return list of instruments
 #' @importFrom REDCapR redcap_metadata_read redcap_read redcap_event_instruments
@@ -36,8 +42,12 @@ 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 = "all",
+                               ...) {
+
+  raw_or_label <- match.arg(raw_or_label, c("raw","label","both"))
+
   # Getting metadata
   m <-
     REDCapR::redcap_metadata_read(redcap_uri = uri, token = token)[["data"]]
@@ -92,7 +102,8 @@ read_redcap_tables <- function(uri,
     events = events,
     forms = forms,
     records = records,
-    raw_or_label = rorl
+    raw_or_label = rorl,
+    ...
   )[["data"]]
 
   if (raw_or_label=="both"){
@@ -147,6 +158,20 @@ clean_field_label <- function(data) {
 }
 
 
+#' 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() |>
@@ -158,7 +183,7 @@ format_redcap_factor <- function(data, meta) {
       Reduce(c, .x)
     })()
   set_attr(data, label = lvls, attr = "labels") |>
-    set_attr(data, label = "redcapcast_labelled", attr = "class")
+    set_attr(data, label = "labelled", attr = "class")
 }