mirror of
https://github.com/agdamsbo/REDCapCAST.git
synced 2024-11-27 15:21:55 +01:00
710 lines
20 KiB
R
710 lines
20 KiB
R
utils::globalVariables(c(
|
|
"stats::setNames",
|
|
"field_name",
|
|
"field_type",
|
|
"select_choices_or_calculations",
|
|
"field_label"
|
|
))
|
|
#' Try at determining which are true time only variables
|
|
#'
|
|
#' @description
|
|
#' This is just a try at guessing data type based on data class and column names
|
|
#' hoping for a tiny bit of naming consistency. R does not include a time-only
|
|
#' data format natively, so the "hms" class from `readr` is used. This
|
|
#' has to be converted to character class before REDCap upload.
|
|
#'
|
|
#' @param data data set
|
|
#' @param validate flag to output validation data. Will output list.
|
|
#' @param sel.pos Positive selection regex string
|
|
#' @param sel.neg Negative selection regex string
|
|
#'
|
|
#' @return character vector or list depending on `validate` flag.
|
|
#' @export
|
|
#'
|
|
#' @examples
|
|
#' data <- redcapcast_data
|
|
#' data |> guess_time_only_filter()
|
|
#' data |>
|
|
#' guess_time_only_filter(validate = TRUE) |>
|
|
#' lapply(head)
|
|
guess_time_only_filter <- function(data,
|
|
validate = FALSE,
|
|
sel.pos = "[Tt]i[d(me)]",
|
|
sel.neg = "[Dd]at[eo]") {
|
|
datetime_nms <- data |>
|
|
lapply(\(x) any(c("POSIXct", "hms") %in% class(x))) |>
|
|
(\(x) names(data)[do.call(c, x)])()
|
|
|
|
time_only_log <- datetime_nms |> (\(x) {
|
|
## Detects which are determined true Time only variables
|
|
## Inspection is necessary
|
|
grepl(pattern = sel.pos, x = x) &
|
|
!grepl(pattern = sel.neg, x = x)
|
|
})()
|
|
|
|
if (validate) {
|
|
list(
|
|
"is.POSIX" = data[datetime_nms],
|
|
"is.datetime" = data[datetime_nms[!time_only_log]],
|
|
"is.time_only" = data[datetime_nms[time_only_log]]
|
|
)
|
|
} else {
|
|
datetime_nms[time_only_log]
|
|
}
|
|
}
|
|
|
|
#' Correction based on time_only_filter function
|
|
#'
|
|
#'
|
|
#' @param data data set
|
|
#' @param ... arguments passed on to `guess_time_only_filter()`
|
|
#'
|
|
#' @return tibble
|
|
#' @importFrom readr parse_time
|
|
#'
|
|
#' @examples
|
|
#' data <- redcapcast_data
|
|
#' ## data |> time_only_correction()
|
|
time_only_correction <- function(data, ...) {
|
|
nms <- guess_time_only_filter(data, ...)
|
|
z <- nms |>
|
|
lapply(\(y) {
|
|
readr::parse_time(format(data[[y]], format = "%H:%M:%S"))
|
|
}) |>
|
|
suppressMessages(dplyr::bind_cols()) |>
|
|
stats::setNames(nm = nms)
|
|
data[nms] <- z
|
|
data
|
|
}
|
|
|
|
#' Change "hms" to "character" for REDCap upload.
|
|
#'
|
|
#' @param data data set
|
|
#'
|
|
#' @return data.frame or tibble
|
|
#'
|
|
#' @examples
|
|
#' data <- redcapcast_data
|
|
#' ## data |> time_only_correction() |> hms2character()
|
|
hms2character <- function(data) {
|
|
data |>
|
|
lapply(function(x) {
|
|
if ("hms" %in% class(x)) {
|
|
as.character(x)
|
|
} else {
|
|
x
|
|
}
|
|
}) |>
|
|
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
|
|
#' This function is a natural development of the ds2dd() function. It assumes
|
|
#' that the first column is the ID-column. No checks.
|
|
#' Please, do always inspect the data dictionary before upload.
|
|
#'
|
|
#' Ensure, that the data set is formatted with as much information as possible.
|
|
#'
|
|
#' `field.type` can be supplied
|
|
#'
|
|
#' @param data data frame
|
|
#' @param date.format date format, character string. ymd/dmy/mdy. dafault is
|
|
#' dmy.
|
|
#' @param add.auto.id flag to add id column
|
|
#' @param form.name manually specify form name(s). Vector of length 1 or
|
|
#' 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.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
|
|
#' ncol(data). Default is NULL and "text" is used for everything but factors,
|
|
#' which wil get "radio".
|
|
#' @param field.label manually specify field label(s). Vector of length 1 or
|
|
#' ncol(data). Default is NULL and colnames(data) is used or attribute
|
|
#' `field.label.attr` for haven_labelled data set (imported .dta file with
|
|
#' `haven::read_dta()`).
|
|
#' @param field.label.attr attribute name for named labels for haven_labelled
|
|
#' data set (imported .dta file with `haven::read_dta()`. Default is "label"
|
|
#' @param field.validation manually specify field validation(s). Vector of
|
|
#' length 1 or ncol(data). Default is NULL and `levels()` are used for factors
|
|
#' 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::redcap_meta_default().
|
|
#' @param convert.logicals convert logicals to factor. Default is TRUE.
|
|
#'
|
|
#' @return list of length 2
|
|
#' @export
|
|
#'
|
|
#' @examples
|
|
#' ## Basic parsing with default options
|
|
#' requireNamespace("REDCapCAST")
|
|
#' redcapcast_data |>
|
|
#' dplyr::select(-dplyr::starts_with("redcap_")) |>
|
|
#' ds2dd_detailed()
|
|
#'
|
|
#' ## Adding a record_id field
|
|
#' iris |> 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 |> 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 = "__")
|
|
ds2dd_detailed <- function(data,
|
|
add.auto.id = FALSE,
|
|
date.format = "dmy",
|
|
form.name = NULL,
|
|
form.sep = NULL,
|
|
form.prefix = TRUE,
|
|
field.type = NULL,
|
|
field.label = NULL,
|
|
field.label.attr = "label",
|
|
field.validation = NULL,
|
|
metadata = REDCapCAST::redcap_meta_default(),
|
|
convert.logicals = TRUE) {
|
|
|
|
if (convert.logicals) {
|
|
data <- data |>
|
|
## Converts logical to factor, which overwrites attributes
|
|
dplyr::mutate(dplyr::across(dplyr::where(is.logical), as_factor))
|
|
}
|
|
|
|
## Handles the odd case of no id column present
|
|
if (add.auto.id) {
|
|
data <- dplyr::tibble(
|
|
record_id = seq_len(nrow(data)),
|
|
data
|
|
)
|
|
}
|
|
|
|
## ---------------------------------------
|
|
## Building the data dictionary
|
|
## ---------------------------------------
|
|
|
|
## skeleton
|
|
|
|
dd <- data.frame(matrix(ncol = length(metadata), nrow = ncol(data))) |>
|
|
stats::setNames(metadata) |>
|
|
dplyr::tibble()
|
|
|
|
## form_name and field_name
|
|
|
|
if (!is.null(form.sep)) {
|
|
if (form.sep != "") {
|
|
parts <- strsplit(names(data), split = form.sep)
|
|
|
|
## 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
|
|
## The other split part is used as field names
|
|
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)))
|
|
}
|
|
} else {
|
|
## if no form name prefix, the colnames are used as field_names
|
|
dd$field_name <- gsub(" ", "_", tolower(colnames(data)))
|
|
|
|
if (is.null(form.name)) {
|
|
dd$form_name <- "data"
|
|
} else {
|
|
if (length(form.name) == 1 || length(form.name) == nrow(dd)) {
|
|
dd$form_name <- form.name
|
|
} else {
|
|
stop("Length of supplied 'form.name' has to be one (1) or ncol(data).")
|
|
}
|
|
}
|
|
}
|
|
|
|
## field_label
|
|
|
|
if (is.null(field.label)) {
|
|
dd$field_label <- data |>
|
|
sapply(function(x) {
|
|
get_attr(x, attr = field.label.attr) |>
|
|
compact_vec()
|
|
})
|
|
|
|
dd <-
|
|
dd |>
|
|
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 {
|
|
stop("Length of supplied 'field.label' has to be one (1) or ncol(data).")
|
|
}
|
|
}
|
|
|
|
data_classes <- do.call(c, lapply(data, \(.x)class(.x)[1]))
|
|
|
|
## field_type
|
|
|
|
if (is.null(field.type)) {
|
|
dd$field_type <- "text"
|
|
|
|
dd <-
|
|
dd |> dplyr::mutate(field_type = dplyr::if_else(data_classes == "factor",
|
|
"radio", field_type
|
|
))
|
|
} else {
|
|
if (length(field.type) == 1 || length(field.type) == nrow(dd)) {
|
|
dd$field_type <- field.type
|
|
} else {
|
|
stop("Length of supplied 'field.type' has to be one (1) or ncol(data).")
|
|
}
|
|
}
|
|
|
|
## validation
|
|
if (is.null(field.validation)) {
|
|
dd <-
|
|
dd |> dplyr::mutate(
|
|
text_validation_type_or_show_slider_number = dplyr::case_when(
|
|
data_classes == "Date" ~ paste0("date_", date.format),
|
|
data_classes ==
|
|
"hms" ~ "time_hh_mm_ss",
|
|
## Self invented format after filtering
|
|
data_classes ==
|
|
"POSIXct" ~ paste0("datetime_", date.format),
|
|
data_classes ==
|
|
"numeric" ~ "number"
|
|
)
|
|
)
|
|
} else {
|
|
if (length(field.validation) == 1 || length(field.validation) == nrow(dd)) {
|
|
dd$text_validation_type_or_show_slider_number <- field.validation
|
|
} else {
|
|
stop("Length of supplied 'field.validation'
|
|
has to be one (1) or ncol(data).")
|
|
}
|
|
}
|
|
|
|
## choices
|
|
|
|
factor_levels <- data |>
|
|
sapply(function(x) {
|
|
if (is.factor(x)) {
|
|
## Custom function to ensure factor order and keep original values
|
|
## Avoiding refactoring to keep as much information as possible
|
|
sort(named_levels(x)) |>
|
|
vec2choice()
|
|
} else {
|
|
NA
|
|
}
|
|
})
|
|
|
|
dd <-
|
|
dd |> dplyr::mutate(
|
|
select_choices_or_calculations = dplyr::if_else(
|
|
is.na(factor_levels),
|
|
select_choices_or_calculations,
|
|
factor_levels
|
|
)
|
|
)
|
|
|
|
out <- list(
|
|
data = data |>
|
|
hms2character() |>
|
|
stats::setNames(dd$field_name),
|
|
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
|
|
#'
|
|
#' @param upload output list from `REDCapR::redcap_write()`
|
|
#' @param ls output list from `ds2dd_detailed()`
|
|
#'
|
|
#' @return list with `REDCapR::redcap_write()` results
|
|
mark_complete <- function(upload, ls) {
|
|
data <- ls$data
|
|
meta <- ls$meta
|
|
forms <- unique(meta$form_name)
|
|
cbind(
|
|
data[[1]][data[[1]] %in% upload$affected_ids],
|
|
data.frame(matrix(2,
|
|
ncol = length(forms),
|
|
nrow = upload$records_affected_count
|
|
))
|
|
) |>
|
|
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 = "; ") {
|
|
# browser()
|
|
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
|
|
)
|
|
}
|
|
}
|