keeping pegeler as coauthor

DESCRIPTION

@@ -6,12 +6,13 @@ Authors@R: c(
     role = c("aut", "cre"),comment = c(ORCID = "0000-0002-7559-1154")), 
     person("Paul", "Egeler", email = "paulegeler@gmail.com", role = c("aut"), 
     comment = c(ORCID = "0000-0001-6948-9498")))
-Description: Originally forked from the R part of 'REDCapRITS' by Paul Egeler. 
+Description: Casting metadata for REDCap database creation and handling of 
+    castellated data using repeated instruments and longitudinal projects in 
+    'REDCap'. Keeps a focused data export approach, by allowing to only export 
+    required data from the database. Also for casting new REDCap databases based 
+    on datasets from other sources.
+    Originally forked from the R part of 'REDCapRITS' by Paul Egeler. 
     See <https://github.com/pegeler/REDCapRITS>.
-    'REDCap' database casting and handling of castellated data when using 
-    repeated instruments and longitudinal projects. Keeps a focused data export 
-    approach, by allowing to only export required data from the database.
-    Also for casting new REDCap databases based on datasets from other sources.
     'REDCap' (Research Electronic Data Capture) is a secure, web-based software
     platform designed to support data capture for research studies, providing
     1) an intuitive interface for validated data capture; 2) audit trails for

NAMESPACE

@@ -21,6 +21,7 @@ export(file_extension)
 export(focused_metadata)
 export(format_subheader)
 export(get_api_key)
+export(get_attr)
 export(guess_time_only)
 export(guess_time_only_filter)
 export(haven_all_levels)
@@ -35,6 +36,7 @@ export(read_redcap_instrument)
 export(read_redcap_tables)
 export(redcap_wider)
 export(sanitize_split)
+export(set_attr)
 export(shiny_cast)
 export(split_non_repeating_forms)
 export(strsplitx)

NEWS.md

@@ -2,7 +2,7 @@
 
 24.11.1 was rejected on CRAN based on wrong title capitalisation. This was an opportunity to extend the package overhaul.
 
-Documentation has been updated. Data parser functions have been added (based on readr) and separated from the ds2dd_detailed().
+Documentation has been updated. Data parser functions have been added (based on readr) and separated from the ds2dd_detailed(). Now also includes conversion of logicals to factor as REDCap truefalse class follows different naming conversion compared to R. Also correct support for variable labels as field labels (use .rds formatted data and label with labelled::var_label())
 
 Vignettes and documentation have been restructured.
 

R/ds2dd_detailed.R

