executing examples with as_factor() errors. I think due to redundancy. Will investigate.

2024-11-22 05:20:23 +01:00 · 2024-11-20 12:40:29 +01:00 · 2024-11-20 12:40:29 +01:00 · c86ae9a364
commit c86ae9a364
parent 69e1520aff
13 changed files with 58 additions and 24 deletions
--- 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))])
-# }
-
--- 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(
--- 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
--- 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
  })
--- 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()
-
+}
 }
--- 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 = "__")
 }
+}
--- 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()
+  }
 }
--- 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()
 }
+}
--- 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()
 }
+}
--- 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()
 }
+}
--- 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()
 }
+}
--- 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
--- 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)
 }
+}