restructuring

NEWS.md

@@ -1,3 +1,9 @@
+# REDCapCAST 24.11.4
+
+The hosting on shinyapps.io has given a lot of trouble recently. Modyfied package structure a little around the `shiny_cast()`, to accommodate an alternative hosting approach with all package functions included in a script instead of requiring the package.
+
+* read_readcap_labelled(): 
+
 # REDCapCAST 24.11.3
 
 * BUG: shiny_cast() fails to load as I missed loading REDCapCAST library in ui.r. Fixed. Tests would be great.

R/as_factor.R

@@ -16,7 +16,8 @@
 #' structure(c(1, 2, 3, 2, 10, 9),
 #'   labels = c(Unknown = 9, Refused = 10)
 #' ) |>
-#'   as_factor() |> dput()
+#'   as_factor() |>
+#'   dput()
 #'
 #' structure(c(1, 2, 3, 2, 10, 9),
 #'   labels = c(Unknown = 9, Refused = 10),
@@ -202,6 +203,7 @@ named_levels <- function(data, label = "labels", na.label = NULL, na.value = 99)
     )
   }
 
+
   # Handle empty factors
   if (all_na(data)) {
     d <- data.frame(
@@ -213,7 +215,8 @@ named_levels <- function(data, label = "labels", na.label = NULL, na.value = 99)
       name = levels(data)[data],
       value = as.numeric(data)
     ) |>
-      unique()
+      unique() |>
+      stats::na.omit()
   }
 
   ## Applying labels
@@ -221,6 +224,9 @@ named_levels <- function(data, label = "labels", na.label = NULL, na.value = 99)
   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 if (all(d$name %in% names(attr_l)) && nrow(d) < length(attr_l)){
+      d <- data.frame(name = names(attr_l),
+                      value=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)
@@ -244,12 +250,16 @@ named_levels <- function(data, label = "labels", na.label = NULL, na.value = 99)
 #' @export
 #'
 #' @examples
-#' sample(1:100,10) |> as.roman() |> possibly_roman()
+#' sample(1:100, 10) |>
+#'   as.roman() |>
+#'   possibly_roman()
 #' sample(c(TRUE, FALSE), 10, TRUE) |> possibly_roman()
 #' rep(NA, 10) |> possibly_roman()
 possibly_roman <- function(data) {
   # browser()
-  if (all(is.na(data))) return(FALSE)
+  if (all(is.na(data))) {
+    return(FALSE)
+  }
   identical(as.character(data), as.character(utils::as.roman(data)))
 }
 
@@ -369,7 +379,6 @@ set_attr <- function(data, label, attr = NULL, overwrite = FALSE) {
       label <- label[!names(label) %in% names(attributes(data))]
     }
     attributes(data) <- c(attributes(data), label)
-
   } else {
     attr(data, attr) <- label
   }

R/ds2dd_detailed.R

@@ -98,6 +98,116 @@ hms2character <- function(data) {
     dplyr::bind_cols()
 }
 
