moving functions from app to fix dependencies

DESCRIPTION

@@ -29,16 +29,11 @@ Suggests:
     Hmisc,
     knitr,
     rmarkdown,
-    gt,
-    ggplot2,
-    here,
     styler,
     devtools,
     roxygen2,
     spelling,
-    glue,
-    rhub,
-    bslib
+    rhub
 License: GPL (>= 3)
 Encoding: UTF-8
 LazyData: true
@@ -61,7 +56,11 @@ Imports:
     openxlsx2,
     readODS,
     forcats,
-    rlang
+    vctrs,
+    gt,
+    bslib,
+    here,
+    glue
 Collate: 
     'REDCapCAST-package.R'
     'utils.r'

NAMESPACE

@@ -1,6 +1,7 @@
 # Generated by roxygen2: do not edit by hand
 
 S3method(as_factor,character)
+S3method(as_factor,factor)
 S3method(as_factor,haven_labelled)
 S3method(as_factor,labelled)
 S3method(as_factor,logical)
@@ -12,6 +13,8 @@ S3method(process_user_input,response)
 export(REDCap_split)
 export(as_factor)
 export(case_match_regex_list)
+export(cast_data_overview)
+export(cast_meta_overview)
 export(char2choice)
 export(char2cond)
 export(clean_redcap_name)
@@ -36,6 +39,7 @@ export(html_tag_wrap)
 export(is_repeated_longitudinal)
 export(match_fields_to_form)
 export(named_levels)
+export(nav_bar_page)
 export(numchar2fct)
 export(parse_data)
 export(process_user_input)
@@ -59,6 +63,5 @@ importFrom(keyring,key_set)
 importFrom(openxlsx2,read_xlsx)
 importFrom(purrr,reduce)
 importFrom(readr,parse_time)
-importFrom(rlang,check_dots_used)
 importFrom(tidyr,pivot_wider)
 importFrom(tidyselect,all_of)

R/as_factor.R

@@ -5,87 +5,173 @@
 #' ta loss in case of rich formatted and labelled data.
 #'
 #' Please refer to parent functions for extended documentation.
+#' To avoid redundancy calls and errors, functions are copy-pasted here
 #'
 #' @param x Object to coerce to a factor.
 #' @param ... Other arguments passed down to method.
 #' @export
 #' @examples
-#' # will preserve all attributes but class
+#' # will preserve all attributes
 #' c(1, 4, 3, "A", 7, 8, 1) |> as_factor()
 #' structure(c(1, 2, 3, 2, 10, 9),
 #'   labels = c(Unknown = 9, Refused = 10)
 #' ) |>
-#'   as_factor()
+#'   as_factor() |> dput()
 #'
 #' structure(c(1, 2, 3, 2, 10, 9),
 #'   labels = c(Unknown = 9, Refused = 10),
 #'   class = "haven_labelled"
 #' ) |>
 #'   as_factor()
-#'
 #' @importFrom forcats as_factor
-#' @importFrom rlang check_dots_used
 #' @export
 #' @name as_factor
 as_factor <- function(x, ...) {
-  rlang::check_dots_used()
   UseMethod("as_factor")
 }
 
+#' @rdname as_factor
+#' @export
+as_factor.factor <- function(x, ...) {
+  x
+}
+
 #' @rdname as_factor
 #' @export
 as_factor.logical <- function(x, ...) {
   labels <- get_attr(x)
-  x <- forcats::as_factor(x, ...)
-  set_attr(x, labels[-match("class", names(labels))])
+  x <- factor(x, levels = c("FALSE", "TRUE"))
+  set_attr(x, labels, overwrite = FALSE)
 }
 
 #' @rdname as_factor
 #' @export
 as_factor.numeric <- function(x, ...) {
   labels <- get_attr(x)
-  x <- forcats::as_factor(x, ...)
-  set_attr(x, labels[-match("class", names(labels))])
+  x <- factor(x)
+  set_attr(x, labels, overwrite = FALSE)
 }
 
 #' @rdname as_factor
 #' @export
 as_factor.character <- function(x, ...) {
   labels <- get_attr(x)
-  x <- forcats::as_factor(x, ...)
-  set_attr(x, labels[-match("class", names(labels))])
+  if (is.roman(x)){
+    x <- factor(x)
+  } else {
+  x <- structure(
+    forcats::fct_inorder(x),
+    label = attr(x, "label", exact = TRUE)
+  )}
+  set_attr(x, labels, overwrite = FALSE)
 }
 
