andreas/FreesearchR
1
0
Fork 0
mirror of https://github.com/agdamsbo/FreesearchR.git synced 2026-06-19 12:37:30 +02:00
Code Issues Projects Releases Packages Wiki Activity

fix: keep level labels

Browse source
This commit is contained in:
Andreas Gammelgaard Damsbo 2026-03-27 21:56:57 +01:00
commit 9b4ddafe6f
No known key found for this signature in database
1 changed files with 198 additions and 188 deletions
Download patch file Download diff file Expand all files Collapse all files

230
R/redcap_read_shiny_module.R
View file

@ -11,10 +11,7 @@ m_redcap_readUI <- function(id, title = TRUE, url = NULL) {
ns <- shiny::NS(id) ns <- shiny::NS(id)
if (isTRUE(title)) { if (isTRUE(title)) {
title <- shiny::tags$h4( title <- shiny::tags$h4(i18n$t("Import data from REDCap"), class = "redcap-module-title")
i18n$t("Import data from REDCap"),
class = "redcap-module-title"
)
} }
server_ui <- shiny::tagList( 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/"), value = if_not_missing(url, "https://redcap.your.institution/"),
width = "100%" 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::br(), shiny::br(),
shiny::passwordInput( shiny::passwordInput(
@ -34,7 +35,9 @@ m_redcap_readUI <- function(id, title = TRUE, url = NULL) {
value = "", value = "",
width = "100%" 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::br(), shiny::br(),
shiny::actionButton( shiny::actionButton(
@ -51,7 +54,10 @@ m_redcap_readUI <- function(id, title = TRUE, url = NULL) {
shinyWidgets::alert( shinyWidgets::alert(
id = ns("connect-result"), id = ns("connect-result"),
status = "info", 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 dismissible = TRUE
), ),
@ -64,8 +70,8 @@ m_redcap_readUI <- function(id, title = TRUE, url = NULL) {
shiny::uiOutput(outputId = ns("arms")), shiny::uiOutput(outputId = ns("arms")),
shiny::textInput( shiny::textInput(
inputId = ns("filter"), 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 <- 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::tags$br(), shiny::tags$br(),
shiny::uiOutput(outputId = ns("data_type")), shiny::uiOutput(outputId = ns("data_type")),
@ -115,7 +125,10 @@ m_redcap_readUI <- function(id, title = TRUE, url = NULL) {
shinyWidgets::alert( shinyWidgets::alert(
id = ns("retrieved-result"), id = ns("retrieved-result"),
status = "info", 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 dismissible = TRUE
) )
@ -126,11 +139,7 @@ m_redcap_readUI <- function(id, title = TRUE, url = NULL) {
title = title, title = title,
server_ui, server_ui,
# shiny::uiOutput(ns("params_ui")), # shiny::uiOutput(ns("params_ui")),
shiny::conditionalPanel( shiny::conditionalPanel(condition = "output.connect_success == true", params_ui, ns = ns),
condition = "output.connect_success == true",
params_ui,
ns = ns
),
shiny::br() shiny::br()
) )
} }
@ -162,7 +171,11 @@ m_redcap_readServer <- function(id) {
shiny::req(input$api) shiny::req(input$api)
shiny::req(input$uri) shiny::req(input$uri)
if (!is.null(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 { } else {
uri <- input$uri uri <- input$uri
} }
@ -176,32 +189,26 @@ m_redcap_readServer <- function(id) {
}) })
tryCatch( tryCatch({
{ shiny::observeEvent(list(input$data_connect), {
shiny::observeEvent(
list(
input$data_connect
),
{
shiny::req(input$api) shiny::req(input$api)
shiny::req(data_rv$uri) shiny::req(data_rv$uri)
parameters <- list( parameters <- list(redcap_uri = data_rv$uri, token = input$api)
redcap_uri = data_rv$uri,
token = input$api
)
# browser() # browser()
shiny::withProgress( shiny::withProgress({
{ imported <- try(rlang::exec(REDCapR::redcap_metadata_read, !!!parameters),
imported <- try(rlang::exec(REDCapR::redcap_metadata_read, !!!parameters), silent = TRUE) silent = TRUE)
}, }, message = paste("Connecting to", data_rv$uri))
message = paste("Connecting to", data_rv$uri)
)
## TODO: Simplify error messages ## TODO: Simplify error messages
if (inherits(imported, "try-error") || NROW(imported) < 1 || ifelse(is.list(imported), !isTRUE(imported$success), FALSE)) { if (inherits(imported, "try-error") ||
if (ifelse(is.list(imported), !isTRUE(imported$success), FALSE)) { NROW(imported) < 1 ||
ifelse(is.list(imported), !isTRUE(imported$success), FALSE)) {
if (ifelse(is.list(imported),
!isTRUE(imported$success),
FALSE)) {
mssg <- imported$raw_text mssg <- imported$raw_text
} else { } else {
mssg <- attr(imported, "condition")$message mssg <- attr(imported, "condition")$message
@ -213,10 +220,7 @@ m_redcap_readServer <- function(id) {
} else if (isTRUE(imported$success)) { } else if (isTRUE(imported$success)) {
data_rv$dd_status <- "success" data_rv$dd_status <- "success"
data_rv$info <- REDCapR::redcap_project_info_read( data_rv$info <- REDCapR::redcap_project_info_read(redcap_uri = data_rv$uri, token = input$api)$data
redcap_uri = data_rv$uri,
token = input$api
)$data
datamods:::insert_alert( datamods:::insert_alert(
selector = ns("connect"), selector = ns("connect"),
@ -225,8 +229,15 @@ m_redcap_readServer <- function(id) {
see_data_text = i18n$t("Click to see data dictionary"), see_data_text = i18n$t("Click to see data dictionary"),
dataIdName = "see_dd", dataIdName = "see_dd",
extra = tags$p( extra = tags$p(
tags$b(phosphoricons::ph("check", weight = "bold"), i18n$t("Connected to server!")), tags$b(
glue::glue(i18n$t("The {data_rv$info$project_title} project is loaded.")) 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 btn_show_data = TRUE
) )
@ -234,17 +245,12 @@ m_redcap_readServer <- function(id) {
data_rv$dd_list <- imported data_rv$dd_list <- imported
} }
}, }, ignoreInit = TRUE)
ignoreInit = TRUE }, warning = function(warn) {
)
},
warning = function(warn) {
showNotification(paste0(warn), type = "warning") showNotification(paste0(warn), type = "warning")
}, }, error = function(err) {
error = function(err) {
showNotification(paste0(err), type = "err") showNotification(paste0(err), type = "err")
} })
)
output$connect_success <- shiny::reactive(identical(data_rv$dd_status, "success")) output$connect_success <- shiny::reactive(identical(data_rv$dd_status, "success"))
shiny::outputOptions(output, "connect_success", suspendWhenHidden = FALSE) shiny::outputOptions(output, "connect_success", suspendWhenHidden = FALSE)
@ -275,10 +281,7 @@ m_redcap_readServer <- function(id) {
shiny::req(input$api) shiny::req(input$api)
shiny::req(data_rv$uri) shiny::req(data_rv$uri)
REDCapR::redcap_event_read( REDCapR::redcap_event_read(redcap_uri = data_rv$uri, token = input$api)$data
redcap_uri = data_rv$uri,
token = input$api
)$data
}) })
output$fields <- shiny::renderUI({ output$fields <- shiny::renderUI({
@ -321,14 +324,10 @@ m_redcap_readServer <- function(id) {
shiny::req(input$data_type) shiny::req(input$data_type)
## Get repeated field ## Get repeated field
data_rv$rep_fields <- data_rv$dd_list$data$field_name[ 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$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( vectorSelectInput(
inputId = ns("fill"), inputId = ns("fill"),
label = i18n$t("Fill missing values?"), label = i18n$t("Fill missing values?"),
@ -370,7 +369,6 @@ m_redcap_readServer <- function(id) {
# browser() # browser()
record_id <- purrr::pluck(data_rv$dd_list, "data")[[1]][1] record_id <- purrr::pluck(data_rv$dd_list, "data")[[1]][1]
parameters <- list( parameters <- list(
uri = data_rv$uri, uri = data_rv$uri,
token = input$api, token = input$api,
@ -386,13 +384,19 @@ m_redcap_readServer <- function(id) {
) )
shiny::withProgress(message = "Downloading REDCap data. Hold on for a moment..", { 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( parameters_code <- parameters[c("uri",
"easy_redcap", "fields",
"events",
"raw_or_label",
"filter_logic")]
code <- rlang::call2("easy_redcap",
!!!utils::modifyList( !!!utils::modifyList(
parameters_code, parameters_code,
list( list(
@ -404,8 +408,7 @@ m_redcap_readServer <- function(id) {
project.name = simple_snake(data_rv$info$project_title) project.name = simple_snake(data_rv$info$project_title)
) )
), ),
.ns = "REDCapCAST" .ns = "REDCapCAST")
)
if (inherits(imported, "try-error") || NROW(imported) < 1) { if (inherits(imported, "try-error") || NROW(imported) < 1) {
data_rv$data_status <- "error" data_rv$data_status <- "error"
@ -419,7 +422,6 @@ m_redcap_readServer <- function(id) {
## "wide"/"long" without re-importing data ## "wide"/"long" without re-importing data
if (parameters$split_form == "all") { if (parameters$split_form == "all") {
# browser()
out <- imported |> out <- imported |>
# redcap_wider() # redcap_wider()
REDCapCAST::redcap_wider() REDCapCAST::redcap_wider()
@ -442,35 +444,46 @@ 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) | 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])) { if (!any(in_data_check[-1])) {
data_rv$data_status <- "warning" 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)) { if (!all(in_data_check)) {
data_rv$data_status <- "warning" 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 data_rv$code <- code
## Level labels nare lost at this point...
data_rv$data <- out |> data_rv$data <- out |>
dplyr::select(-dplyr::ends_with("_complete")) |> dplyr::select(-dplyr::ends_with("_complete")) |>
# dplyr::select(-dplyr::any_of(record_id)) |> # dplyr::select(-dplyr::any_of(record_id)) |>
REDCapCAST::suffix2label() REDCapCAST::suffix2label()
} }
}) })
shiny::observeEvent( shiny::observeEvent(data_rv$data_status, {
data_rv$data_status,
{
# browser() # browser()
if (identical(data_rv$data_status, "error")) { if (identical(data_rv$data_status, "error")) {
datamods:::insert_error(mssg = data_rv$data_message, selector = ns("retrieved")) datamods:::insert_error(mssg = data_rv$data_message,
selector = ns("retrieved"))
} else if (identical(data_rv$data_status, "success")) { } else if (identical(data_rv$data_status, "success")) {
datamods:::insert_alert( datamods:::insert_alert(
selector = ns("retrieved"), selector = ns("retrieved"),
@ -482,9 +495,10 @@ m_redcap_readServer <- function(id) {
include_data_alert( include_data_alert(
see_data_text = i18n$t("Click to see the imported data"), see_data_text = i18n$t("Click to see the imported data"),
dataIdName = "see_data", dataIdName = "see_data",
extra = tags$p( extra = tags$p(tags$b(
tags$b(phosphoricons::ph("check", weight = "bold"), data_rv$data_message) phosphoricons::ph("check", weight = "bold"),
), data_rv$data_message
)),
btn_show_data = TRUE btn_show_data = TRUE
) )
) )
@ -493,27 +507,28 @@ m_redcap_readServer <- function(id) {
selector = ns("retrieved"), selector = ns("retrieved"),
status = data_rv$data_status, status = data_rv$data_status,
tags$p( tags$p(
tags$b(phosphoricons::ph("warning", weight = "bold"), "Warning!"), tags$b(
phosphoricons::ph("warning", weight = "bold"),
"Warning!"
),
data_rv$data_message data_rv$data_message
) )
) )
} }
} })
)
return(list( return(
list(
status = shiny::reactive(data_rv$data_status), status = shiny::reactive(data_rv$data_status),
name = shiny::reactive(data_rv$info$project_title), name = shiny::reactive(data_rv$info$project_title),
info = shiny::reactive(data_rv$info), info = shiny::reactive(data_rv$info),
code = shiny::reactive(data_rv$code), code = shiny::reactive(data_rv$code),
data = shiny::reactive(data_rv$data) data = shiny::reactive(data_rv$data)
)) )
)
} }
shiny::moduleServer( shiny::moduleServer(id = id, module = module)
id = id,
module = module
)
} }
#' @importFrom htmltools tagList tags #' @importFrom htmltools tagList tags
@ -524,14 +539,12 @@ include_data_alert <- function(dataIdName = "see_data",
extra = NULL, extra = NULL,
session = shiny::getDefaultReactiveDomain()) { session = shiny::getDefaultReactiveDomain()) {
if (isTRUE(btn_show_data)) { if (isTRUE(btn_show_data)) {
success_message <- tagList( success_message <- tagList(extra,
extra,
tags$br(), tags$br(),
shiny::actionLink( shiny::actionLink(
inputId = session$ns(dataIdName), inputId = session$ns(dataIdName),
label = tagList(phosphoricons::ph("book-open-text"), see_data_text) label = tagList(phosphoricons::ph("book-open-text"), see_data_text)
) ))
)
} }
return(success_message) return(success_message)
} }
@ -583,20 +596,18 @@ is_valid_redcap_url <- function(url) {
#' @examples #' @examples
#' token <- paste(sample(c(1:9, LETTERS[1:6]), 32, TRUE), collapse = "") #' token <- paste(sample(c(1:9, LETTERS[1:6]), 32, TRUE), collapse = "")
#' is_valid_token(token) #' 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) checkmate::assert_character(token, any.missing = TRUE, len = 1)
if (!is.null(pattern_env)) { if (!is.null(pattern_env)) {
checkmate::assert_character(pattern_env, checkmate::assert_character(pattern_env, any.missing = FALSE, len = 1)
any.missing = FALSE,
len = 1
)
pattern <- pattern_env pattern <- pattern_env
} else { } else {
pattern <- glue::glue("^([0-9A-Fa-f]{<nchar>})(?:\\n)?$", pattern <- glue::glue("^([0-9A-Fa-f]{<nchar>})(?:\\n)?$",
.open = "<", .open = "<",
.close = ">" .close = ">")
)
} }
if (is.na(token)) { if (is.na(token)) {
@ -636,7 +647,12 @@ repeated_instruments <- function(uri, token) {
#' @export #' @export
#' #'
drop_empty_event <- function(data, event = "redcap_event_name") { 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]]) |> filt <- split(data, data[[event]]) |>
lapply(\(.x) { lapply(\(.x) {
@ -667,16 +683,10 @@ redcap_demo_app <- function() {
server <- function(input, output, session) { server <- function(input, output, session) {
data_val <- m_redcap_readServer(id = "data") data_val <- m_redcap_readServer(id = "data")
output$data <- DT::renderDataTable( output$data <- DT::renderDataTable({
{
shiny::req(data_val$data) shiny::req(data_val$data)
data_val$data() data_val$data()
}, }, options = list(scrollX = TRUE, pageLength = 5), )
options = list(
scrollX = TRUE,
pageLength = 5
),
)
output$code <- shiny::renderPrint({ output$code <- shiny::renderPrint({
shiny::req(data_val$code) shiny::req(data_val$code)
data_val$code() data_val$code()