From 9b4ddafe6f086aa3a0e4aef011de4d4320d0d00e Mon Sep 17 00:00:00 2001 From: Andreas Gammelgaard Damsbo Date: Fri, 27 Mar 2026 21:56:57 +0100 Subject: [PATCH] fix: keep level labels --- R/redcap_read_shiny_module.R | 378 ++++++++++++++++++----------------- 1 file changed, 194 insertions(+), 184 deletions(-) diff --git a/R/redcap_read_shiny_module.R b/R/redcap_read_shiny_module.R index a74c599a..2b26d929 100644 --- a/R/redcap_read_shiny_module.R +++ b/R/redcap_read_shiny_module.R @@ -11,10 +11,7 @@ m_redcap_readUI <- function(id, title = TRUE, url = NULL) { ns <- shiny::NS(id) if (isTRUE(title)) { - title <- shiny::tags$h4( - i18n$t("Import data from REDCap"), - class = "redcap-module-title" - ) + title <- shiny::tags$h4(i18n$t("Import data from REDCap"), class = "redcap-module-title") } server_ui <- shiny::tagList( @@ -25,7 +22,11 @@ m_redcap_readUI <- function(id, title = TRUE, url = NULL) { value = if_not_missing(url, "https://redcap.your.institution/"), width = "100%" ), - shiny::helpText(i18n$t("Format should be either 'https://redcap.your.institution/' or 'https://your.institution/redcap/'")), + shiny::helpText( + i18n$t( + "Format should be either 'https://redcap.your.institution/' or 'https://your.institution/redcap/'" + ) + ), shiny::br(), shiny::br(), shiny::passwordInput( @@ -34,7 +35,9 @@ m_redcap_readUI <- function(id, title = TRUE, url = NULL) { value = "", width = "100%" ), - shiny::helpText(i18n$t("The token is a string of 32 numbers and letters.")), + shiny::helpText(i18n$t( + "The token is a string of 32 numbers and letters." + )), shiny::br(), shiny::br(), shiny::actionButton( @@ -51,7 +54,10 @@ m_redcap_readUI <- function(id, title = TRUE, url = NULL) { shinyWidgets::alert( id = ns("connect-result"), status = "info", - tags$p(phosphoricons::ph("info", weight = "bold"), i18n$t("Please fill in web address and API token, then press 'Connect'.")) + tags$p( + phosphoricons::ph("info", weight = "bold"), + i18n$t("Please fill in web address and API token, then press 'Connect'.") + ) ), dismissible = TRUE ), @@ -64,8 +70,8 @@ m_redcap_readUI <- function(id, title = TRUE, url = NULL) { shiny::uiOutput(outputId = ns("arms")), shiny::textInput( inputId = ns("filter"), - label = i18n$t("Optional filter logic (e.g., ⁠[gender] = 'female')" - )) + label = i18n$t("Optional filter logic (e.g., ⁠[gender] = 'female')") + ) ) params_ui <- @@ -96,7 +102,11 @@ m_redcap_readUI <- function(id, title = TRUE, url = NULL) { ) ) ), - shiny::helpText(i18n$t("Select fields/variables to import and click the funnel to apply optional filters")), + shiny::helpText( + i18n$t( + "Select fields/variables to import and click the funnel to apply optional filters" + ) + ), shiny::tags$br(), shiny::tags$br(), shiny::uiOutput(outputId = ns("data_type")), @@ -115,7 +125,10 @@ m_redcap_readUI <- function(id, title = TRUE, url = NULL) { shinyWidgets::alert( id = ns("retrieved-result"), status = "info", - tags$p(phosphoricons::ph("info", weight = "bold"), "Please specify data to download, then press 'Import'.") + tags$p( + phosphoricons::ph("info", weight = "bold"), + "Please specify data to download, then press 'Import'." + ) ), dismissible = TRUE ) @@ -126,11 +139,7 @@ m_redcap_readUI <- function(id, title = TRUE, url = NULL) { title = title, server_ui, # shiny::uiOutput(ns("params_ui")), - shiny::conditionalPanel( - condition = "output.connect_success == true", - params_ui, - ns = ns - ), + shiny::conditionalPanel(condition = "output.connect_success == true", params_ui, ns = ns), shiny::br() ) } @@ -162,7 +171,11 @@ m_redcap_readServer <- function(id) { shiny::req(input$api) shiny::req(input$uri) if (!is.null(input$uri)) { - uri <- paste0(ifelse(endsWith(input$uri, "/"), input$uri, paste0(input$uri, "/")), "api/") + uri <- paste0(ifelse( + endsWith(input$uri, "/"), + input$uri, + paste0(input$uri, "/") + ), "api/") } else { uri <- input$uri } @@ -176,75 +189,68 @@ m_redcap_readServer <- function(id) { }) - tryCatch( - { - shiny::observeEvent( - list( - input$data_connect - ), - { - shiny::req(input$api) - shiny::req(data_rv$uri) + tryCatch({ + shiny::observeEvent(list(input$data_connect), { + shiny::req(input$api) + shiny::req(data_rv$uri) - parameters <- list( - redcap_uri = data_rv$uri, - token = input$api - ) + parameters <- list(redcap_uri = data_rv$uri, token = input$api) - # browser() - shiny::withProgress( - { - imported <- try(rlang::exec(REDCapR::redcap_metadata_read, !!!parameters), silent = TRUE) - }, - message = paste("Connecting to", data_rv$uri) - ) + # browser() + shiny::withProgress({ + imported <- try(rlang::exec(REDCapR::redcap_metadata_read, !!!parameters), + silent = TRUE) + }, message = paste("Connecting to", data_rv$uri)) - ## TODO: Simplify error messages - if (inherits(imported, "try-error") || NROW(imported) < 1 || ifelse(is.list(imported), !isTRUE(imported$success), FALSE)) { - if (ifelse(is.list(imported), !isTRUE(imported$success), FALSE)) { - mssg <- imported$raw_text - } else { - mssg <- attr(imported, "condition")$message - } + ## TODO: Simplify error messages + if (inherits(imported, "try-error") || + NROW(imported) < 1 || + ifelse(is.list(imported), !isTRUE(imported$success), FALSE)) { + if (ifelse(is.list(imported), + !isTRUE(imported$success), + FALSE)) { + mssg <- imported$raw_text + } else { + mssg <- attr(imported, "condition")$message + } - datamods:::insert_error(mssg = mssg, selector = "connect") - data_rv$dd_status <- "error" - data_rv$dd_list <- NULL - } else if (isTRUE(imported$success)) { - data_rv$dd_status <- "success" + datamods:::insert_error(mssg = mssg, selector = "connect") + data_rv$dd_status <- "error" + data_rv$dd_list <- NULL + } else if (isTRUE(imported$success)) { + data_rv$dd_status <- "success" - data_rv$info <- REDCapR::redcap_project_info_read( - redcap_uri = data_rv$uri, - token = input$api - )$data + data_rv$info <- REDCapR::redcap_project_info_read(redcap_uri = data_rv$uri, token = input$api)$data - datamods:::insert_alert( - selector = ns("connect"), - status = "success", - include_data_alert( - see_data_text = i18n$t("Click to see data dictionary"), - dataIdName = "see_dd", - extra = tags$p( - tags$b(phosphoricons::ph("check", weight = "bold"), i18n$t("Connected to server!")), - glue::glue(i18n$t("The {data_rv$info$project_title} project is loaded.")) - ), - btn_show_data = TRUE + datamods:::insert_alert( + selector = ns("connect"), + status = "success", + include_data_alert( + see_data_text = i18n$t("Click to see data dictionary"), + dataIdName = "see_dd", + extra = tags$p( + tags$b( + phosphoricons::ph("check", weight = "bold"), + i18n$t("Connected to server!") + ), + glue::glue( + i18n$t( + "The {data_rv$info$project_title} project is loaded." + ) ) - ) + ), + btn_show_data = TRUE + ) + ) - data_rv$dd_list <- imported - } - }, - ignoreInit = TRUE - ) - }, - warning = function(warn) { - showNotification(paste0(warn), type = "warning") - }, - error = function(err) { - showNotification(paste0(err), type = "err") - } - ) + data_rv$dd_list <- imported + } + }, ignoreInit = TRUE) + }, warning = function(warn) { + showNotification(paste0(warn), type = "warning") + }, error = function(err) { + showNotification(paste0(err), type = "err") + }) output$connect_success <- shiny::reactive(identical(data_rv$dd_status, "success")) shiny::outputOptions(output, "connect_success", suspendWhenHidden = FALSE) @@ -275,10 +281,7 @@ m_redcap_readServer <- function(id) { shiny::req(input$api) shiny::req(data_rv$uri) - REDCapR::redcap_event_read( - redcap_uri = data_rv$uri, - token = input$api - )$data + REDCapR::redcap_event_read(redcap_uri = data_rv$uri, token = input$api)$data }) output$fields <- shiny::renderUI({ @@ -288,7 +291,7 @@ m_redcap_readServer <- function(id) { label = i18n$t("Select fields/variables to import:"), choices = purrr::pluck(data_rv$dd_list, "data") |> dplyr::select(field_name, form_name) |> - (\(.x){ + (\(.x) { split(.x$field_name, REDCapCAST::as_factor(.x$form_name)) })(), updateOn = "change", @@ -321,14 +324,10 @@ m_redcap_readServer <- function(id) { shiny::req(input$data_type) ## Get repeated field - data_rv$rep_fields <- data_rv$dd_list$data$field_name[ - data_rv$dd_list$data$form_name %in% repeated_instruments( - uri = data_rv$uri, - token = input$api - ) - ] + data_rv$rep_fields <- data_rv$dd_list$data$field_name[data_rv$dd_list$data$form_name %in% repeated_instruments(uri = data_rv$uri, token = input$api)] - if (input$data_type == "long" && isTRUE(any(input$fields %in% data_rv$rep_fields))) { + if (input$data_type == "long" && + isTRUE(any(input$fields %in% data_rv$rep_fields))) { vectorSelectInput( inputId = ns("fill"), label = i18n$t("Fill missing values?"), @@ -370,7 +369,6 @@ m_redcap_readServer <- function(id) { # browser() record_id <- purrr::pluck(data_rv$dd_list, "data")[[1]][1] - parameters <- list( uri = data_rv$uri, token = input$api, @@ -386,26 +384,31 @@ m_redcap_readServer <- function(id) { ) shiny::withProgress(message = "Downloading REDCap data. Hold on for a moment..", { - imported <- try(rlang::exec(REDCapCAST::read_redcap_tables, !!!parameters), silent = TRUE) + imported <- tryCatch(rlang::exec(REDCapCAST::read_redcap_tables, !!!parameters), + silent = TRUE) }) - parameters_code <- parameters[c("uri", "fields", "events", "raw_or_label", "filter_logic")] + # d <- REDCapCAST::apply_factor_labels(data = imported$survey, meta = data_rv$dd_list$data) - code <- rlang::call2( - "easy_redcap", - !!!utils::modifyList( - parameters_code, - list( - data_format = ifelse( - input$data_type == "long" && !is.null(input$data_type), - "long", - "wide" - ), - project.name = simple_snake(data_rv$info$project_title) - ) - ), - .ns = "REDCapCAST" - ) + parameters_code <- parameters[c("uri", + "fields", + "events", + "raw_or_label", + "filter_logic")] + + code <- rlang::call2("easy_redcap", + !!!utils::modifyList( + parameters_code, + list( + data_format = ifelse( + input$data_type == "long" && !is.null(input$data_type), + "long", + "wide" + ), + project.name = simple_snake(data_rv$info$project_title) + ) + ), + .ns = "REDCapCAST") if (inherits(imported, "try-error") || NROW(imported) < 1) { data_rv$data_status <- "error" @@ -419,7 +422,6 @@ m_redcap_readServer <- function(id) { ## "wide"/"long" without re-importing data if (parameters$split_form == "all") { - # browser() out <- imported |> # redcap_wider() REDCapCAST::redcap_wider() @@ -442,78 +444,91 @@ m_redcap_readServer <- function(id) { } } - # browser() + ## Ensure correct factor labels + ## It is a little hacky and should be included in the read_redcap_tables, but is lost along the way + out <- REDCapCAST::apply_factor_labels(data = out, meta = data_rv$dd_list$data) + + in_data_check <- parameters$fields %in% names(out) | - sapply(names(out), \(.x) any(sapply(parameters$fields, \(.y) startsWith(.x, .y)))) + sapply(names(out), \(.x) any(sapply( + parameters$fields, \(.y) startsWith(.x, .y) + ))) if (!any(in_data_check[-1])) { data_rv$data_status <- "warning" - data_rv$data_message <- i18n$t("Data retrieved, but it looks like only the ID was retrieved from the server. Please check with your REDCap administrator that you have required permissions for data access.") + data_rv$data_message <- i18n$t( + "Data retrieved, but it looks like only the ID was retrieved from the server. Please check with your REDCap administrator that you have required permissions for data access." + ) } if (!all(in_data_check)) { data_rv$data_status <- "warning" - data_rv$data_message <- i18n$t("Data retrieved, but it looks like not all requested fields were retrieved from the server. Please check with your REDCap administrator that you have required permissions for data access.") + data_rv$data_message <- i18n$t( + "Data retrieved, but it looks like not all requested fields were retrieved from the server. Please check with your REDCap administrator that you have required permissions for data access." + ) } data_rv$code <- code + ## Level labels nare lost at this point... data_rv$data <- out |> dplyr::select(-dplyr::ends_with("_complete")) |> # dplyr::select(-dplyr::any_of(record_id)) |> REDCapCAST::suffix2label() + } }) - shiny::observeEvent( - data_rv$data_status, - { - # browser() - if (identical(data_rv$data_status, "error")) { - datamods:::insert_error(mssg = data_rv$data_message, selector = ns("retrieved")) - } else if (identical(data_rv$data_status, "success")) { - datamods:::insert_alert( - selector = ns("retrieved"), - status = data_rv$data_status, - # tags$p( - # tags$b(phosphoricons::ph("check", weight = "bold"), "Success!"), - # data_rv$data_message - # ), - include_data_alert( - see_data_text = i18n$t("Click to see the imported data"), - dataIdName = "see_data", - extra = tags$p( - tags$b(phosphoricons::ph("check", weight = "bold"), data_rv$data_message) - ), - btn_show_data = TRUE - ) - ) - } else { - datamods:::insert_alert( - selector = ns("retrieved"), - status = data_rv$data_status, - tags$p( - tags$b(phosphoricons::ph("warning", weight = "bold"), "Warning!"), + shiny::observeEvent(data_rv$data_status, { + # browser() + if (identical(data_rv$data_status, "error")) { + datamods:::insert_error(mssg = data_rv$data_message, + selector = ns("retrieved")) + } else if (identical(data_rv$data_status, "success")) { + datamods:::insert_alert( + selector = ns("retrieved"), + status = data_rv$data_status, + # tags$p( + # tags$b(phosphoricons::ph("check", weight = "bold"), "Success!"), + # data_rv$data_message + # ), + include_data_alert( + see_data_text = i18n$t("Click to see the imported data"), + dataIdName = "see_data", + extra = tags$p(tags$b( + phosphoricons::ph("check", weight = "bold"), data_rv$data_message - ) + )), + btn_show_data = TRUE ) - } + ) + } else { + datamods:::insert_alert( + selector = ns("retrieved"), + status = data_rv$data_status, + tags$p( + tags$b( + phosphoricons::ph("warning", weight = "bold"), + "Warning!" + ), + data_rv$data_message + ) + ) } - ) + }) - return(list( - status = shiny::reactive(data_rv$data_status), - name = shiny::reactive(data_rv$info$project_title), - info = shiny::reactive(data_rv$info), - code = shiny::reactive(data_rv$code), - data = shiny::reactive(data_rv$data) - )) + return( + list( + status = shiny::reactive(data_rv$data_status), + name = shiny::reactive(data_rv$info$project_title), + info = shiny::reactive(data_rv$info), + code = shiny::reactive(data_rv$code), + data = shiny::reactive(data_rv$data) + ) + ) } - shiny::moduleServer( - id = id, - module = module - ) + shiny::moduleServer(id = id, module = module) } #' @importFrom htmltools tagList tags @@ -524,14 +539,12 @@ include_data_alert <- function(dataIdName = "see_data", extra = NULL, session = shiny::getDefaultReactiveDomain()) { if (isTRUE(btn_show_data)) { - success_message <- tagList( - extra, - tags$br(), - shiny::actionLink( - inputId = session$ns(dataIdName), - label = tagList(phosphoricons::ph("book-open-text"), see_data_text) - ) - ) + success_message <- tagList(extra, + tags$br(), + shiny::actionLink( + inputId = session$ns(dataIdName), + label = tagList(phosphoricons::ph("book-open-text"), see_data_text) + )) } return(success_message) } @@ -583,20 +596,18 @@ is_valid_redcap_url <- function(url) { #' @examples #' token <- paste(sample(c(1:9, LETTERS[1:6]), 32, TRUE), collapse = "") #' is_valid_token(token) -is_valid_token <- function(token, pattern_env = NULL, nchar = 32) { +is_valid_token <- function(token, + pattern_env = NULL, + nchar = 32) { checkmate::assert_character(token, any.missing = TRUE, len = 1) if (!is.null(pattern_env)) { - checkmate::assert_character(pattern_env, - any.missing = FALSE, - len = 1 - ) + checkmate::assert_character(pattern_env, any.missing = FALSE, len = 1) pattern <- pattern_env } else { pattern <- glue::glue("^([0-9A-Fa-f]{})(?:\\n)?$", - .open = "<", - .close = ">" - ) + .open = "<", + .close = ">") } if (is.na(token)) { @@ -636,10 +647,15 @@ repeated_instruments <- function(uri, token) { #' @export #' drop_empty_event <- function(data, event = "redcap_event_name") { - generics <- c(names(data)[1], "redcap_event_name", "redcap_repeat_instrument", "redcap_repeat_instance") + generics <- c( + names(data)[1], + "redcap_event_name", + "redcap_repeat_instrument", + "redcap_repeat_instance" + ) filt <- split(data, data[[event]]) |> - lapply(\(.x){ + lapply(\(.x) { dplyr::select(.x, -tidyselect::all_of(generics)) |> REDCapCAST::all_na() }) |> @@ -667,16 +683,10 @@ redcap_demo_app <- function() { server <- function(input, output, session) { data_val <- m_redcap_readServer(id = "data") - output$data <- DT::renderDataTable( - { - shiny::req(data_val$data) - data_val$data() - }, - options = list( - scrollX = TRUE, - pageLength = 5 - ), - ) + output$data <- DT::renderDataTable({ + shiny::req(data_val$data) + data_val$data() + }, options = list(scrollX = TRUE, pageLength = 5), ) output$code <- shiny::renderPrint({ shiny::req(data_val$code) data_val$code()