From c86ae9a364291a234cd464560969ce15326419d4 Mon Sep 17 00:00:00 2001
From: Andreas Gammelgaard Damsbo <andreas@gdamsbo.dk>
Date: Wed, 20 Nov 2024 12:40:29 +0100
Subject: [PATCH] executing examples with as_factor() errors. I think due to
 redundancy. Will investigate.

---
 R/as_factor.R                                 | 29 +++++++++++--------
 R/ds2dd_detailed.R                            | 12 ++++++--
 .../shinyapps.io/agdamsbo/redcapcast.dcf      |  2 +-
 inst/shiny-examples/casting/server.R          | 10 +++----
 man/as_factor.Rd                              |  3 +-
 man/ds2dd_detailed.Rd                         |  2 ++
 man/fct2num.Rd                                |  2 ++
 man/get_attr.Rd                               |  5 ++--
 man/named_levels.Rd                           |  7 +++++
 man/numchar2fct.Rd                            |  2 ++
 man/parse_data.Rd                             |  2 ++
 man/set_attr.Rd                               |  4 ++-
 man/var2fct.Rd                                |  2 ++
 13 files changed, 58 insertions(+), 24 deletions(-)

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)
 }
+}