DESCRIPTION

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

NAMESPACE

@@ -1,7 +1,6 @@
 # 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)
@@ -13,8 +12,6 @@ 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)
@@ -39,7 +36,6 @@ 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)
@@ -63,5 +59,6 @@ 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,170 +5,84 @@
 #' 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
+#' # will preserve all attributes but class
 #' 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() |> dput()
+#'   as_factor()
 #'
 #' 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 <- factor(x, levels = c("FALSE", "TRUE"))
+  x <- forcats::as_factor(x, ...)
-  set_attr(x, labels, overwrite = FALSE)
+  set_attr(x, labels[-match("class", names(labels))])
 }
 
 #' @rdname as_factor
 #' @export
 as_factor.numeric <- function(x, ...) {
   labels <- get_attr(x)
-  x <- factor(x)
+  x <- forcats::as_factor(x, ...)
-  set_attr(x, labels, overwrite = FALSE)
+  set_attr(x, labels[-match("class", names(labels))])
 }
 
 #' @rdname as_factor
 #' @export
 as_factor.character <- function(x, ...) {
   labels <- get_attr(x)
-  if (is.roman(x)){
+  x <- forcats::as_factor(x, ...)
-    x <- factor(x)
+  set_attr(x, labels[-match("class", names(labels))])
-  } 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, levels = c("default", "labels", "values", "both"),
+as_factor.haven_labelled <- function(x, ...) {
-                                     ordered = FALSE, ...) {
+  labels <- get_attr(x)
-  labels_all <- get_attr(x)
+  x <- haven::as_factor(x, ...)
-
+  set_attr(x, labels[-match("class", names(labels))])
-  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()
-#'   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)){
@@ -181,24 +95,17 @@ 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(
+    data <- do.call(structure,
-      structure,
+            c(list(.Data=match(vals,lbls)),
-      c(
-        list(.Data = match(vals, lbls)),
               attrs[-match("levels", names(attrs))],
-        list(
+              list(levels=names(lbls),
-          levels = names(lbls),
+                   labels=lbls)))
-          labels = lbls
-        )
-      )
-    )
   }
 
   d <- data.frame(
@@ -210,27 +117,21 @@ 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 (possibly_numeric(levels(data))) {
+  if (identical(
+    levels(data),
+    suppressWarnings(as.character(as.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
 #'
@@ -241,8 +142,7 @@ is.roman <- function(data){
 #'
 #' @examples
 #' c(1, 4, 3, "A", 7, 8, 1) |>
-#'   as_factor() |>
+#' as_factor() |> fct2num()
-#'   fct2num()
 #'
 #' structure(c(1, 2, 3, 2, 10, 9),
 #'   labels = c(Unknown = 9, Refused = 10),
@@ -252,44 +152,13 @@ is.roman <- function(data){
 #'   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))
-  if (is.character(named_levels(data))){
+  as.numeric(named_levels(data))[match(data, names(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
@@ -302,12 +171,11 @@ possibly_numeric <- function(data){
 #'
 #' @examples
 #' attr(mtcars$mpg, "label") <- "testing"
-#' do.call(c, sapply(mtcars, get_attr))
+#' sapply(mtcars, get_attr)
-#' \dontrun{
+#' lapply(mtcars, \(.x)get_attr(.x, NULL))
 #' mtcars |>
 #'   numchar2fct(numeric.threshold = 6) |>
 #'   ds2dd_detailed()
-#' }
 get_attr <- function(data, attr = NULL) {
   if (is.null(attr)) {
     attributes(data)
@@ -327,27 +195,17 @@ 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, overwrite = FALSE) {
+set_attr <- function(data, label, attr = NULL) {
-  # browser()
   if (is.null(attr)) {
-    ## Has to be a named list
+    ## Has to be list...
-    ## Will not fail, but just return original data
+    stopifnot(is.list(label))
-    if (!is.list(label) | length(label) != length(names(label))) {
+    ## ... with names
-      return(data)
+    stopifnot(length(label)==length(names(label)))
-    }
-    ## 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
   }
@@ -380,3 +238,12 @@ 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,7 +141,6 @@ hms2character <- function(data) {
 #' @export
 #'
 #' @examples
-#' \dontrun{
 #' data <- REDCapCAST::redcapcast_data
 #' data |> ds2dd_detailed()
 #' iris |> ds2dd_detailed(add.auto.id = TRUE)
@@ -158,7 +157,6 @@ 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",
@@ -197,8 +195,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")
   }
 
@@ -339,15 +335,12 @@ ds2dd_detailed <- function(data,
       )
     )
 
-  out <- list(
+  list(
     data = data |>
       hms2character() |>
       stats::setNames(dd$field_name),
     meta = dd
   )
-
-  class(out) <- c("REDCapCAST",class(out))
-  out
 }
 
 
@@ -423,11 +416,9 @@ mark_complete <- function(upload, ls) {
 #' @export
 #'
 #' @examples
-#' \dontrun{
 #' mtcars |>
 #'   parse_data() |>
 #'   str()
-#' }
 parse_data <- function(data,
                        guess_type = TRUE,
                        col_types = NULL,
@@ -443,7 +434,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 |>
-      as_factor()
+      haven::as_factor()
   }
 
   ## Applying readr cols
@@ -483,7 +474,6 @@ parse_data <- function(data,
 #' @importFrom forcats as_factor
 #'
 #' @examples
-#' \dontrun{
 #' sample(seq_len(4), 20, TRUE) |>
 #'   var2fct(6) |>
 #'   summary()
@@ -491,10 +481,9 @@ 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)
+    forcats::as_factor(data)
   } else {
     data
   }
@@ -516,11 +505,9 @@ 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,216 +78,3 @@ 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: 9392320
+bundleId:
 url: https://agdamsbo.shinyapps.io/redcapcast/
 version: 1

inst/shiny-examples/casting/server.R

@@ -5,6 +5,7 @@ library(haven)
 library(readODS)
 library(readr)
 library(dplyr)
+library(here)
 library(devtools)
 if (!requireNamespace("REDCapCAST")) {
   devtools::install_github("agdamsbo/REDCapCAST", quiet = TRUE, upgrade = "never")
@@ -102,12 +103,53 @@ server <- function(input, output, session) {
 
   output$data.tbl <- gt::render_gt(
     dd() |>
-      cast_data_overview()
+      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."
+      )
   )
 
   output$meta.tbl <- gt::render_gt(
     dd() |>
-      cast_meta_overview()
+      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()
+        )
+      )
   )
 
   # Downloadable csv of dataset ----

inst/shiny-examples/casting/ui.R

@@ -2,6 +2,143 @@ ui <-
   bslib::page(
     theme = bslib::bs_theme(preset = "united"),
     title = "REDCap database creator",
-nav_bar_page()
+    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")
+      )
+    )
   )
 

man/as_factor.Rd

@@ -2,7 +2,6 @@
 % 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}
@@ -12,43 +11,20 @@
 \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}(
+\method{as_factor}{haven_labelled}(x, ...)
-  x,
-  levels = c("default", "labels", "values", "both"),
-  ordered = FALSE,
-  ...
-)
 
-\method{as_factor}{labelled}(
+\method{as_factor}{labelled}(x, ...)
-  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
@@ -57,19 +33,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
+# will preserve all attributes but class
 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() |> dput()
+  as_factor()
 
 structure(c(1, 2, 3, 2, 10, 9),
   labels = c(Unknown = 9, Refused = 10),
   class = "haven_labelled"
 ) |>
   as_factor()
+
 }

man/cast_data_overview.Rd

@@ -1,17 +0,0 @@
-% 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

@@ -1,17 +0,0 @@
-% 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,7 +75,6 @@ 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)
@@ -93,4 +92,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 = "__")
 }
-}

man/fct2num.Rd

@@ -17,8 +17,7 @@ Allows conversion of factor to numeric values preserving original levels
 }
 \examples{
 c(1, 4, 3, "A", 7, 8, 1) |>
-  as_factor() |>
+as_factor() |> fct2num()
-  fct2num()
 
 structure(c(1, 2, 3, 2, 10, 9),
   labels = c(Unknown = 9, Refused = 10),
@@ -28,21 +27,8 @@ 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,10 +19,9 @@ Extract attribute. Returns NA if none
 }
 \examples{
 attr(mtcars$mpg, "label") <- "testing"
-do.call(c, sapply(mtcars, get_attr))
+sapply(mtcars, get_attr)
-\dontrun{
+lapply(mtcars, \(.x)get_attr(.x, NULL))
 mtcars |>
   numchar2fct(numeric.threshold = 6) |>
   ds2dd_detailed()
 }
-}

man/named_levels.Rd

@@ -10,11 +10,6 @@ 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
@@ -23,12 +18,8 @@ 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

@@ -1,14 +0,0 @@
-% 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,9 +23,7 @@ Individual thresholds for character and numeric columns
 }
 \examples{
 mtcars |> str()
-\dontrun{
 mtcars |>
   numchar2fct(numeric.threshold = 6) |>
   str()
 }
-}

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

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, overwrite = FALSE)
+set_attr(data, label, attr = NULL)
 }
 \arguments{
 \item{data}{vector}
@@ -12,8 +12,6 @@ set_attr(data, label, attr = NULL, overwrite = FALSE)
 \item{label}{label}
 
 \item{attr}{attribute name}
-
-\item{overwrite}{overwrite existing attributes. Default is FALSE.}
 }
 \value{
 vector with attribute

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

vignettes/Shiny-app.Rmd

@@ -69,6 +69,11 @@ 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: