diff --git a/NAMESPACE b/NAMESPACE index b9939b2..6ec3128 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -11,6 +11,7 @@ S3method(process_user_input,data.frame) S3method(process_user_input,default) S3method(process_user_input,response) export(REDCap_split) +export(all_na) export(as_factor) export(case_match_regex_list) export(cast_data_overview) @@ -18,6 +19,7 @@ export(cast_meta_overview) export(char2choice) export(char2cond) export(clean_redcap_name) +export(compact_vec) export(create_html_table) export(create_instrument_meta) export(d2w) @@ -42,6 +44,7 @@ export(named_levels) export(nav_bar_page) export(numchar2fct) export(parse_data) +export(possibly_roman) export(process_user_input) export(read_input) export(read_redcap_instrument) @@ -53,6 +56,7 @@ export(shiny_cast) export(split_non_repeating_forms) export(strsplitx) export(var2fct) +export(vec2choice) importFrom(REDCapR,redcap_event_instruments) importFrom(REDCapR,redcap_metadata_read) importFrom(REDCapR,redcap_read) diff --git a/R/as_factor.R b/R/as_factor.R index 982deb3..d6d7fd1 100644 --- a/R/as_factor.R +++ b/R/as_factor.R @@ -56,13 +56,14 @@ as_factor.numeric <- function(x, ...) { #' @export as_factor.character <- function(x, ...) { labels <- get_attr(x) - if (is.roman(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) } @@ -201,11 +202,19 @@ named_levels <- function(data, label = "labels", na.label = NULL, na.value = 99) ) } - d <- data.frame( - name = levels(data)[data], - value = as.numeric(data) - ) |> - unique() + # 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() + } ## Applying labels attr_l <- attr(x = data, which = label, exact = TRUE) @@ -227,8 +236,21 @@ named_levels <- function(data, label = "labels", na.label = NULL, na.value = 99) out } -is.roman <- function(data){ - identical(data,as.character(utils::as.roman(data))) +#' 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){ + # browser() + if (all(is.na(data))) return(FALSE) + identical(as.character(data),as.character(utils::as.roman(data))) } diff --git a/R/ds2dd_detailed.R b/R/ds2dd_detailed.R index 1d41de5..73fb7f0 100644 --- a/R/ds2dd_detailed.R +++ b/R/ds2dd_detailed.R @@ -141,10 +141,15 @@ hms2character <- function(data) { #' @export #' #' @examples -#' \dontrun{ -#' data <- REDCapCAST::redcapcast_data -#' data |> ds2dd_detailed() +#' ## Basic parsing with default options +#' 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, @@ -152,13 +157,14 @@ hms2character <- function(data) { #' ) |> #' 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", @@ -171,24 +177,18 @@ ds2dd_detailed <- function(data, field.validation = NULL, metadata = names(REDCapCAST::redcapcast_meta), 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) { - # Labels/attributes are saved - # labels <- lapply(data, \(.x){ - # get_attr(.x, attr = NULL) - # }) - data <- data |> ## Converts logical to factor, which overwrites attributes dplyr::mutate(dplyr::across(dplyr::where(is.logical), as_factor)) - - # Old attributes are appended - # data <- purrr::imap(no_attr,\(.x,.i){ - # attributes(.x) <- c(attributes(.x),labels[[.i]]) - # .x - # }) |> - # dplyr::bind_cols() - } ## Handles the odd case of no id column present @@ -197,9 +197,6 @@ ds2dd_detailed <- function(data, record_id = seq_len(nrow(data)), data ) - # set_attr(data$record_id,label="ID",attr="label") - - message("A default id column has been added") } ## --------------------------------------- @@ -227,6 +224,9 @@ ds2dd_detailed <- function(data, 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))) @@ -251,14 +251,20 @@ ds2dd_detailed <- function(data, if (is.null(field.label)) { dd$field_label <- data |> sapply(function(x) { - get_attr(x, attr = field.label.attr) + get_attr(x, attr = field.label.attr) |> + compact_vec() }) dd <- - dd |> dplyr::mutate(field_label = dplyr::if_else(is.na(field_label), - field_name, field_label - )) + 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 { @@ -312,23 +318,16 @@ ds2dd_detailed <- function(data, ## choices factor_levels <- data |> - lapply(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 - lvls <- sort(named_levels(x)) - paste( - paste(lvls, - names(lvls), - sep = ", " - ), - collapse = " | " - ) - } else { - NA - } - }) |> - (\(x)do.call(c, x))() + 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( @@ -346,10 +345,22 @@ ds2dd_detailed <- function(data, meta = dd ) - class(out) <- c("REDCapCAST",class(out)) + 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 #' @@ -423,11 +434,9 @@ mark_complete <- function(upload, ls) { #' @export #' #' @examples -#' \dontrun{ #' mtcars |> #' parse_data() |> #' str() -#' } parse_data <- function(data, guess_type = TRUE, col_types = NULL, @@ -483,7 +492,6 @@ parse_data <- function(data, #' @importFrom forcats as_factor #' #' @examples -#' \dontrun{ #' sample(seq_len(4), 20, TRUE) |> #' var2fct(6) |> #' summary() @@ -491,7 +499,6 @@ parse_data <- function(data, #' 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) @@ -540,5 +547,59 @@ numchar2fct <- function(data, numeric.threshold = 6, character.throshold = 6) { } +#' 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 + ) + } +} diff --git a/R/shiny_cast.R b/R/shiny_cast.R index eb28174..585c34e 100644 --- a/R/shiny_cast.R +++ b/R/shiny_cast.R @@ -21,7 +21,6 @@ shiny_cast <- function(...) { } - #' DEPRECATED Helper to import files correctly #' #' @param filenames file names diff --git a/inst/shiny-examples/casting/rsconnect/shinyapps.io/agdamsbo/redcapcast.dcf b/inst/shiny-examples/casting/rsconnect/shinyapps.io/agdamsbo/redcapcast.dcf index c22cdf3..f353f52 100644 --- a/inst/shiny-examples/casting/rsconnect/shinyapps.io/agdamsbo/redcapcast.dcf +++ b/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: 9392320 +bundleId: 9392352 url: https://agdamsbo.shinyapps.io/redcapcast/ version: 1 diff --git a/inst/shiny-examples/casting/server.R b/inst/shiny-examples/casting/server.R index 7fe60ba..0fbc6c2 100644 --- a/inst/shiny-examples/casting/server.R +++ b/inst/shiny-examples/casting/server.R @@ -63,8 +63,8 @@ server <- function(input, output, session) { v$file <- "loaded" ds2dd_detailed( data = dat(), - add.auto.id = input$add_id=="yes" - ) + add.auto.id = input$add_id == "yes" + ) }) output$uploaded <- shiny::reactive({ @@ -131,8 +131,9 @@ server <- function(input, output, session) { 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])) + file = file, + record.id = ifelse(input$add_id == "none", NA, names(dat())[1]) + ) } ) diff --git a/inst/shiny-examples/casting/ui.R b/inst/shiny-examples/casting/ui.R index 221d54b..2a293ff 100644 --- a/inst/shiny-examples/casting/ui.R +++ b/inst/shiny-examples/casting/ui.R @@ -2,6 +2,5 @@ ui <- bslib::page( theme = bslib::bs_theme(preset = "united"), title = "REDCap database creator", -nav_bar_page() + nav_bar_page() ) - diff --git a/man/all_na.Rd b/man/all_na.Rd new file mode 100644 index 0000000..9092e71 --- /dev/null +++ b/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() +} diff --git a/man/compact_vec.Rd b/man/compact_vec.Rd new file mode 100644 index 0000000..1daaaed --- /dev/null +++ b/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() +} diff --git a/man/ds2dd_detailed.Rd b/man/ds2dd_detailed.Rd index 8fcef47..0cac82f 100644 --- a/man/ds2dd_detailed.Rd +++ b/man/ds2dd_detailed.Rd @@ -75,10 +75,15 @@ Ensure, that the data set is formatted with as much information as possible. `field.type` can be supplied } \examples{ -\dontrun{ -data <- REDCapCAST::redcapcast_data -data |> ds2dd_detailed() +## Basic parsing with default options +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, @@ -86,6 +91,8 @@ iris |> ) |> 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") @@ -93,4 +100,3 @@ 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 = "__") } -} diff --git a/man/parse_data.Rd b/man/parse_data.Rd index 11d95fa..db54782 100644 --- a/man/parse_data.Rd +++ b/man/parse_data.Rd @@ -33,9 +33,7 @@ data.frame or tibble Helper to auto-parse un-formatted data with haven and readr } \examples{ -\dontrun{ mtcars |> parse_data() |> str() } -} diff --git a/man/possibly_roman.Rd b/man/possibly_roman.Rd new file mode 100644 index 0000000..fad8232 --- /dev/null +++ b/man/possibly_roman.Rd @@ -0,0 +1,22 @@ +% 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() +} diff --git a/man/var2fct.Rd b/man/var2fct.Rd index 50038a0..5b2265f 100644 --- a/man/var2fct.Rd +++ b/man/var2fct.Rd @@ -19,7 +19,6 @@ This is a wrapper of forcats::as_factor, which sorts numeric vectors before factoring, but levels character vectors in order of appearance. } \examples{ -\dontrun{ sample(seq_len(4), 20, TRUE) |> var2fct(6) |> summary() @@ -28,4 +27,3 @@ sample(letters, 20) |> summary() sample(letters[1:4], 20, TRUE) |> var2fct(6) } -} diff --git a/man/vec2choice.Rd b/man/vec2choice.Rd new file mode 100644 index 0000000..b9c0e17 --- /dev/null +++ b/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() +}