diff --git a/R/as_factor.R b/R/as_factor.R index 5e4e912..d53db2f 100644 --- a/R/as_factor.R +++ b/R/as_factor.R @@ -11,6 +11,7 @@ #' @export #' @examples #' # will preserve all attributes but class +#' \dontrun{ #' c(1, 4, 3, "A", 7, 8, 1) |> as_factor() #' structure(c(1, 2, 3, 2, 10, 9), #' labels = c(Unknown = 9, Refused = 10) @@ -22,7 +23,7 @@ #' class = "haven_labelled" #' ) |> #' as_factor() -#' +#' } #' @importFrom forcats as_factor #' @importFrom rlang check_dots_used #' @export @@ -74,15 +75,20 @@ as_factor.labelled <- as_factor.haven_labelled #' #' @param data factor #' @param label character string of attribute with named vector of factor labels +#' @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. #' #' @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() +#' } named_levels <- function(data, label = "labels",na.label=NULL, na.value=99) { stopifnot(is.factor(data)) if (!is.null(na.label)){ @@ -141,6 +147,7 @@ named_levels <- function(data, label = "labels",na.label=NULL, na.value=99) { #' @export #' #' @examples +#' \dontrun{ #' c(1, 4, 3, "A", 7, 8, 1) |> #' as_factor() |> fct2num() #' @@ -156,6 +163,7 @@ named_levels <- function(data, label = "labels",na.label=NULL, na.value=99) { #' ) |> #' as_factor() |> #' fct2num() +#' } fct2num <- function(data) { stopifnot(is.factor(data)) as.numeric(named_levels(data))[match(data, names(named_levels(data)))] @@ -171,11 +179,12 @@ fct2num <- function(data) { #' #' @examples #' attr(mtcars$mpg, "label") <- "testing" -#' sapply(mtcars, get_attr) -#' lapply(mtcars, \(.x)get_attr(.x, NULL)) +#' do.call(c,sapply(mtcars, get_attr)) +#' \dontrun{ #' mtcars |> #' numchar2fct(numeric.threshold = 6) |> #' ds2dd_detailed() +#' } get_attr <- function(data, attr = NULL) { if (is.null(attr)) { attributes(data) @@ -195,16 +204,20 @@ get_attr <- function(data, attr = NULL) { #' @param data vector #' @param label label #' @param attr attribute name +#' @param overwrite overwrite existing attributes. Default is FALSE. #' #' @return vector with attribute #' @export #' -set_attr <- function(data, label, attr = NULL) { +set_attr <- function(data, label, attr = NULL, overwrite=FALSE) { if (is.null(attr)) { ## Has to be list... stopifnot(is.list(label)) ## ... with names stopifnot(length(label)==length(names(label))) + if (!overwrite){ + label <- label[!names(label) %in% names(attributes(data))] + } attributes(data) <- c(attributes(data),label) } else { attr(data, attr) <- label @@ -239,11 +252,3 @@ haven_all_levels <- function(data) { out } -# readr::read_rds("/Users/au301842/PAaSO/labelled_test.rds") |> ds2dd_detailed() -#' sample(c(TRUE,FALSE,NA),20,TRUE) |> set_attr("hidden","status") |> trial_fct() |> named_levels(na.label = "Missing") |> sort() -# trial_fct <- function(x){ -# labels <- get_attr(x) -# x <- factor(x, levels = c("FALSE", "TRUE")) -# set_attr(x, labels[-match("class", names(labels))]) -# } - diff --git a/R/ds2dd_detailed.R b/R/ds2dd_detailed.R index 13a515d..ea9fd40 100644 --- a/R/ds2dd_detailed.R +++ b/R/ds2dd_detailed.R @@ -141,6 +141,7 @@ hms2character <- function(data) { #' @export #' #' @examples +#' \dontrun{ #' data <- REDCapCAST::redcapcast_data #' data |> ds2dd_detailed() #' iris |> ds2dd_detailed(add.auto.id = TRUE) @@ -157,6 +158,7 @@ hms2character <- function(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", @@ -416,9 +418,11 @@ mark_complete <- function(upload, ls) { #' @export #' #' @examples +#' \dontrun{ #' mtcars |> #' parse_data() |> #' str() +#' } parse_data <- function(data, guess_type = TRUE, col_types = NULL, @@ -434,7 +438,7 @@ parse_data <- function(data, ## 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 |> - haven::as_factor() + as_factor() } ## Applying readr cols @@ -474,6 +478,7 @@ parse_data <- function(data, #' @importFrom forcats as_factor #' #' @examples +#' \dontrun{ #' sample(seq_len(4), 20, TRUE) |> #' var2fct(6) |> #' summary() @@ -481,9 +486,10 @@ 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) { - forcats::as_factor(data) + as_factor(data) } else { data } @@ -505,9 +511,11 @@ var2fct <- function(data, unique.n) { #' #' @examples #' mtcars |> str() +#' \dontrun{ #' mtcars |> #' numchar2fct(numeric.threshold = 6) |> #' str() +#' } numchar2fct <- function(data, numeric.threshold = 6, character.throshold = 6) { data |> dplyr::mutate( 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 ccf5c42..0e83ed2 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: +bundleId: 9391508 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 0f449a4..c9df87b 100644 --- a/inst/shiny-examples/casting/server.R +++ b/inst/shiny-examples/casting/server.R @@ -24,7 +24,7 @@ server <- function(input, output, session) { out <- read_input(input$ds$datapath) # Saves labels to reapply later - # labels <- lapply(out, get_attr) + labels <- lapply(out, get_attr) out <- out |> ## Parses data with readr functions @@ -44,10 +44,10 @@ server <- function(input, output, session) { } # Old attributes are appended - # out <- purrr::imap(out,\(.x,.i){ - # set_attr(.x,labels[[.i]]) - # }) |> - # dplyr::bind_cols() + out <- purrr::imap(out,\(.x,.i){ + set_attr(.x,labels[[.i]]) + }) |> + dplyr::bind_cols() out }) diff --git a/man/as_factor.Rd b/man/as_factor.Rd index a681fc9..8f10d7b 100644 --- a/man/as_factor.Rd +++ b/man/as_factor.Rd @@ -36,6 +36,7 @@ Please refer to parent functions for extended documentation. } \examples{ # will preserve all attributes but class +\dontrun{ c(1, 4, 3, "A", 7, 8, 1) |> as_factor() structure(c(1, 2, 3, 2, 10, 9), labels = c(Unknown = 9, Refused = 10) @@ -47,5 +48,5 @@ structure(c(1, 2, 3, 2, 10, 9), class = "haven_labelled" ) |> as_factor() - +} } diff --git a/man/ds2dd_detailed.Rd b/man/ds2dd_detailed.Rd index 5053421..8fcef47 100644 --- a/man/ds2dd_detailed.Rd +++ b/man/ds2dd_detailed.Rd @@ -75,6 +75,7 @@ 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() iris |> ds2dd_detailed(add.auto.id = TRUE) @@ -92,3 +93,4 @@ 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/fct2num.Rd b/man/fct2num.Rd index 2d6c99e..fb76c70 100644 --- a/man/fct2num.Rd +++ b/man/fct2num.Rd @@ -16,6 +16,7 @@ numeric vector Allows conversion of factor to numeric values preserving original levels } \examples{ +\dontrun{ c(1, 4, 3, "A", 7, 8, 1) |> as_factor() |> fct2num() @@ -31,4 +32,5 @@ structure(c(1, 2, 3, 2, 10, 9), ) |> as_factor() |> fct2num() + } } diff --git a/man/get_attr.Rd b/man/get_attr.Rd index b6757f6..9c9d874 100644 --- a/man/get_attr.Rd +++ b/man/get_attr.Rd @@ -19,9 +19,10 @@ Extract attribute. Returns NA if none } \examples{ attr(mtcars$mpg, "label") <- "testing" -sapply(mtcars, get_attr) -lapply(mtcars, \(.x)get_attr(.x, NULL)) +do.call(c,sapply(mtcars, get_attr)) +\dontrun{ mtcars |> numchar2fct(numeric.threshold = 6) |> ds2dd_detailed() } +} diff --git a/man/named_levels.Rd b/man/named_levels.Rd index e1481f6..40553c2 100644 --- a/man/named_levels.Rd +++ b/man/named_levels.Rd @@ -10,6 +10,11 @@ named_levels(data, label = "labels", na.label = NULL, na.value = 99) \item{data}{factor} \item{label}{character string of attribute with named vector of factor labels} + +\item{na.label}{character string to refactor NA values. Default is NULL.} + +\item{na.value}{new value for NA strings. Ignored if na.label is NULL. +Default is 99.} } \value{ named vector @@ -18,8 +23,10 @@ named vector Get named vector of factor levels and values } \examples{ +\dontrun{ structure(c(1, 2, 3, 2, 10, 9), labels = c(Unknown = 9, Refused = 10), class = "haven_labelled" ) |> as_factor() |> named_levels() } +} diff --git a/man/numchar2fct.Rd b/man/numchar2fct.Rd index bb9da29..815ade6 100644 --- a/man/numchar2fct.Rd +++ b/man/numchar2fct.Rd @@ -23,7 +23,9 @@ Individual thresholds for character and numeric columns } \examples{ mtcars |> str() +\dontrun{ mtcars |> numchar2fct(numeric.threshold = 6) |> str() } +} diff --git a/man/parse_data.Rd b/man/parse_data.Rd index db54782..11d95fa 100644 --- a/man/parse_data.Rd +++ b/man/parse_data.Rd @@ -33,7 +33,9 @@ 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/set_attr.Rd b/man/set_attr.Rd index a7b3884..8af2860 100644 --- a/man/set_attr.Rd +++ b/man/set_attr.Rd @@ -4,7 +4,7 @@ \alias{set_attr} \title{Set attributes for named attribute. Appends if attr is NULL} \usage{ -set_attr(data, label, attr = NULL) +set_attr(data, label, attr = NULL, overwrite = FALSE) } \arguments{ \item{data}{vector} @@ -12,6 +12,8 @@ set_attr(data, label, attr = NULL) \item{label}{label} \item{attr}{attribute name} + +\item{overwrite}{overwrite existing attributes. Default is FALSE.} } \value{ vector with attribute diff --git a/man/var2fct.Rd b/man/var2fct.Rd index 5b2265f..50038a0 100644 --- a/man/var2fct.Rd +++ b/man/var2fct.Rd @@ -19,6 +19,7 @@ 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() @@ -27,3 +28,4 @@ sample(letters, 20) |> summary() sample(letters[1:4], 20, TRUE) |> var2fct(6) } +}