implemented specification of categorical variables (logicals are converted to factor)

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) |>
-      parse_data()
+    out <- read_input(input$ds$datapath)
+
+    # 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() |>
-      gt::gt()
+      # 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() |>
       purrr::pluck("meta") |>
-      dplyr::tibble() |>
-      gt::gt()
+      # 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 ----
@@ -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."),