mirror of
https://github.com/agdamsbo/REDCapCAST.git
synced 2026-06-19 05:07:30 +02:00
restructuring
This commit is contained in:
parent
21c2dc0444
commit
4ad21c7f57
19 changed files with 432 additions and 80 deletions
|
|
@ -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
|
||||
}
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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) {
|
||||
|
|
|
|||
|
|
@ -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{
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue