andreas/FreesearchR
1
0
Fork 0
mirror of https://github.com/agdamsbo/FreesearchR.git synced 2025-09-12 18:09:39 +02:00
Code Issues Projects Releases Packages Wiki Activity Actions

more improvements to the REDCap module

Browse source
This commit is contained in:
Andreas Gammelgaard Damsbo 2025-02-27 13:34:45 +01:00
parent 5dd872f254
commit 984f383171
No known key found for this signature in database
5 changed files with 358 additions and 172 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

2
R/app_version.R
View file

@ -1 +1 @@
app_version <- function()'250226_2108' app_version <- function()'250227_1333'

216
R/redcap_read_shiny_module.R
View file

@ -12,26 +12,38 @@ m_redcap_readUI <- function(id, include_title = TRUE) {
server_ui <- shiny::tagList( server_ui <- shiny::tagList(
# width = 6, # width = 6,
shiny::tags$h4("REDCap server information"), shiny::tags$h4("REDCap server"),
shiny::textInput( shiny::textInput(
inputId = ns("uri"), inputId = ns("uri"),
label = "URI/Address", label = "Web address",
value = "https://redcap.your.institution/api/" value = "https://redcap.your.institution/"
), ),
shiny::helpText("Format should be either 'https://redcap.your.institution/' or 'https://your.institution/redcap/'"),
shiny::textInput( shiny::textInput(
inputId = ns("api"), inputId = ns("api"),
label = "API token", label = "API token",
value = "" value = ""
), ),
shiny::helpText("The token is a string of 32 numbers and letters."),
shiny::actionButton(
inputId = ns("data_connect"),
label = "Connect",
icon = shiny::icon("link", lib = "glyphicon"),
# width = NULL,
disabled = TRUE
),
shiny::br(),
shiny::br(),
tags$div( tags$div(
id = ns("connect-placeholder"), id = ns("connect-placeholder"),
shinyWidgets::alert( shinyWidgets::alert(
id = ns("connect-result"), id = ns("connect-result"),
status = "info", status = "info",
tags$p(phosphoricons::ph("info", weight = "bold"),"Please fill in server address (URI) and API token.") tags$p(phosphoricons::ph("info", weight = "bold"), "Please fill in server address (URI) and API token, then press 'Connect'.")
), ),
dismissible = TRUE dismissible = TRUE
) ),
shiny::br()
) )
@ -74,27 +86,35 @@ m_redcap_readUI <- function(id, include_title = TRUE) {
width = 12, width = 12,
# shiny::actionButton(inputId = ns("import"), label = "Import"), # shiny::actionButton(inputId = ns("import"), label = "Import"),
## TODO: Use busy indicator like on download to have button activate/deactivate ## TODO: Use busy indicator like on download to have button activate/deactivate
bslib::input_task_button( shiny::actionButton(
id = ns("data_import"), inputId = ns("data_import"),
label = "Import", label = "Import",
icon = shiny::icon("download", lib = "glyphicon"), icon = shiny::icon("download", lib = "glyphicon"),
label_busy = "Just a minute...", width = "100%",
icon_busy = fontawesome::fa_i("arrows-rotate", disabled = TRUE
class = "fa-spin",
"aria-hidden" = "true"
),
type = "primary",
auto_reset = TRUE#,state="busy"
), ),
# bslib::input_task_button(
# id = ns("data_import"),
# label = "Import",
# icon = shiny::icon("download", lib = "glyphicon"),
# label_busy = "Just a minute...",
# icon_busy = fontawesome::fa_i("arrows-rotate",
# class = "fa-spin",
# "aria-hidden" = "true"
# ),
# type = "primary",
# auto_reset = TRUE#,state="busy"
# ),
shiny::br(), shiny::br(),
shiny::br(), shiny::br(),
shiny::helpText("Press 'Import' after having specified API token and URI to export data from the REDCap server. A preview will show below the DataDictionary."), shiny::helpText("Press 'Import' to get data from the REDCap server. Check the preview below before proceeding."),
shiny::br(), shiny::br(),
shiny::br() shiny::br()
) )
) )
} }
#' @rdname redcap_read_shiny_module #' @rdname redcap_read_shiny_module
#' #'
#' @return shiny server module #' @return shiny server module
@ -107,25 +127,38 @@ m_redcap_readServer <- function(id) {
data_rv <- shiny::reactiveValues( data_rv <- shiny::reactiveValues(
dd_status = NULL, dd_status = NULL,
data_status = NULL, data_status = NULL,
uri = NULL,
project_name = NULL,
info = NULL, info = NULL,
arms = NULL, arms = NULL,
dd_list = NULL, dd_list = NULL,
data = NULL data = NULL
) )
# tryCatch( shiny::observeEvent(list(input$api, input$uri), {
# { uri <- paste0(ifelse(endsWith(input$uri, "/"), input$uri, paste0(input$uri, "/")), "api/")
if (is_valid_redcap_url(uri) & is_valid_token(input$api)) {
data_rv$uri <- uri
shiny::updateActionButton(inputId = "data_connect", disabled = FALSE)
} else {
shiny::updateActionButton(inputId = "data_connect", disabled = TRUE)
}
})
tryCatch(
{
shiny::observeEvent( shiny::observeEvent(
list( list(
input$api, input$data_connect
input$uri
), ),
{ {
shiny::req(input$api) shiny::req(input$api)
shiny::req(input$uri) shiny::req(data_rv$uri)
parameters <- list( parameters <- list(
redcap_uri = input$uri, redcap_uri = data_rv$uri,
token = input$api token = input$api
) )
@ -134,42 +167,46 @@ m_redcap_readServer <- function(id) {
## 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") || NROW(imported) < 1 || ifelse(is.list(imported), !isTRUE(imported$success), FALSE)) {
if (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
} }
datamods:::insert_error(mssg = mssg,selector = "connect") datamods:::insert_error(mssg = mssg, selector = "connect")
data_rv$dd_status <- "error" data_rv$dd_status <- "error"
data_rv$dd_list <- NULL data_rv$dd_list <- NULL
} else if (isTRUE(imported$success)) { } else if (isTRUE(imported$success)) {
data_rv$dd_status <- "success"
data_rv$project_name <- REDCapR::redcap_project_info_read(
redcap_uri = data_rv$uri,
token = input$api
)$data$project_title
datamods:::insert_alert( datamods:::insert_alert(
selector = ns("connect"), selector = ns("connect"),
status = "success", status = "success",
make_success_alert( make_success_alert(
dataIdName = "see_data", dataIdName = "see_data",
extra = tags$b(phosphoricons::ph("check", weight = "bold"),"Connected to server! Project data loaded."), extra = tags$p(tags$b(phosphoricons::ph("check", weight = "bold"), "Connected to server!"), tags$p(paste0(data_rv$project_name, " loaded."))),
btn_show_data = TRUE btn_show_data = TRUE
) )
) )
data_rv$dd_status <- "success"
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")
# } }
# ) )
shiny::observeEvent(input$see_data, { shiny::observeEvent(input$see_data, {
datamods::show_data( datamods::show_data(
@ -178,15 +215,15 @@ m_redcap_readServer <- function(id) {
type = "modal", type = "modal",
show_classes = FALSE, show_classes = FALSE,
tags$b("Preview:") tags$b("Preview:")
) )
}) })
arms <- shiny::reactive({ arms <- shiny::reactive({
shiny::req(input$api) shiny::req(input$api)
shiny::req(input$uri) shiny::req(data_rv$uri)
REDCapR::redcap_event_read( REDCapR::redcap_event_read(
redcap_uri = input$uri, redcap_uri = data_rv$uri,
token = input$api token = input$api
)$data )$data
}) })
@ -195,31 +232,26 @@ m_redcap_readServer <- function(id) {
shiny::req(data_rv$dd_list) shiny::req(data_rv$dd_list)
shinyWidgets::virtualSelectInput( shinyWidgets::virtualSelectInput(
inputId = ns("fields"), inputId = ns("fields"),
label = "Select fields/variables to import:", label = "Select variables to import:",
choices = purrr::pluck(data_rv$dd_list, "data") |> choices = purrr::pluck(data_rv$dd_list, "data") |>
dplyr::select(field_name, form_name) |> dplyr::select(field_name, form_name) |>
(\(.x){ (\(.x){
split(.x$field_name, .x$form_name) split(.x$field_name, .x$form_name)
})() })(),
, updateOn = "change",
updateOn = "close",
multiple = TRUE, multiple = TRUE,
search = TRUE, search = TRUE,
showValueAsTags = TRUE showValueAsTags = TRUE
) )
}) })
## TODO: Get activate/inactivate action button to work shiny::observeEvent(input$fields, {
# shiny::observeEvent(input$fields, if (is.null(input$fields) | length(input$fields) == 0) {
# { shiny::updateActionButton(inputId = "data_import", disabled = TRUE)
# if (is.null(input$fields) | length(input$fields)==1){ } else {
# bslib::update_task_button(id= "data_import", state = "busy") shiny::updateActionButton(inputId = "data_import", disabled = FALSE)
# # datamods:::toggle_widget(inputId = "data_import", enable = FALSE) }
# } else { })
# bslib::update_task_button(id= "data_import", state = "ready")
# # datamods:::toggle_widget(inputId = "data_import", enable = TRUE)
# }
# })
output$arms <- shiny::renderUI({ output$arms <- shiny::renderUI({
shiny::selectizeInput( shiny::selectizeInput(
@ -231,24 +263,12 @@ m_redcap_readServer <- function(id) {
) )
}) })
## Merge project name in success meassage
## Generate Codebook link
name <- shiny::reactive({
if (data_rv$dd_status=="success"){
# browser()
REDCapR::redcap_project_info_read(
redcap_uri = input$uri,
token = input$api
)$data$project_title}
})
shiny::observeEvent(input$data_import, { shiny::observeEvent(input$data_import, {
shiny::req(input$fields) shiny::req(input$fields)
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 = input$uri, uri = data_rv$uri,
token = input$api, token = input$api,
fields = unique(c(record_id, input$fields)), fields = unique(c(record_id, input$fields)),
events = input$arms, events = input$arms,
@ -256,12 +276,13 @@ m_redcap_readServer <- function(id) {
filter_logic = input$filter filter_logic = input$filter
) )
imported <- try(rlang::exec(REDCapCAST::read_redcap_tables, !!!parameters), silent = TRUE) shiny::withProgress(message = "Downloading REDCap data. Hold on for a moment..", {
imported <- try(rlang::exec(REDCapCAST::read_redcap_tables, !!!parameters), silent = TRUE)
})
code <- rlang::call2(REDCapCAST::read_redcap_tables, !!!parameters) code <- rlang::call2(REDCapCAST::read_redcap_tables, !!!parameters)
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"
data_rv$data_list <- NULL data_rv$data_list <- NULL
} else { } else {
@ -287,7 +308,7 @@ m_redcap_readServer <- function(id) {
#' @importFrom shiny icon getDefaultReactiveDomain #' @importFrom shiny icon getDefaultReactiveDomain
make_success_alert <- function(dataIdName = "see_data", make_success_alert <- function(dataIdName = "see_data",
btn_show_data, btn_show_data,
see_data_text="Click to see data", see_data_text = "Click to see data",
extra = NULL, extra = NULL,
session = shiny::getDefaultReactiveDomain()) { session = shiny::getDefaultReactiveDomain()) {
if (isTRUE(btn_show_data)) { if (isTRUE(btn_show_data)) {
@ -318,6 +339,67 @@ make_success_alert <- function(dataIdName = "see_data",
# ) # )
#' Title
#'
#' @param url
#'
#' @returns
#' @export
#'
#' @examples
#' url <- c(
#' "www.example.com",
#' "http://example.com",
#' "https://redcap.your.inst/api/"
#' )
#' is_valid_redcap_url(url)
is_valid_redcap_url <- function(url) {
pattern <- "https://[^ /$.?#].[^\\s]*/api/$"
stringr::str_detect(url, pattern)
}
#' Validate REDCap token
#'
#' @param token token
#' @param pattern_env pattern
#'
#' @returns
#' @export
#'
#' @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) {
checkmate::assert_character(token, any.missing = TRUE, len = 1)
if (!is.null(pattern_env)) {
checkmate::assert_character(pattern_env,
any.missing = FALSE,
len = 1
)
pattern <- pattern_env
} else {
pattern <- glue::glue("^([0-9A-Fa-f]{<nchar>})(?:\\n)?$",
.open = "<",
.close = ">"
)
}
if (is.na(token)) {
out <- FALSE
} else if (is.null(token)) {
out <- FALSE
} else if (nchar(token) == 0L) {
out <- FALSE
} else if (!grepl(pattern, token, perl = TRUE)) {
out <- FALSE
} else {
out <- TRUE
}
out
}
#' Test app for the redcap_read_shiny_module #' Test app for the redcap_read_shiny_module
#' #'
#' @rdname redcap_read_shiny_module #' @rdname redcap_read_shiny_module

265
inst/apps/freesearcheR/app.R
View file

@ -10,7 +10,7 @@
#### Current file: R//app_version.R #### Current file: R//app_version.R
######## ########
app_version <- function()'250226_2108' app_version <- function()'250227_1333'
######## ########
@ -2356,26 +2356,38 @@ m_redcap_readUI <- function(id, include_title = TRUE) {
server_ui <- shiny::tagList( server_ui <- shiny::tagList(
# width = 6, # width = 6,
shiny::tags$h4("REDCap server information"), shiny::tags$h4("REDCap server"),
shiny::textInput( shiny::textInput(
inputId = ns("uri"), inputId = ns("uri"),
label = "URI/Address", label = "Web address",
value = "https://redcap.your.institution/api/" value = "https://redcap.your.institution/"
), ),
shiny::helpText("Format should be either 'https://redcap.your.institution/' or 'https://your.institution/redcap/'"),
shiny::textInput( shiny::textInput(
inputId = ns("api"), inputId = ns("api"),
label = "API token", label = "API token",
value = "" value = ""
), ),
shiny::helpText("The token is a string of 32 numbers and letters."),
shiny::actionButton(
inputId = ns("data_connect"),
label = "Connect",
icon = shiny::icon("link", lib = "glyphicon"),
# width = NULL,
disabled = TRUE
),
shiny::br(),
shiny::br(),
tags$div( tags$div(
id = ns("connect-placeholder"), id = ns("connect-placeholder"),
shinyWidgets::alert( shinyWidgets::alert(
id = ns("connect-result"), id = ns("connect-result"),
status = "info", status = "info",
tags$p(phosphoricons::ph("info", weight = "bold"),"Please fill in server address (URI) and API token.") tags$p(phosphoricons::ph("info", weight = "bold"), "Please fill in server address (URI) and API token, then press 'Connect'.")
), ),
dismissible = TRUE dismissible = TRUE
) ),
shiny::br()
) )
@ -2418,27 +2430,35 @@ m_redcap_readUI <- function(id, include_title = TRUE) {
width = 12, width = 12,
# shiny::actionButton(inputId = ns("import"), label = "Import"), # shiny::actionButton(inputId = ns("import"), label = "Import"),
## TODO: Use busy indicator like on download to have button activate/deactivate ## TODO: Use busy indicator like on download to have button activate/deactivate
bslib::input_task_button( shiny::actionButton(
id = ns("data_import"), inputId = ns("data_import"),
label = "Import", label = "Import",
icon = shiny::icon("download", lib = "glyphicon"), icon = shiny::icon("download", lib = "glyphicon"),
label_busy = "Just a minute...", width = "100%",
icon_busy = fontawesome::fa_i("arrows-rotate", disabled = TRUE
class = "fa-spin",
"aria-hidden" = "true"
),
type = "primary",
auto_reset = TRUE#,state="busy"
), ),
# bslib::input_task_button(
# id = ns("data_import"),
# label = "Import",
# icon = shiny::icon("download", lib = "glyphicon"),
# label_busy = "Just a minute...",
# icon_busy = fontawesome::fa_i("arrows-rotate",
# class = "fa-spin",
# "aria-hidden" = "true"
# ),
# type = "primary",
# auto_reset = TRUE#,state="busy"
# ),
shiny::br(), shiny::br(),
shiny::br(), shiny::br(),
shiny::helpText("Press 'Import' after having specified API token and URI to export data from the REDCap server. A preview will show below the DataDictionary."), shiny::helpText("Press 'Import' to get data from the REDCap server. Check the preview below before proceeding."),
shiny::br(), shiny::br(),
shiny::br() shiny::br()
) )
) )
} }
#' @rdname redcap_read_shiny_module #' @rdname redcap_read_shiny_module
#' #'
#' @return shiny server module #' @return shiny server module
@ -2451,25 +2471,38 @@ m_redcap_readServer <- function(id) {
data_rv <- shiny::reactiveValues( data_rv <- shiny::reactiveValues(
dd_status = NULL, dd_status = NULL,
data_status = NULL, data_status = NULL,
uri = NULL,
project_name = NULL,
info = NULL, info = NULL,
arms = NULL, arms = NULL,
dd_list = NULL, dd_list = NULL,
data = NULL data = NULL
) )
# tryCatch( shiny::observeEvent(list(input$api, input$uri), {
# { uri <- paste0(ifelse(endsWith(input$uri, "/"), input$uri, paste0(input$uri, "/")), "api/")
if (is_valid_redcap_url(uri) & is_valid_token(input$api)) {
data_rv$uri <- uri
shiny::updateActionButton(inputId = "data_connect", disabled = FALSE)
} else {
shiny::updateActionButton(inputId = "data_connect", disabled = TRUE)
}
})
tryCatch(
{
shiny::observeEvent( shiny::observeEvent(
list( list(
input$api, input$data_connect
input$uri
), ),
{ {
shiny::req(input$api) shiny::req(input$api)
shiny::req(input$uri) shiny::req(data_rv$uri)
parameters <- list( parameters <- list(
redcap_uri = input$uri, redcap_uri = data_rv$uri,
token = input$api token = input$api
) )
@ -2478,42 +2511,46 @@ m_redcap_readServer <- function(id) {
## 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") || NROW(imported) < 1 || ifelse(is.list(imported), !isTRUE(imported$success), FALSE)) {
if (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
} }
datamods:::insert_error(mssg = mssg,selector = "connect") datamods:::insert_error(mssg = mssg, selector = "connect")
data_rv$dd_status <- "error" data_rv$dd_status <- "error"
data_rv$dd_list <- NULL data_rv$dd_list <- NULL
} else if (isTRUE(imported$success)) { } else if (isTRUE(imported$success)) {
data_rv$dd_status <- "success"
data_rv$project_name <- REDCapR::redcap_project_info_read(
redcap_uri = data_rv$uri,
token = input$api
)$data$project_title
datamods:::insert_alert( datamods:::insert_alert(
selector = ns("connect"), selector = ns("connect"),
status = "success", status = "success",
make_success_alert( make_success_alert(
dataIdName = "see_data", dataIdName = "see_data",
extra = tags$b(phosphoricons::ph("check", weight = "bold"),"Connected to server! Project data loaded."), extra = tags$p(tags$b(phosphoricons::ph("check", weight = "bold"), "Connected to server!"), tags$p(paste0(data_rv$project_name, " loaded."))),
btn_show_data = TRUE btn_show_data = TRUE
) )
) )
data_rv$dd_status <- "success"
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")
# } }
# ) )
shiny::observeEvent(input$see_data, { shiny::observeEvent(input$see_data, {
datamods::show_data( datamods::show_data(
@ -2522,15 +2559,15 @@ m_redcap_readServer <- function(id) {
type = "modal", type = "modal",
show_classes = FALSE, show_classes = FALSE,
tags$b("Preview:") tags$b("Preview:")
) )
}) })
arms <- shiny::reactive({ arms <- shiny::reactive({
shiny::req(input$api) shiny::req(input$api)
shiny::req(input$uri) shiny::req(data_rv$uri)
REDCapR::redcap_event_read( REDCapR::redcap_event_read(
redcap_uri = input$uri, redcap_uri = data_rv$uri,
token = input$api token = input$api
)$data )$data
}) })
@ -2539,31 +2576,26 @@ m_redcap_readServer <- function(id) {
shiny::req(data_rv$dd_list) shiny::req(data_rv$dd_list)
shinyWidgets::virtualSelectInput( shinyWidgets::virtualSelectInput(
inputId = ns("fields"), inputId = ns("fields"),
label = "Select fields/variables to import:", label = "Select variables to import:",
choices = purrr::pluck(data_rv$dd_list, "data") |> choices = purrr::pluck(data_rv$dd_list, "data") |>
dplyr::select(field_name, form_name) |> dplyr::select(field_name, form_name) |>
(\(.x){ (\(.x){
split(.x$field_name, .x$form_name) split(.x$field_name, .x$form_name)
})() })(),
, updateOn = "change",
updateOn = "close",
multiple = TRUE, multiple = TRUE,
search = TRUE, search = TRUE,
showValueAsTags = TRUE showValueAsTags = TRUE
) )
}) })
## TODO: Get activate/inactivate action button to work shiny::observeEvent(input$fields, {
# shiny::observeEvent(input$fields, if (is.null(input$fields) | length(input$fields) == 0) {
# { shiny::updateActionButton(inputId = "data_import", disabled = TRUE)
# if (is.null(input$fields) | length(input$fields)==1){ } else {
# bslib::update_task_button(id= "data_import", state = "busy") shiny::updateActionButton(inputId = "data_import", disabled = FALSE)
# # datamods:::toggle_widget(inputId = "data_import", enable = FALSE) }
# } else { })
# bslib::update_task_button(id= "data_import", state = "ready")
# # datamods:::toggle_widget(inputId = "data_import", enable = TRUE)
# }
# })
output$arms <- shiny::renderUI({ output$arms <- shiny::renderUI({
shiny::selectizeInput( shiny::selectizeInput(
@ -2575,24 +2607,12 @@ m_redcap_readServer <- function(id) {
) )
}) })
## Merge project name in success meassage
## Generate Codebook link
name <- shiny::reactive({
if (data_rv$dd_status=="success"){
# browser()
REDCapR::redcap_project_info_read(
redcap_uri = input$uri,
token = input$api
)$data$project_title}
})
shiny::observeEvent(input$data_import, { shiny::observeEvent(input$data_import, {
shiny::req(input$fields) shiny::req(input$fields)
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 = input$uri, uri = data_rv$uri,
token = input$api, token = input$api,
fields = unique(c(record_id, input$fields)), fields = unique(c(record_id, input$fields)),
events = input$arms, events = input$arms,
@ -2600,12 +2620,13 @@ m_redcap_readServer <- function(id) {
filter_logic = input$filter filter_logic = input$filter
) )
imported <- try(rlang::exec(REDCapCAST::read_redcap_tables, !!!parameters), silent = TRUE) shiny::withProgress(message = "Downloading REDCap data. Hold on for a moment..", {
imported <- try(rlang::exec(REDCapCAST::read_redcap_tables, !!!parameters), silent = TRUE)
})
code <- rlang::call2(REDCapCAST::read_redcap_tables, !!!parameters) code <- rlang::call2(REDCapCAST::read_redcap_tables, !!!parameters)
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"
data_rv$data_list <- NULL data_rv$data_list <- NULL
} else { } else {
@ -2631,7 +2652,7 @@ m_redcap_readServer <- function(id) {
#' @importFrom shiny icon getDefaultReactiveDomain #' @importFrom shiny icon getDefaultReactiveDomain
make_success_alert <- function(dataIdName = "see_data", make_success_alert <- function(dataIdName = "see_data",
btn_show_data, btn_show_data,
see_data_text="Click to see data", see_data_text = "Click to see data",
extra = NULL, extra = NULL,
session = shiny::getDefaultReactiveDomain()) { session = shiny::getDefaultReactiveDomain()) {
if (isTRUE(btn_show_data)) { if (isTRUE(btn_show_data)) {
@ -2662,6 +2683,67 @@ make_success_alert <- function(dataIdName = "see_data",
# ) # )
#' Title
#'
#' @param url
#'
#' @returns
#' @export
#'
#' @examples
#' url <- c(
#' "www.example.com",
#' "http://example.com",
#' "https://redcap.your.inst/api/"
#' )
#' is_valid_redcap_url(url)
is_valid_redcap_url <- function(url) {
pattern <- "https://[^ /$.?#].[^\\s]*/api/$"
stringr::str_detect(url, pattern)
}
#' Validate REDCap token
#'
#' @param token token
#' @param pattern_env pattern
#'
#' @returns
#' @export
#'
#' @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) {
checkmate::assert_character(token, any.missing = TRUE, len = 1)
if (!is.null(pattern_env)) {
checkmate::assert_character(pattern_env,
any.missing = FALSE,
len = 1
)
pattern <- pattern_env
} else {
pattern <- glue::glue("^([0-9A-Fa-f]{<nchar>})(?:\\n)?$",
.open = "<",
.close = ">"
)
}
if (is.na(token)) {
out <- FALSE
} else if (is.null(token)) {
out <- FALSE
} else if (nchar(token) == 0L) {
out <- FALSE
} else if (!grepl(pattern, token, perl = TRUE)) {
out <- FALSE
} else {
out <- TRUE
}
out
}
#' Test app for the redcap_read_shiny_module #' Test app for the redcap_read_shiny_module
#' #'
#' @rdname redcap_read_shiny_module #' @rdname redcap_read_shiny_module
@ -4968,26 +5050,35 @@ ui_elements <- list(
shiny::br(), shiny::br(),
shiny::br(), shiny::br(),
shiny::h5("Exclude in-complete variables"), shiny::h5("Exclude in-complete variables"),
shiny::p("Before going further, you can exclude variables with a low degree of completeness."), shiny::fluidRow(
shiny::br(), shiny::column(width=6,
shinyWidgets::noUiSliderInput( shiny::br(),
inputId = "complete_cutoff", shiny::br(),
label = "Choose completeness threshold (%)", shiny::p("Filter incomplete variables, by setting a completeness threshold:"),
min = 0, shiny::br()
max = 100, ),
step = 10, shiny::column(width=6,
value = 70, shinyWidgets::noUiSliderInput(
format = shinyWidgets::wNumbFormat(decimals = 0), inputId = "complete_cutoff",
color = datamods:::get_primary_color() label = NULL,
min = 0,
max = 100,
step = 10,
value = 70,
format = shinyWidgets::wNumbFormat(decimals = 0),
color = datamods:::get_primary_color()
),
shiny::helpText("Include variables with completeness above the specified percentage.")
)
), ),
shiny::helpText("Only include variables with completeness above a specified percentage."),
shiny::br(), shiny::br(),
shiny::br(), shiny::br(),
shiny::actionButton( shiny::actionButton(
inputId = "act_start", inputId = "act_start",
label = "Start", label = "Start",
width = "100%", width = "100%",
icon = shiny::icon("play") icon = shiny::icon("play"),
disabled = TRUE
), ),
shiny::helpText('After importing, hit "Start" or navigate to the desired tab.'), shiny::helpText('After importing, hit "Start" or navigate to the desired tab.'),
shiny::br(), shiny::br(),
@ -5704,6 +5795,13 @@ server <- function(input, output, session) {
# rv$code <- append_list(data = from_env$code(),list = rv$code,index = "import") # rv$code <- append_list(data = from_env$code(),list = rv$code,index = "import")
}) })
shiny::observeEvent(rv$data_original, {
if (is.null(rv$data_original) | NROW(rv$data_original) == 0) {
shiny::updateActionButton(inputId = "act_start", disabled = TRUE)
} else {
shiny::updateActionButton(inputId = "act_start", disabled = FALSE)
}
})
############################################################################## ##############################################################################
######### #########
@ -6387,11 +6485,6 @@ server <- function(input, output, session) {
condition = "output.uploaded == 'yes'", condition = "output.uploaded == 'yes'",
) )
# observeEvent(input$act_start, {
# nav_show(id = "overview",target = "Import"
# )
# })
############################################################################## ##############################################################################
######### #########
######### Page navigation ######### Page navigation

12
inst/apps/freesearcheR/server.R
View file

@ -186,6 +186,13 @@ server <- function(input, output, session) {
# rv$code <- append_list(data = from_env$code(),list = rv$code,index = "import") # rv$code <- append_list(data = from_env$code(),list = rv$code,index = "import")
}) })
shiny::observeEvent(rv$data_original, {
if (is.null(rv$data_original) | NROW(rv$data_original) == 0) {
shiny::updateActionButton(inputId = "act_start", disabled = TRUE)
} else {
shiny::updateActionButton(inputId = "act_start", disabled = FALSE)
}
})
############################################################################## ##############################################################################
######### #########
@ -869,11 +876,6 @@ server <- function(input, output, session) {
condition = "output.uploaded == 'yes'", condition = "output.uploaded == 'yes'",
) )
# observeEvent(input$act_start, {
# nav_show(id = "overview",target = "Import"
# )
# })
############################################################################## ##############################################################################
######### #########
######### Page navigation ######### Page navigation

35
inst/apps/freesearcheR/ui.R
View file

@ -66,26 +66,35 @@ ui_elements <- list(
shiny::br(), shiny::br(),
shiny::br(), shiny::br(),
shiny::h5("Exclude in-complete variables"), shiny::h5("Exclude in-complete variables"),
shiny::p("Before going further, you can exclude variables with a low degree of completeness."), shiny::fluidRow(
shiny::br(), shiny::column(width=6,
shinyWidgets::noUiSliderInput( shiny::br(),
inputId = "complete_cutoff", shiny::br(),
label = "Choose completeness threshold (%)", shiny::p("Filter incomplete variables, by setting a completeness threshold:"),
min = 0, shiny::br()
max = 100, ),
step = 10, shiny::column(width=6,
value = 70, shinyWidgets::noUiSliderInput(
format = shinyWidgets::wNumbFormat(decimals = 0), inputId = "complete_cutoff",
color = datamods:::get_primary_color() label = NULL,
min = 0,
max = 100,
step = 5,
value = 70,
format = shinyWidgets::wNumbFormat(decimals = 0),
color = datamods:::get_primary_color()
),
shiny::helpText("Include variables with completeness above the specified percentage.")
)
), ),
shiny::helpText("Only include variables with completeness above a specified percentage."),
shiny::br(), shiny::br(),
shiny::br(), shiny::br(),
shiny::actionButton( shiny::actionButton(
inputId = "act_start", inputId = "act_start",
label = "Start", label = "Start",
width = "100%", width = "100%",
icon = shiny::icon("play") icon = shiny::icon("play"),
disabled = TRUE
), ),
shiny::helpText('After importing, hit "Start" or navigate to the desired tab.'), shiny::helpText('After importing, hit "Start" or navigate to the desired tab.'),
shiny::br(), shiny::br(),