+#' @param ordered If `TRUE` create an ordered (ordinal) factor, if
+#'   `FALSE` (the default) create a regular (nominal) factor.
+#' @param levels How to create the levels of the generated factor:
+#'
+#'   * "default": uses labels where available, otherwise the values.
+#'     Labels are sorted by value.
+#'   * "both": like "default", but pastes together the level and value
+#'   * "label": use only the labels; unlabelled values become `NA`
+#'   * "values": use only the values
 #' @rdname as_factor
 #' @export
-as_factor.haven_labelled <- function(x, ...) {
-  labels <- get_attr(x)
-  x <- haven::as_factor(x, ...)
-  set_attr(x, labels[-match("class", names(labels))])
+as_factor.haven_labelled <- function(x, levels = c("default", "labels", "values", "both"),
+                                     ordered = FALSE, ...) {
+  labels_all <- get_attr(x)
+
+  levels <- match.arg(levels)
+  label <- attr(x, "label", exact = TRUE)
+  labels <- attr(x, "labels")
+
+  if (levels %in% c("default", "both")) {
+    if (levels == "both") {
+      names(labels) <- paste0("[", labels, "] ", names(labels))
+    }
+
+    # Replace each value with its label
+    vals <- unique(vctrs::vec_data(x))
+    levs <- replace_with(vals, unname(labels), names(labels))
+    # Ensure all labels are preserved
+    levs <- sort(c(stats::setNames(vals, levs), labels), na.last = TRUE)
+    levs <- unique(names(levs))
+
+    x <- replace_with(vctrs::vec_data(x), unname(labels), names(labels))
+
+    x <- factor(x, levels = levs, ordered = ordered)
+  } else if (levels == "labels") {
+    levs <- unname(labels)
+    labs <- names(labels)
+    x <- replace_with(vctrs::vec_data(x), levs, labs)
+    x <- factor(x, unique(labs), ordered = ordered)
+  } else if (levels == "values") {
+    if (all(x %in% labels)) {
+      levels <- unname(labels)
+    } else {
+      levels <- sort(unique(vctrs::vec_data(x)))
+    }
+    x <- factor(vctrs::vec_data(x), levels, ordered = ordered)
+  }
+
+  x <- structure(x, label = label)
+
+  set_attr(x, labels_all, overwrite = FALSE)
 }
 
 #' @export
 #' @rdname as_factor
 as_factor.labelled <- as_factor.haven_labelled
 
+replace_with <- function(x, from, to) {
+  stopifnot(length(from) == length(to))
+
+  out <- x
+  # First replace regular values
+  matches <- match(x, from, incomparables = NA)
+  if (anyNA(matches)) {
+    out[!is.na(matches)] <- to[matches[!is.na(matches)]]
+  } else {
+    out <- to[matches]
+  }
+
+  # Then tagged missing values
+  tagged <- haven::is_tagged_na(x)
+  if (!any(tagged)) {
+    return(out)
+  }
+
+  matches <- match(haven::na_tag(x), haven::na_tag(from), incomparables = NA)
+
+  # Could possibly be faster to use anyNA(matches)
+  out[!is.na(matches)] <- to[matches[!is.na(matches)]]
+  out
+}
 
 
 #' Get named vector of factor levels and values
 #'
 #' @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) {
+#' ) |>
+#'   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)){
+  if (!is.null(na.label)) {
     attrs <- attributes(data)
     lvls <- as.character(data)
     lvls[is.na(lvls)] <- na.label
@@ -95,17 +181,24 @@ named_levels <- function(data, label = "labels",na.label=NULL, na.value=99) {
     lbls <- data.frame(
       name = lvls,
       value = vals
-    ) |> unique() |>
+    ) |>
+      unique() |>
       (\(d){
         stats::setNames(d$value, d$name)
       })() |>
       sort()
 
-    data <- do.call(structure,
-            c(list(.Data=match(vals,lbls)),
+    data <- do.call(
+      structure,
+      c(
+        list(.Data = match(vals, lbls)),
         attrs[-match("levels", names(attrs))],
-              list(levels=names(lbls),
-                   labels=lbls)))
+        list(
+          levels = names(lbls),
+          labels = lbls
+        )
+      )
+    )
   }
 
   d <- data.frame(
@@ -117,21 +210,27 @@ named_levels <- function(data, label = "labels",na.label=NULL, na.value=99) {
   ## Applying labels
   attr_l <- attr(x = data, which = label, exact = TRUE)
   if (length(attr_l) != 0) {
+    if (all(names(attr_l) %in% d$name)){
       d$value[match(names(attr_l), d$name)] <- 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)
+    }
   }
 
   out <- stats::setNames(d$value, d$name)
   ## Sort if levels are numeric
   ## Else, they appear in order of appearance
-  if (identical(
-    levels(data),
-    suppressWarnings(as.character(as.numeric(levels(data))))
-  )) {
+  if (possibly_numeric(levels(data))) {
     out <- out |> sort()
   }
   out
 }
 
+is.roman <- function(data){
+  identical(data,as.character(utils::as.roman(data)))
+}
+
 
 #' Allows conversion of factor to numeric values preserving original levels
 #'
@@ -142,7 +241,8 @@ named_levels <- function(data, label = "labels",na.label=NULL, na.value=99) {
 #'
 #' @examples
 #' c(1, 4, 3, "A", 7, 8, 1) |>
-#' as_factor() |> fct2num()
+#'   as_factor() |>
+#'   fct2num()
 #'
 #' structure(c(1, 2, 3, 2, 10, 9),
 #'   labels = c(Unknown = 9, Refused = 10),
@@ -152,13 +252,44 @@ named_levels <- function(data, label = "labels",na.label=NULL, na.value=99) {
 #'   fct2num()
 #'
 #' structure(c(1, 2, 3, 2, 10, 9),
-#'   labels = c(Unknown = 9, Refused = 10)
+#'   labels = c(Unknown = 9, Refused = 10),
+#'   class = "labelled"
 #' ) |>
 #'   as_factor() |>
 #'   fct2num()
+#'
+#' # Outlier with labels, but no class of origin, handled like numeric vector
+#' # structure(c(1, 2, 3, 2, 10, 9),
+#' #   labels = c(Unknown = 9, Refused = 10)
+#' # ) |>
+#' #   as_factor() |>
+#' #   fct2num()
+#'
+#' v <- sample(6:19,20,TRUE) |> factor()
+#' dput(v)
+#' named_levels(v)
+#' fct2num(v)
 fct2num <- function(data) {
   stopifnot(is.factor(data))
-  as.numeric(named_levels(data))[match(data, names(named_levels(data)))]
+  if (is.character(named_levels(data))){
+    values <- as.numeric(named_levels(data))
+  } else {
+    values <- named_levels(data)
+  }
+
+  out <- values[match(data, names(named_levels(data)))]
+
+  ## If no NA on numeric coercion, of original names, then return
+  ## original numeric names, else values
+  if (possibly_numeric(out)) {
+    out <- as.numeric(names(out))
+  }
+  unname(out)
+}
+
+possibly_numeric <- function(data){
+  length(stats::na.omit(suppressWarnings(as.numeric(names(data))))) ==
+    length(data)
 }
 
 #' Extract attribute. Returns NA if none
@@ -171,11 +302,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,17 +327,27 @@ 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) {
+  # browser()
   if (is.null(attr)) {
-    ## Has to be list...
-    stopifnot(is.list(label))
-    ## ... with names
-    stopifnot(length(label)==length(names(label)))
-    attributes(data) <- c(attributes(data),label)
+    ## Has to be a named list
+    ## Will not fail, but just return original data
+    if (!is.list(label) | length(label) != length(names(label))) {
+      return(data)
+    }
+    ## Only include named labels
+    label <- label[!is.na(names(label))]
+
+    if (!overwrite) {
+      label <- label[!names(label) %in% names(attributes(data))]
+    }
+    attributes(data) <- c(attributes(data), label)
+
   } else {
     attr(data, attr) <- label
   }
@@ -238,12 +380,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))])
-# }
-

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",
@@ -195,6 +197,8 @@ 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")
   }
 