+
+#' Default column names of a REDCap data dictionary
+#'
+#' @param ... ignored for now
+#'
+#' @return character vector
+#' @export
+#'
+#' @examples
+#' dput(redcap_meta_default())
+redcap_meta_default <- function(...) {
+  c(
+    "field_name", "form_name", "section_header", "field_type",
+    "field_label", "select_choices_or_calculations", "field_note",
+    "text_validation_type_or_show_slider_number", "text_validation_min",
+    "text_validation_max", "identifier", "branching_logic", "required_field",
+    "custom_alignment", "question_number", "matrix_group_name", "matrix_ranking",
+    "field_annotation"
+  )
+}
+
+#' (DEPRECATED) Data set to data dictionary function
+#'
+#' @description
+#' Creates a very basic data dictionary skeleton. Please see `ds2dd_detailed()`
+#' for a more advanced function.
+#'
+#' @details
+#' Migrated from stRoke ds2dd(). Fits better with the functionality of
+#' 'REDCapCAST'.
+#' @param ds data set
+#' @param record.id name or column number of id variable, moved to first row of
+#' data dictionary, character of integer. Default is "record_id".
+#' @param form.name vector of form names, character string, length 1 or length
+#' equal to number of variables. Default is "basis".
+#' @param field.type vector of field types, character string, length 1 or length
+#' equal to number of variables. Default is "text.
+#' @param field.label vector of form names, character string, length 1 or length
+#' equal to number of variables. Default is NULL and is then identical to field
+#' names.
+#' @param include.column.names Flag to give detailed output including new
+#' column names for original data set for upload.
+#' @param metadata Metadata column names. Default is the included
+#' REDCapCAST::redcap_meta_default.
+#'
+#' @return data.frame or list of data.frame and vector
+#' @export
+#'
+#' @examples
+#' redcapcast_data$record_id <- seq_len(nrow(redcapcast_data))
+#' ds2dd(redcapcast_data, include.column.names=TRUE)
+
+ds2dd <-
+  function(ds,
+           record.id = "record_id",
+           form.name = "basis",
+           field.type = "text",
+           field.label = NULL,
+           include.column.names = FALSE,
+           metadata = REDCapCAST::redcap_meta_default()
+           ) {
+    dd <- data.frame(matrix(ncol = length(metadata), nrow = ncol(ds)))
+    colnames(dd) <- metadata
+
+    if (is.character(record.id) && !record.id %in% colnames(ds)) {
+      stop("Provided record.id is not a variable name in provided data set.")
+    }
+
+    # renaming to lower case and substitute spaces with underscore
+    field.name <- gsub(" ", "_", tolower(colnames(ds)))
+
+    # handles both character and integer
+    colsel <-
+      colnames(ds) == colnames(ds[record.id])
+
+    if (summary(colsel)[3] != 1) {
+      stop("Provided record.id has to be or refer to a uniquely named column.")
+    }
+
+    dd[, "field_name"] <-
+      c(field.name[colsel], field.name[!colsel])
+
+    if (length(form.name) > 1 && length(form.name) != ncol(ds)) {
+      stop(
+        "Provided form.name should be of length 1 (value is reused) or equal
+        length as number of variables in data set."
+      )
+    }
+    dd[, "form_name"] <- form.name
+
+    if (length(field.type) > 1 && length(field.type) != ncol(ds)) {
+      stop(
+        "Provided field.type should be of length 1 (value is reused) or equal
+        length as number of variables in data set."
+      )
+    }
+
+    dd[, "field_type"] <- field.type
+
+    if (is.null(field.label)) {
+      dd[, "field_label"] <- dd[, "field_name"]
+    } else
+      dd[, "field_label"] <- field.label
+
+    if (include.column.names){
+      list("DataDictionary"=dd,"Column names"=field.name)
+    } else dd
+  }
+
+
 #' Extract data from stata file for data dictionary
 #'
 #' @details
@@ -134,7 +244,7 @@ hms2character <- function(data) {
 #' or attribute `factor.labels.attr` for haven_labelled data set (imported .dta
 #' file with `haven::read_dta()`).
 #' @param metadata redcap metadata headings. Default is
-#' REDCapCAST:::metadata_names.
+#' REDCapCAST::redcap_meta_default().
 #' @param convert.logicals convert logicals to factor. Default is TRUE.
 #'
 #' @return list of length 2
@@ -142,7 +252,8 @@ hms2character <- function(data) {
 #'
 #' @examples
 #' ## Basic parsing with default options
-#' REDCapCAST::redcapcast_data |>
+#' requireNamespace("REDCapCAST")
+#' redcapcast_data |>
 #'   dplyr::select(-dplyr::starts_with("redcap_")) |>
 #'   ds2dd_detailed()
 #'
@@ -175,15 +286,8 @@ ds2dd_detailed <- function(data,
                            field.label = NULL,
                            field.label.attr = "label",
                            field.validation = NULL,
-                           metadata = names(REDCapCAST::redcapcast_meta),
+                           metadata = REDCapCAST::redcap_meta_default(),
                            convert.logicals = TRUE) {
-  # Repair empty columns
-  # These where sometimes classed as factors or
-  # if (any(sapply(data,all_na))){
-  #   data <- data |>
-  #     ## Converts logical to factor, which overwrites attributes
-  #     dplyr::mutate(dplyr::across(dplyr::where(all_na), as.character))
-  # }
 
   if (convert.logicals) {
     data <- data |>

R/export_redcap_instrument.R

@@ -82,6 +82,7 @@ export_redcap_instrument <- function(data,
 #' @export
 #'
 #' @examples
+#' \dontrun{
 #' data <- iris |>
 #'   ds2dd_detailed(
 #'     add.auto.id = TRUE,
@@ -100,9 +101,10 @@ export_redcap_instrument <- function(data,
 #'   setNames(glue::glue("{sample(x = c('a','b'),size = length(ncol(iris)),
 #' replace=TRUE,prob = rep(x=.5,2))}__{names(iris)}")) |>
 #'   ds2dd_detailed(form.sep = "__")
-#' # data |>
+#' data |>
-#' #   purrr::pluck("meta") |>
+#'   purrr::pluck("meta") |>
-#' #   create_instrument_meta(record.id = FALSE)
+#'   create_instrument_meta(record.id = FALSE)
+#' }
 create_instrument_meta <- function(data,
                                    dir = here::here(""),
                                    record.id = TRUE) {

R/redcapcast_meta.R

@@ -1,6 +1,6 @@
 #' REDCap metadata from data base
 #'
-#' This metadata dataset from a REDCap database is for demonstrational purposes.
+#' This metadata dataset from a REDCap database is for demonstration purposes.
 #'
 #' @format A data frame with 22 variables:
 #' \describe{

data-raw/metadata_names.R

@@ -7,9 +7,9 @@
 #   "matrix_ranking", "field_annotation"
 # )
 
-metadata_names <- REDCapR::redcap_metadata_read(
+# metadata_names <- REDCapR::redcap_metadata_read(
-  redcap_uri = keyring::key_get("DB_URI"),
+#   redcap_uri = keyring::key_get("DB_URI"),
-  token = keyring::key_get("cast_api")
+#   token = keyring::key_get("cast_api")
-)$data |> names()
+# )$data |> names()
-
+#
-usethis::use_data(metadata_names, overwrite = TRUE, internal = TRUE)
+# usethis::use_data(metadata_names, overwrite = TRUE, internal = TRUE)

data-raw/redcapcast_data.R

@@ -12,4 +12,4 @@ redcapcast_data <- REDCapR::redcap_read(
 
 usethis::use_data(redcapcast_data, overwrite = TRUE)
 
-write.csv(redcapcast_data,here::here("data/redcapcast_data.csv"),row.names = FALSE)
+# write.csv(redcapcast_data,here::here("data/redcapcast_data.csv"),row.names = FALSE)

inst/shiny-examples/casting/app.R

@@ -0,0 +1,195 @@
+library(bslib)
+library(shiny)
+library(openxlsx2)
+library(haven)
+library(readODS)
+library(readr)
+library(dplyr)
+library(gt)
+library(devtools)
+
+if (!requireNamespace("REDCapCAST")) {
+  install.packages("REDCapCAST")
+}
+library(REDCapCAST)
+
+## Load merged files for shinyapps.io hosting
+if (file.exists(here::here("functions.R"))) {
+  source(here::here("functions.R"))
+}
+
+ui <-
+  bslib::page(
+    theme = bslib::bs_theme(preset = "united"),
+    title = "REDCap database creator",
+    nav_bar_page()
+  )
+
+server <- function(input, output, session) {
+  v <- shiny::reactiveValues(
+    file = NULL
+  )
+
+  ds <- shiny::reactive({
+    shiny::req(input$ds)
+
+    out <- read_input(input$ds$datapath)
+
+    out <- out |>
+      ## Parses data with readr functions
+      parse_data() |>
+      ## Converts logical to factor, preserving attributes with own function
+      dplyr::mutate(dplyr::across(dplyr::where(is.logical), as_factor))
+
+    out
+  })
+
+  dat <- shiny::reactive({
+    out <- ds()
+
+    if (!is.null(input$factor_vars)) {
+      out <- out |>
+        dplyr::mutate(
+          dplyr::across(
+            dplyr::all_of(input$factor_vars),
+            as_factor
+          )
+        )
+    }
+
+    out
+  })
+
+  # getData <- reactive({
+  #   if(is.null(input$ds$datapath)) return(NULL)
+  # })
+  # output$uploaded <- reactive({
+  #   return(!is.null(getData()))
+  # })
+
+  dd <- shiny::reactive({
+    shiny::req(input$ds)
+    v$file <- "loaded"
+    ds2dd_detailed(
+      data = dat(),
+      add.auto.id = input$add_id == "yes"
+    )
+  })
+
+  output$uploaded <- shiny::reactive({
+    if (is.null(v$file)) {
+      "no"
+    } else {
+      "yes"
+    }
+  })
+
+  shiny::outputOptions(output, "uploaded", suspendWhenHidden = FALSE)
+
+  output$factor_vars <- shiny::renderUI({
+    shiny::req(input$ds)
+    selectizeInput(
+      inputId = "factor_vars",
+      selected = colnames(dat())[sapply(dat(), is.factor)],
+      label = "Covariables to format as categorical",
+      choices = colnames(dat()),
+      multiple = TRUE
+    )
+  })
+
+  ## Specify ID if necessary
+  # output$id_var <- shiny::renderUI({
+  #   shiny::req(input$ds)
+  #   selectizeInput(
+  #     inputId = "id_var",
+  #     selected = colnames(dat())[1],
+  #     label = "ID variable",
+  #     choices = colnames(dat())[-match(colnames(dat()),input$factor_vars)],
+  #     multiple = FALSE
+  #   )
+  # })
+
+  output$data.tbl <- gt::render_gt(
+    dd() |>
+      cast_data_overview()
+  )
+
+  output$meta.tbl <- gt::render_gt(
+    dd() |>
+      cast_meta_overview()
+  )
+
+  # Downloadable csv of dataset ----
+  output$downloadData <- shiny::downloadHandler(
+    filename = "data_ready.csv",
+    content = function(file) {
+      write.csv(purrr::pluck(dd(), "data"), file, row.names = FALSE, na = "")
+    }
+  )
+
+  # Downloadable csv of data dictionary ----
+  output$downloadMeta <- shiny::downloadHandler(
+    filename = paste0("REDCapCAST_DataDictionary_", Sys.Date(), ".csv"),
+    content = function(file) {
+      write.csv(purrr::pluck(dd(), "meta"), file, row.names = FALSE, na = "")
+    }
+  )
+
+  # Downloadable .zip of instrument ----
+  output$downloadInstrument <- shiny::downloadHandler(
+    filename = paste0("REDCapCAST_instrument", Sys.Date(), ".zip"),
+    content = function(file) {
+      export_redcap_instrument(purrr::pluck(dd(), "meta"),
+        file = file,
+        record.id = ifelse(input$add_id == "none", NA, names(dat())[1])
+      )
+    }
+  )
+
+  output_staging <- shiny::reactiveValues()
+
+  output_staging$meta <- output_staging$data <- NA
+
+  shiny::observeEvent(input$upload.meta, {
+    upload_meta()
+  })
+
+  shiny::observeEvent(input$upload.data, {
+    upload_data()
+  })
+
+  upload_meta <- function() {
+    shiny::req(input$uri)
+
+    shiny::req(input$api)
+
+    output_staging$meta <- REDCapR::redcap_metadata_write(
+      ds = purrr::pluck(dd(), "meta"),
+      redcap_uri = input$uri,
+      token = input$api
+    ) |> purrr::pluck("success")
+  }
+
+  upload_data <- function() {
+    shiny::req(input$uri)
+
+    shiny::req(input$api)
+
+    output_staging$data <- REDCapR::redcap_write(
+      ds = purrr::pluck(dd(), "data"),
+      redcap_uri = input$uri,
+      token = input$api
+    ) |> purrr::pluck("success")
+  }
+
+  output$upload.meta.print <- renderText(output_staging$meta)
+
+  output$upload.data.print <- renderText(output_staging$data)
+
+  # session$onSessionEnded(function() {
+  #   # cat("Session Ended\n")
+  #   unlink("www",recursive = TRUE)
+  # })
+}
+
+shiny::shinyApp(ui = ui, server = server)

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: 9412329
+bundleId: 9418747
 url: https://agdamsbo.shinyapps.io/redcapcast/
 version: 1

man/create_instrument_meta.Rd

@@ -26,6 +26,7 @@ function can be used to create (an) instrument(s) to add to a project in
 production.
 }
 \examples{
+\dontrun{
 data <- iris |>
   ds2dd_detailed(
     add.auto.id = TRUE,
@@ -44,7 +45,8 @@ iris |>
   setNames(glue::glue("{sample(x = c('a','b'),size = length(ncol(iris)),
 replace=TRUE,prob = rep(x=.5,2))}__{names(iris)}")) |>
   ds2dd_detailed(form.sep = "__")
-# data |>
+data |>
-#   purrr::pluck("meta") |>
+  purrr::pluck("meta") |>
-#   create_instrument_meta(record.id = FALSE)
+  create_instrument_meta(record.id = FALSE)
+}
 }

man/ds2dd.Rd

@@ -1,5 +1,5 @@
 % Generated by roxygen2: do not edit by hand
-% Please edit documentation in R/ds2dd.R
+% Please edit documentation in R/ds2dd_detailed.R
 \name{ds2dd}
 \alias{ds2dd}
 \title{(DEPRECATED) Data set to data dictionary function}
@@ -11,7 +11,7 @@ ds2dd(
   field.type = "text",
   field.label = NULL,
   include.column.names = FALSE,
-  metadata = metadata_names
+  metadata = REDCapCAST::redcap_meta_default()
 )
 }
 \arguments{
@@ -34,7 +34,7 @@ names.}
 column names for original data set for upload.}
 
 \item{metadata}{Metadata column names. Default is the included
-REDCapCAST::metadata_names.}
+REDCapCAST::redcap_meta_default.}
 }
 \value{
 data.frame or list of data.frame and vector

man/ds2dd_detailed.Rd

@@ -15,7 +15,7 @@ ds2dd_detailed(
   field.label = NULL,
   field.label.attr = "label",
   field.validation = NULL,
-  metadata = names(REDCapCAST::redcapcast_meta),
+  metadata = REDCapCAST::redcap_meta_default(),
   convert.logicals = TRUE
 )
 }
@@ -55,7 +55,7 @@ or attribute `factor.labels.attr` for haven_labelled data set (imported .dta
 file with `haven::read_dta()`).}
 
 \item{metadata}{redcap metadata headings. Default is
-REDCapCAST:::metadata_names.}
+REDCapCAST::redcap_meta_default().}
 
 \item{convert.logicals}{convert logicals to factor. Default is TRUE.}
 }
@@ -76,7 +76,8 @@ Ensure, that the data set is formatted with as much information as possible.
 }
 \examples{
 ## Basic parsing with default options
-REDCapCAST::redcapcast_data |>
+requireNamespace("REDCapCAST")
+redcapcast_data |>
   dplyr::select(-dplyr::starts_with("redcap_")) |>
   ds2dd_detailed()
 

man/possibly_roman.Rd

@@ -16,7 +16,9 @@ logical
 Test if vector can be interpreted as roman numerals
 }
 \examples{
-sample(1:100,10) |> as.roman() |> possibly_roman()
+sample(1:100, 10) |>
+  as.roman() |>
+  possibly_roman()
 sample(c(TRUE, FALSE), 10, TRUE) |> possibly_roman()
 rep(NA, 10) |> possibly_roman()
 }

man/redcap_meta_default.Rd

@@ -0,0 +1,20 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/ds2dd_detailed.R
+\name{redcap_meta_default}
+\alias{redcap_meta_default}
+\title{Default column names of a REDCap data dictionary}
+\usage{
+redcap_meta_default(...)
+}
+\arguments{
+\item{...}{ignored for now}
+}
+\value{
+character vector
+}
+\description{
+Default column names of a REDCap data dictionary
+}
+\examples{
+dput(redcap_meta_default())
+}

man/redcapcast_meta.Rd

@@ -31,6 +31,6 @@ A data frame with 22 variables:
 data(redcapcast_meta)
 }
 \description{
-This metadata dataset from a REDCap database is for demonstrational purposes.
+This metadata dataset from a REDCap database is for demonstration purposes.
 }
 \keyword{datasets}

tests/testthat/test-ds2dd.R

@@ -1,9 +1,20 @@
 mtcars$id <- seq_len(nrow(mtcars))
 
+metadata_names <- function(...) {
+  c(
+    "field_name", "form_name", "section_header", "field_type",
+    "field_label", "select_choices_or_calculations", "field_note",
+    "text_validation_type_or_show_slider_number", "text_validation_min",
+    "text_validation_max", "identifier", "branching_logic", "required_field",
+    "custom_alignment", "question_number", "matrix_group_name", "matrix_ranking",
+    "field_annotation"
+  )
+}
+
 test_that("ds2dd gives desired output", {
-  expect_equal(ncol(ds2dd(mtcars, record.id = "id")), 18)
+  expect_equal(ncol(ds2dd(mtcars, record.id = "id",metadata = metadata_names())), 18)
-  expect_s3_class(ds2dd(mtcars, record.id = "id"), "data.frame")
+  expect_s3_class(ds2dd(mtcars, record.id = "id",metadata = metadata_names()), "data.frame")
-  expect_s3_class(ds2dd(mtcars, record.id = 12), "data.frame")
+  expect_s3_class(ds2dd(mtcars, record.id = 12,metadata = metadata_names()), "data.frame")
 })
 
 
@@ -11,19 +22,19 @@ test_that("ds2dd gives output with list of length two", {
   expect_equal(length(ds2dd(
     mtcars,
     record.id = "id",
-    include.column.names = TRUE
+    include.column.names = TRUE,metadata = metadata_names()
   )), 2)
 })
 
 
 test_that("ds2dd gives correct errors", {
-  expect_error(ds2dd(mtcars))
+  expect_error(ds2dd(mtcars,metadata = metadata_names()))
-  expect_error(ds2dd(mtcars, form.name = c("basis", "incl")))
+  expect_error(ds2dd(mtcars, form.name = c("basis", "incl"),metadata = metadata_names()))
-  expect_error(ds2dd(mtcars, field.type = c("text", "dropdown")))
+  expect_error(ds2dd(mtcars, field.type = c("text", "dropdown"),metadata = metadata_names()))
-  expect_error(ds2dd(mtcars, field.label = c("Name", "Age")))
+  expect_error(ds2dd(mtcars, field.label = c("Name", "Age"),metadata = metadata_names()))
 })
 
 test_that("ds2dd correctly renames", {
-  expect_equal(ncol(ds2dd(mtcars, record.id = "id")), 18)
+  expect_equal(ncol(ds2dd(mtcars, record.id = "id",metadata = metadata_names())), 18)
-  expect_s3_class(ds2dd(mtcars, record.id = "id"), "data.frame")
+  expect_s3_class(ds2dd(mtcars, record.id = "id",metadata = metadata_names()), "data.frame")
 })

vignettes/Database-creation.Rmd

@@ -32,7 +32,7 @@ In the following I will try to come with a few suggestions on how to use these a
 
 The first iteration of a dataset to data dictionary function is the `ds2dd()`, which creates a very basic data dictionary with all variables stored as text. This is sufficient for just storing old datasets/spreadsheets securely in REDCap.
 
-```{r eval=TRUE}
+```{r eval=FALSE}
 d1 <- mtcars |>
   dplyr::mutate(record_id = seq_len(dplyr::n())) |>
   ds2dd()