@@ -135,6 +135,7 @@ hms2character <- function(data) {
 #' file with `haven::read_dta()`).
 #' @param metadata redcap metadata headings. Default is
 #' REDCapCAST:::metadata_names.
+#' @param convert.logicals convert logicals to factor. Default is TRUE.
 #'
 #' @return list of length 2
 #' @export
@@ -166,7 +167,28 @@ ds2dd_detailed <- function(data,
                            field.label = NULL,
                            field.label.attr = "label",
                            field.validation = NULL,
-                           metadata = names(REDCapCAST::redcapcast_meta)) {
+                           metadata = names(REDCapCAST::redcapcast_meta),
+                           convert.logicals = TRUE) {
+
+  if (convert.logicals) {
+    # Labels/attributes are saved
+    labels <- lapply(data, \(.x){
+      get_attr(.x, attr = NULL)
+    })
+
+    no_attr <- data |>
+      ## Converts logical to factor, which overwrites attributes
+      dplyr::mutate(dplyr::across(dplyr::where(is.logical), forcats::as_factor))
+
+    # Old attributes are appended
+    data <- purrr::imap(no_attr,\(.x,.i){
+      attributes(.x) <- c(attributes(.x),labels[[.i]])
+      .x
+    }) |>
+      dplyr::bind_cols()
+
+  }
+
   ## Handles the odd case of no id column present
   if (add.auto.id) {
     data <- dplyr::tibble(
@@ -224,15 +246,9 @@ ds2dd_detailed <- function(data,
 
   if (is.null(field.label)) {
     dd$field_label <- data |>
-      lapply(function(x) {
+      sapply(function(x) {
-        if (haven::is.labelled(x)) {
+        get_attr(x, attr = field.label.attr)
-          att <- haven_all_levels(x)
+      })
-          names(att)
-        } else {
-          NA
-        }
-      }) |>
-      (\(x)do.call(c, x))()
 
     dd <-
       dd |> dplyr::mutate(field_label = dplyr::if_else(is.na(field_label),
@@ -353,6 +369,8 @@ ds2dd_detailed <- function(data,
 #'   labels = c(Unknown = 9, Refused = 10),
 #'   class = "haven_labelled"
 #' )
+#' haven::is.labelled(ds)
+#' attributes(ds)
 #' ds |> haven_all_levels()
 haven_all_levels <- function(data) {
   stopifnot(haven::is.labelled(data))
@@ -548,3 +566,51 @@ numchar2fct <- function(data, numeric.threshold = 6, character.throshold = 6) {
       )
     )
 }
+
+#' Extract attribute. Returns NA if none
+#'
+#' @param data vector
+#' @param attr attribute name
+#'
+#' @return character vector
+#' @export
+#'
+#' @examples
+#' attr(mtcars$mpg, "label") <- "testing"
+#' sapply(mtcars, get_attr)
+#' 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)
+  } else {
+    a <- attr(data, attr, exact = TRUE)
+    if (is.null(a)) {
+      NA
+    } else {
+      a
+    }
+  }
+}
+
+
+#' Set attributes for named attribute. Appends if attr is NULL
+#'
+#' @param data vector
+#' @param label label
+#' @param attr attribute name
+#'
+#' @return vector with attribute
+#' @export
+#'
+set_attr <- function(data, label, attr = NULL) {
+  if (is.null(attr)) {
+    attributes(data) <- c(attributes(data),label)
+  } else {
+    attr(data, attr) <- label
+  }
+  data
+}
+

R/shiny_cast.R

@@ -62,10 +62,12 @@ read_input <- function(file, consider.na = c("NA", '""', "")) {
       } else if (ext == "dta") {
         df <- haven::read_dta(file = file)
       } else if (ext == "ods") {
-        df <- readODS::read_ods(file = file)
+        df <- readODS::read_ods(path = file)
+      } else if (ext == "rds") {
+        df <- readr::read_rds(file = file)
       }else {
         stop("Input file format has to be on of:
-             '.csv', '.xls', '.xlsx', '.dta' or '.ods'")
+             '.csv', '.xls', '.xlsx', '.dta', '.rds' or '.ods'")
       }
     },
     error = function(e) {

inst/shiny-examples/casting/rsconnect/shinyapps.io/agdamsbo/redcapcast.dcf

@@ -0,0 +1,10 @@
+name: redcapcast
+title:
+username: agdamsbo
+account: agdamsbo
+server: shinyapps.io
+hostUrl: https://api.shinyapps.io/v1
+appId: 11351429
+bundleId:
+url: https://agdamsbo.shinyapps.io/redcapcast/
+version: 1

inst/shiny-examples/casting/server.R

@@ -21,8 +21,35 @@ server <- function(input, output, session) {
   dat <- shiny::reactive({
     shiny::req(input$ds)
 
-    read_input(input$ds$datapath) |>
+    out <- read_input(input$ds$datapath)
-      parse_data()
+
+    # Saves labels to reapply later
+    labels <- lapply(out, get_attr)
+
+    out <- out |>
+      ## Parses data with readr functions
+      parse_data() |>
+      ## Converts logical to factor, which overwrites attributes
+      ##
+      dplyr::mutate(dplyr::across(dplyr::where(is.logical), forcats::as_factor))
+
+    if (!is.null(input$factor_vars)) {
+      out <- out |>
+        dplyr::mutate(
+          dplyr::across(
+            dplyr::all_of(input$factor_vars),
+            forcats::as_factor
+          )
+        )
+    }
+
+    # Old attributes are appended
+    out <- purrr::imap(out,\(.x,.i){
+      set_attr(.x,labels[[.i]])
+    }) |>
+      dplyr::bind_cols()
+
+    out
   })
 
   # getData <- reactive({
@@ -48,19 +75,66 @@ server <- function(input, output, session) {
 
   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
+    )
+  })
+
   output$data.tbl <- gt::render_gt(
     dd() |>
       purrr::pluck("data") |>
       head(20) |>
-      dplyr::tibble() |>
+      # dplyr::tibble() |>
-      gt::gt()
+      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() |>
       purrr::pluck("meta") |>
-      dplyr::tibble() |>
+      # dplyr::tibble() |>
-      gt::gt()
+      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 ----
@@ -73,7 +147,7 @@ server <- function(input, output, session) {
 
   # Downloadable csv of data dictionary ----
   output$downloadMeta <- shiny::downloadHandler(
-    filename = "datadictionary_ready.csv",
+    filename = paste0("REDCapCAST_DataDictionary_", Sys.Date(), ".csv"),
     content = function(file) {
       write.csv(purrr::pluck(dd(), "meta"), file, row.names = FALSE, na = "")
     }

inst/shiny-examples/casting/ui.R

@@ -6,7 +6,7 @@ ui <-
       title = "Easy REDCap database creation",
       sidebar = bslib::sidebar(
         width = 300,
-        shiny::h5("1) Database meta data"),
+        shiny::h5("Metadata casting"),
         shiny::fileInput(
           inputId = "ds",
           label = "Upload spreadsheet",
@@ -16,6 +16,7 @@ ui <-
             ".xls",
             ".xlsx",
             ".dta",
+            ".rds",
             ".ods"
           )
         ),
@@ -29,6 +30,20 @@ ui <-
         # 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 = "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."),

man/REDCapCAST-package.Rd

@@ -8,7 +8,7 @@
 \description{
 \if{html}{\figure{logo.png}{options: style='float: right' alt='logo' width='120'}}
 
-Originally forked from the R part of 'REDCapRITS' by Paul Egeler. See \url{https://github.com/pegeler/REDCapRITS}. 'REDCap' database casting and handling of castellated data when using repeated instruments and longitudinal projects. Keeps a focused data export approach, by allowing to only export required data from the database. Also for casting new REDCap databases based on datasets from other sources. 'REDCap' (Research Electronic Data Capture) is a secure, web-based software platform designed to support data capture for research studies, providing 1) an intuitive interface for validated data capture; 2) audit trails for tracking data manipulation and export procedures; 3) automated export procedures for seamless data downloads to common statistical packages; and 4) procedures for data integration and interoperability with external sources (Harris et al (2009) \doi{10.1016/j.jbi.2008.08.010}; Harris et al (2019) \doi{10.1016/j.jbi.2019.103208}).
+Casting metadata for REDCap database creation and handling of castellated data using repeated instruments and longitudinal projects in 'REDCap'. Keeps a focused data export approach, by allowing to only export required data from the database. Also for casting new REDCap databases based on datasets from other sources. Originally forked from the R part of 'REDCapRITS' by Paul Egeler. See \url{https://github.com/pegeler/REDCapRITS}. 'REDCap' (Research Electronic Data Capture) is a secure, web-based software platform designed to support data capture for research studies, providing 1) an intuitive interface for validated data capture; 2) audit trails for tracking data manipulation and export procedures; 3) automated export procedures for seamless data downloads to common statistical packages; and 4) procedures for data integration and interoperability with external sources (Harris et al (2009) \doi{10.1016/j.jbi.2008.08.010}; Harris et al (2019) \doi{10.1016/j.jbi.2019.103208}).
 }
 \seealso{
 Useful links:
@@ -22,10 +22,5 @@ Useful links:
 \author{
 \strong{Maintainer}: Andreas Gammelgaard Damsbo \email{agdamsbo@clin.au.dk} (\href{https://orcid.org/0000-0002-7559-1154}{ORCID})
 
-Authors:
-\itemize{
-  \item Paul Egeler \email{paulegeler@gmail.com} (\href{https://orcid.org/0000-0001-6948-9498}{ORCID})
-}
-
 }
 \keyword{internal}

man/ds2dd_detailed.Rd

@@ -15,7 +15,8 @@ ds2dd_detailed(
   field.label = NULL,
   field.label.attr = "label",
   field.validation = NULL,
-  metadata = names(REDCapCAST::redcapcast_meta)
+  metadata = names(REDCapCAST::redcapcast_meta),
+  convert.logicals = TRUE
 )
 }
 \arguments{
@@ -55,6 +56,8 @@ file with `haven::read_dta()`).}
 
 \item{metadata}{redcap metadata headings. Default is
 REDCapCAST:::metadata_names.}
+
+\item{convert.logicals}{convert logicals to factor. Default is TRUE.}
 }
 \value{
 list of length 2

man/get_attr.Rd

@@ -0,0 +1,27 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/ds2dd_detailed.R
+\name{get_attr}
+\alias{get_attr}
+\title{Extract attribute. Returns NA if none}
+\usage{
+get_attr(data, attr = NULL)
+}
+\arguments{
+\item{data}{vector}
+
+\item{attr}{attribute name}
+}
+\value{
+character vector
+}
+\description{
+Extract attribute. Returns NA if none
+}
+\examples{
+attr(mtcars$mpg, "label") <- "testing"
+sapply(mtcars, get_attr)
+lapply(mtcars, \(.x)get_attr(.x, NULL))
+mtcars |>
+  numchar2fct(numeric.threshold = 6) |>
+  ds2dd_detailed()
+}

man/haven_all_levels.Rd

@@ -20,5 +20,7 @@ ds <- structure(c(1, 2, 3, 2, 10, 9),
   labels = c(Unknown = 9, Refused = 10),
   class = "haven_labelled"
 )
+haven::is.labelled(ds)
+attributes(ds)
 ds |> haven_all_levels()
 }

man/set_attr.Rd

@@ -0,0 +1,21 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/ds2dd_detailed.R
+\name{set_attr}
+\alias{set_attr}
+\title{Set attributes for named attribute. Appends if attr is NULL}
+\usage{
+set_attr(data, label, attr = NULL)
+}
+\arguments{
+\item{data}{vector}
+
+\item{label}{label}
+
+\item{attr}{attribute name}
+}
+\value{
+vector with attribute
+}
+\description{
+Set attributes for named attribute. Appends if attr is NULL
+}