@@ -335,12 +339,15 @@ ds2dd_detailed <- function(data,
       )
     )
 
-  list(
+  out <- list(
     data = data |>
       hms2character() |>
       stats::setNames(dd$field_name),
     meta = dd
   )
+
+  class(out) <- c("REDCapCAST",class(out))
+  out
 }
 
 
@@ -416,9 +423,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 +443,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 +483,7 @@ parse_data <- function(data,
 #' @importFrom forcats as_factor
 #'
 #' @examples
+#' \dontrun{
 #' sample(seq_len(4), 20, TRUE) |>
 #'   var2fct(6) |>
 #'   summary()
@@ -481,9 +491,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 +516,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(

R/shiny_cast.R

@@ -78,3 +78,216 @@ read_input <- function(file, consider.na = c("NA", '""', "")) {
 
   df
 }
+
+#' Overview of REDCapCAST data for shiny
+#'
+#' @param data list with class 'REDCapCAST'
+#'
+#' @return gt object
+#' @export
+cast_data_overview <- function(data){
+  stopifnot("REDCapCAST" %in% class(data))
+  data |>
+    purrr::pluck("data") |>
+    utils::head(20) |>
+    # dplyr::tibble() |>
+    gt::gt() |>
+    gt::tab_style(
+      style = gt::cell_text(weight = "bold"),
+      locations = gt::cells_column_labels(dplyr::everything())
+    ) |>
+    gt::tab_header(
+      title = "Imported data preview",
+      subtitle = "The first 20 subjects of the supplied dataset for reference."
+    )
+}
+
+
+#' Overview of REDCapCAST meta data for shiny
+#'
+#' @param data list with class 'REDCapCAST'
+#'
+#' @return gt object
+#' @export
+cast_meta_overview <- function(data){
+  stopifnot("REDCapCAST" %in% class(data))
+  data |>
+    purrr::pluck("meta") |>
+    # dplyr::tibble() |>
+    dplyr::mutate(
+      dplyr::across(
+        dplyr::everything(),
+        \(.x) {
+          .x[is.na(.x)] <- ""
+          return(.x)
+        }
+      )
+    ) |>
+    dplyr::select(1:8) |>
+    gt::gt() |>
+    gt::tab_style(
+      style = gt::cell_text(weight = "bold"),
+      locations = gt::cells_column_labels(dplyr::everything())
+    ) |>
+    gt::tab_header(
+      title = "Generated metadata",
+      subtitle = "Only the first 8 columns are modified using REDCapCAST. Download the metadata to see everything."
+    ) |>
+    gt::tab_style(
+      style = gt::cell_borders(
+        sides = c("left", "right"),
+        color = "grey80",
+        weight = gt::px(1)
+      ),
+      locations = gt::cells_body(
+        columns = dplyr::everything()
+      )
+    )
+}
+
+
+#' Nav_bar defining function for shiny ui
+#'
+#' @return shiny object
+#' @export
+#'
+nav_bar_page <- function(){
+  bslib::page_navbar(
+    title = "Easy REDCap database creation",
+    sidebar = bslib::sidebar(
+      width = 300,
+      shiny::h5("Metadata casting"),
+      shiny::fileInput(
+        inputId = "ds",
+        label = "Upload spreadsheet",
+        multiple = FALSE,
+        accept = c(
+          ".csv",
+          ".xls",
+          ".xlsx",
+          ".dta",
+          ".rds",
+          ".ods"
+        )
+      ),
+      # shiny::actionButton(
+      #   inputId = "load_data",
+      #   label = "Load data",
+      #   icon = shiny::icon("circle-down")
+      # ),
+      shiny::helpText("Have a look at the preview panels to validate the data dictionary and imported data."),
+      # For some odd reason this only unfolds when the preview panel is shown..
+      # This has been solved by adding an arbitrary button to load data - which was abandoned again
+      shiny::conditionalPanel(
+        condition = "output.uploaded=='yes'",
+        shiny::radioButtons(
+          inputId = "add_id",
+          label = "Add ID, or use first column?",
+          selected = "no",
+          inline = TRUE,
+          choices = list(
+            "First column" = "no",
+            "Add ID" = "yes",
+            "No ID" = "none"
+          )
+        ),
+        shiny::radioButtons(
+          inputId = "specify_factors",
+          label = "Specify categorical variables?",
+          selected = "no",
+          inline = TRUE,
+          choices = list(
+            "No" = "no",
+            "Yes" = "yes"
+          )
+        ),
+        shiny::conditionalPanel(
+          condition = "input.specify_factors=='yes'",
+          shiny::uiOutput("factor_vars")
+        ),
+        # condition = "input.load_data",
+        #  shiny::helpText("Below you can download the dataset formatted for upload and the
+        # corresponding data dictionary for a new data base, if you want to upload manually."),
+        # Button
+        shiny::downloadButton(outputId = "downloadData", label = "Download renamed data"),
+
+        # Button
+        shiny::downloadButton(outputId = "downloadMeta", label = "Download data dictionary"),
+
+        # Button
+        shiny::downloadButton(outputId = "downloadInstrument", label = "Download as instrument"),
+
+        # Horizontal line ----
+        shiny::tags$hr(),
+        shiny::radioButtons(
+          inputId = "upload_redcap",
+          label = "Upload directly to REDCap server?",
+          selected = "no",
+          inline = TRUE,
+          choices = list(
+            "No" = "no",
+            "Yes" = "yes"
+          )
+        ),
+        shiny::conditionalPanel(
+          condition = "input.upload_redcap=='yes'",
+          shiny::h4("2) Data base upload"),
+          shiny::helpText("This tool is usable for now. Detailed instructions are coming."),
+          shiny::textInput(
+            inputId = "uri",
+            label = "URI",
+            value = "https://redcap.your.institution/api/"
+          ),
+          shiny::textInput(
+            inputId = "api",
+            label = "API key",
+            value = ""
+          ),
+          shiny::helpText("An API key is an access key to the REDCap database. Please", shiny::a("see here for directions", href = "https://www.iths.org/news/redcap-tip/redcap-api-101/"), " to obtain an API key for your project."),
+          shiny::actionButton(
+            inputId = "upload.meta",
+            label = "Upload datadictionary", icon = shiny::icon("book-bookmark")
+          ),
+          shiny::helpText("Please note, that before uploading any real data, put your project
+         into production mode."),
+          shiny::actionButton(
+            inputId = "upload.data",
+            label = "Upload data", icon = shiny::icon("upload")
+          )
+        )
+      ),
+      shiny::br(),
+      shiny::br(),
+      shiny::br(),
+      shiny::p(
+        "License: ", shiny::a("GPL-3+", href = "https://agdamsbo.github.io/REDCapCAST/LICENSE.html")
+      ),
+      shiny::p(
+        shiny::a("Package documentation", href = "https://agdamsbo.github.io/REDCapCAST")
+      )
+    ),
+    bslib::nav_panel(
+      title = "Intro",
+      shiny::markdown(readLines("www/SHINYCAST.md")),
+      shiny::br()
+    ),
+    # bslib::nav_spacer(),
+    bslib::nav_panel(
+      title = "Data preview",
+      gt::gt_output(outputId = "data.tbl")
+      # shiny::htmlOutput(outputId = "data.tbl", container = shiny::span)
+    ),
+    bslib::nav_panel(
+      title = "Dictionary overview",
+      gt::gt_output(outputId = "meta.tbl")
+      # shiny::htmlOutput(outputId = "meta.tbl", container = shiny::span)
+    ),
+    bslib::nav_panel(
+      title = "Upload",
+      shiny::h3("Meta upload overview"),
+      shiny::textOutput(outputId = "upload.meta.print"),
+      shiny::h3("Data upload overview"),
+      shiny::textOutput(outputId = "upload.data.print")
+    )
+  )
+}

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: 9392320
 url: https://agdamsbo.shinyapps.io/redcapcast/
 version: 1

inst/shiny-examples/casting/server.R

@@ -5,7 +5,6 @@ library(haven)
 library(readODS)
 library(readr)
 library(dplyr)
-library(here)
 library(devtools)
 if (!requireNamespace("REDCapCAST")) {
   devtools::install_github("agdamsbo/REDCapCAST", quiet = TRUE, upgrade = "never")
@@ -103,53 +102,12 @@ server <- function(input, output, session) {
 
   output$data.tbl <- gt::render_gt(
     dd() |>
-      purrr::pluck("data") |>
-      head(20) |>
-      # dplyr::tibble() |>
-      gt::gt() |>
-      gt::tab_style(
-        style = gt::cell_text(weight = "bold"),
-        locations = gt::cells_column_labels(dplyr::everything())
-      ) |>
-      gt::tab_header(
-        title = "Imported data preview",
-        subtitle = "The first 20 subjects of the supplied dataset for reference."
-      )
+      cast_data_overview()
   )
 
   output$meta.tbl <- gt::render_gt(
     dd() |>
-      purrr::pluck("meta") |>
-      # dplyr::tibble() |>
-      dplyr::mutate(
-        dplyr::across(
-          dplyr::everything(),
-          \(.x) {
-            .x[is.na(.x)] <- ""
-            return(.x)
-          }
-        )
-      ) |>
-      dplyr::select(1:8) |>
-      gt::gt() |>
-      gt::tab_style(
-        style = gt::cell_text(weight = "bold"),
-        locations = gt::cells_column_labels(dplyr::everything())
-      ) |>
-      gt::tab_header(
-        title = "Generated metadata",
-        subtitle = "Only the first 8 columns are modified using REDCapCAST. Download the metadata to see everything."
-      ) |>
-      gt::tab_style(
-        style = gt::cell_borders(
-          sides = c("left", "right"),
-          color = "grey80",
-          weight = gt::px(1)
-        ),
-        locations = gt::cells_body(
-          columns = dplyr::everything()
-        )
-      )
+      cast_meta_overview()
   )
 
   # Downloadable csv of dataset ----

inst/shiny-examples/casting/ui.R

@@ -2,143 +2,6 @@ ui <-
   bslib::page(
     theme = bslib::bs_theme(preset = "united"),
     title = "REDCap database creator",
-    bslib::page_navbar(
-      title = "Easy REDCap database creation",
-      sidebar = bslib::sidebar(
-        width = 300,
-        shiny::h5("Metadata casting"),
-        shiny::fileInput(
-          inputId = "ds",
-          label = "Upload spreadsheet",
-          multiple = FALSE,
-          accept = c(
-            ".csv",
-            ".xls",
-            ".xlsx",
-            ".dta",
-            ".rds",
-            ".ods"
-          )
-        ),
-        # shiny::actionButton(
-        #   inputId = "load_data",
-        #   label = "Load data",
-        #   icon = shiny::icon("circle-down")
-        # ),
-        shiny::helpText("Have a look at the preview panels to validate the data dictionary and imported data."),
-        # For some odd reason this only unfolds when the preview panel is shown..
-        # This has been solved by adding an arbitrary button to load data - which was abandoned again
-        shiny::conditionalPanel(
-          condition = "output.uploaded=='yes'",
-          shiny::radioButtons(
-            inputId = "add_id",
-            label = "Add ID, or use first column?",
-            selected = "no",
-            inline = TRUE,
-            choices = list(
-              "First column" = "no",
-              "Add ID" = "yes",
-              "No ID" = "none"
-            )
-          ),
-          shiny::radioButtons(
-            inputId = "specify_factors",
-            label = "Specify categorical variables?",
-            selected = "no",
-            inline = TRUE,
-            choices = list(
-              "No" = "no",
-              "Yes" = "yes"
-            )
-          ),
-          shiny::conditionalPanel(
-            condition = "input.specify_factors=='yes'",
-            uiOutput("factor_vars")
-          ),
-          # condition = "input.load_data",
-         #  shiny::helpText("Below you can download the dataset formatted for upload and the
-         # corresponding data dictionary for a new data base, if you want to upload manually."),
-          # Button
-          shiny::downloadButton(outputId = "downloadData", label = "Download renamed data"),
-
-          # Button
-          shiny::downloadButton(outputId = "downloadMeta", label = "Download data dictionary"),
-
-          # Button
-          shiny::downloadButton(outputId = "downloadInstrument", label = "Download as instrument"),
-
-          # Horizontal line ----
-          shiny::tags$hr(),
-          shiny::radioButtons(
-            inputId = "upload_redcap",
-            label = "Upload directly to REDCap server?",
-            selected = "no",
-            inline = TRUE,
-            choices = list(
-              "No" = "no",
-              "Yes" = "yes"
-            )
-          ),
-          shiny::conditionalPanel(
-            condition = "input.upload_redcap=='yes'",
-            shiny::h4("2) Data base upload"),
-            shiny::helpText("This tool is usable for now. Detailed instructions are coming."),
-            shiny::textInput(
-              inputId = "uri",
-              label = "URI",
-              value = "https://redcap.your.institution/api/"
-            ),
-            shiny::textInput(
-              inputId = "api",
-              label = "API key",
-              value = ""
-            ),
-            shiny::helpText("An API key is an access key to the REDCap database. Please", shiny::a("see here for directions", href = "https://www.iths.org/news/redcap-tip/redcap-api-101/"), " to obtain an API key for your project."),
-            shiny::actionButton(
-              inputId = "upload.meta",
-              label = "Upload datadictionary", icon = shiny::icon("book-bookmark")
-            ),
-            shiny::helpText("Please note, that before uploading any real data, put your project
-         into production mode."),
-            shiny::actionButton(
-              inputId = "upload.data",
-              label = "Upload data", icon = shiny::icon("upload")
-            )
-          )
-        ),
-        shiny::br(),
-        shiny::br(),
-        shiny::br(),
-        shiny::p(
-          "License: ", shiny::a("GPL-3+", href = "https://agdamsbo.github.io/REDCapCAST/LICENSE.html")
-        ),
-        shiny::p(
-          shiny::a("Package documentation", href = "https://agdamsbo.github.io/REDCapCAST")
-        )
-      ),
-      bslib::nav_panel(
-        title = "Intro",
-        shiny::markdown(readLines("www/SHINYCAST.md")),
-        shiny::br()
-      ),
-      # bslib::nav_spacer(),
-      bslib::nav_panel(
-        title = "Data preview",
-        gt::gt_output(outputId = "data.tbl")
-        # shiny::htmlOutput(outputId = "data.tbl", container = shiny::span)
-      ),
-      bslib::nav_panel(
-        title = "Dictionary overview",
-        gt::gt_output(outputId = "meta.tbl")
-        # shiny::htmlOutput(outputId = "meta.tbl", container = shiny::span)
-      ),
-      bslib::nav_panel(
-        title = "Upload",
-        shiny::h3("Meta upload overview"),
-        shiny::textOutput(outputId = "upload.meta.print"),
-        shiny::h3("Data upload overview"),
-        shiny::textOutput(outputId = "upload.data.print")
-      )
-    )
+nav_bar_page()
   )
 

man/as_factor.Rd

@@ -2,6 +2,7 @@
 % Please edit documentation in R/as_factor.R
 \name{as_factor}
 \alias{as_factor}
+\alias{as_factor.factor}
 \alias{as_factor.logical}
 \alias{as_factor.numeric}
 \alias{as_factor.character}
@@ -11,20 +12,43 @@
 \usage{
 as_factor(x, ...)
 
+\method{as_factor}{factor}(x, ...)
+
 \method{as_factor}{logical}(x, ...)
 
 \method{as_factor}{numeric}(x, ...)
 
 \method{as_factor}{character}(x, ...)
 
-\method{as_factor}{haven_labelled}(x, ...)
+\method{as_factor}{haven_labelled}(
+  x,
+  levels = c("default", "labels", "values", "both"),
+  ordered = FALSE,
+  ...
+)
 
-\method{as_factor}{labelled}(x, ...)
+\method{as_factor}{labelled}(
+  x,
+  levels = c("default", "labels", "values", "both"),
+  ordered = FALSE,
+  ...
+)
 }
 \arguments{
 \item{x}{Object to coerce to a factor.}
 
 \item{...}{Other arguments passed down to method.}
+
+\item{levels}{How to create the levels of the generated factor:
+
+  * "default": uses labels where available, otherwise the values.
+    Labels are sorted by value.
+  * "both": like "default", but pastes together the level and value
+  * "label": use only the labels; unlabelled values become `NA`
+  * "values": use only the values}
+
+\item{ordered}{If `TRUE` create an ordered (ordinal) factor, if
+`FALSE` (the default) create a regular (nominal) factor.}
 }
 \description{
 This extends [forcats::as_factor()] as well as [haven::as_factor()], by appending
@@ -33,19 +57,19 @@ ta loss in case of rich formatted and labelled data.
 }
 \details{
 Please refer to parent functions for extended documentation.
+To avoid redundancy calls and errors, functions are copy-pasted here
 }
 \examples{
-# will preserve all attributes but class
+# will preserve all attributes
 c(1, 4, 3, "A", 7, 8, 1) |> as_factor()
 structure(c(1, 2, 3, 2, 10, 9),
   labels = c(Unknown = 9, Refused = 10)
 ) |>
-  as_factor()
+  as_factor() |> dput()
 
 structure(c(1, 2, 3, 2, 10, 9),
   labels = c(Unknown = 9, Refused = 10),
   class = "haven_labelled"
 ) |>
   as_factor()
-
 }

man/cast_data_overview.Rd

@@ -0,0 +1,17 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/shiny_cast.R
+\name{cast_data_overview}
+\alias{cast_data_overview}
+\title{Overview of REDCapCAST data for shiny}
+\usage{
+cast_data_overview(data)
+}
+\arguments{
+\item{data}{list with class 'REDCapCAST'}
+}
+\value{
+gt object
+}
+\description{
+Overview of REDCapCAST data for shiny
+}

man/cast_meta_overview.Rd

@@ -0,0 +1,17 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/shiny_cast.R
+\name{cast_meta_overview}
+\alias{cast_meta_overview}
+\title{Overview of REDCapCAST meta data for shiny}
+\usage{
+cast_meta_overview(data)
+}
+\arguments{
+\item{data}{list with class 'REDCapCAST'}
+}
+\value{
+gt object
+}
+\description{
+Overview of REDCapCAST meta data for shiny
+}

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 = "__")
 }
+}

man/fct2num.Rd

@@ -17,7 +17,8 @@ Allows conversion of factor to numeric values preserving original levels
 }
 \examples{
 c(1, 4, 3, "A", 7, 8, 1) |>
-as_factor() |> fct2num()
+  as_factor() |>
+  fct2num()
 
 structure(c(1, 2, 3, 2, 10, 9),
   labels = c(Unknown = 9, Refused = 10),
@@ -27,8 +28,21 @@ structure(c(1, 2, 3, 2, 10, 9),
   fct2num()
 
 structure(c(1, 2, 3, 2, 10, 9),
-  labels = c(Unknown = 9, Refused = 10)
+  labels = c(Unknown = 9, Refused = 10),
+  class = "labelled"
 ) |>
   as_factor() |>
   fct2num()
+
+# Outlier with labels, but no class of origin, handled like numeric vector
+# structure(c(1, 2, 3, 2, 10, 9),
+#   labels = c(Unknown = 9, Refused = 10)
+# ) |>
+#   as_factor() |>
+#   fct2num()
+
+v <- sample(6:19,20,TRUE) |> factor()
+dput(v)
+named_levels(v)
+fct2num(v)
 }

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

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,12 @@ 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()
+) |>
+  as_factor() |>
+  named_levels()
+}
 }

man/nav_bar_page.Rd

@@ -0,0 +1,14 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/shiny_cast.R
+\name{nav_bar_page}
+\alias{nav_bar_page}
+\title{Nav_bar defining function for shiny ui}
+\usage{
+nav_bar_page()
+}
+\value{
+shiny object
+}
+\description{
+Nav_bar defining function for shiny ui
+}

man/numchar2fct.Rd

@@ -23,7 +23,9 @@ Individual thresholds for character and numeric columns
 }
 \examples{
 mtcars |> str()
+\dontrun{
 mtcars |>
   numchar2fct(numeric.threshold = 6) |>
   str()
 }
+}

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

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

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

vignettes/Shiny-app.Rmd

@@ -69,11 +69,6 @@ redcapcast_data |>
 ```
 
 
-```{r}
-
-```
-
-
 Column classes can be passed to `parse_data()`.
 
 Making a few crude assumption for factorising data, `numchar2fct()` factorises numerical and character vectors based on a set threshold for unique values: