mirror of
https://github.com/agdamsbo/FreesearchR.git
synced 2025-09-12 18:09:39 +02:00
364 lines
9.1 KiB
R
364 lines
9.1 KiB
R
#' Shiny module to browser and export REDCap data
|
||
#'
|
||
#' @param id Namespace id
|
||
#' @param include_title logical to include title
|
||
#'
|
||
#' @rdname redcap_read_shiny_module
|
||
#'
|
||
#' @return shiny ui element
|
||
#' @export
|
||
m_redcap_readUI <- function(id, include_title = TRUE) {
|
||
ns <- shiny::NS(id)
|
||
|
||
server_ui <- shiny::column(
|
||
width = 6,
|
||
shiny::tags$h4("REDCap server information"),
|
||
shiny::textInput(
|
||
inputId = ns("uri"),
|
||
label = "URI/Address",
|
||
value = "https://redcap.your.institution/api/"
|
||
),
|
||
shiny::textInput(
|
||
inputId = ns("api"),
|
||
label = "API token",
|
||
value = ""
|
||
)
|
||
)
|
||
|
||
|
||
params_ui <-
|
||
shiny::column(
|
||
width = 6,
|
||
shiny::tags$h4("Data import parameters"),
|
||
shiny::helpText("Options here will show, when API and uri are typed"),
|
||
shiny::uiOutput(outputId = ns("fields")),
|
||
shinyWidgets::switchInput(
|
||
inputId = "do_filter",
|
||
label = "Apply filter?",
|
||
value = FALSE,
|
||
inline = FALSE,
|
||
onLabel = "YES",
|
||
offLabel = "NO"
|
||
),
|
||
# shiny::radioButtons(
|
||
# inputId = "do_filter",
|
||
# label = "Filter export?",
|
||
# selected = "no",
|
||
# inline = TRUE,
|
||
# choices = list(
|
||
# "No" = "no",
|
||
# "Yes" = "yes"
|
||
# )
|
||
# ),
|
||
shiny::conditionalPanel(
|
||
condition = "input.do_filter",
|
||
shiny::uiOutput(outputId = ns("arms")),
|
||
shiny::textInput(
|
||
inputId = ns("filter"),
|
||
label = "Optional filter logic (e.g., [gender] = 'female')"
|
||
)
|
||
)
|
||
)
|
||
|
||
|
||
shiny::fluidPage(
|
||
if (include_title) shiny::tags$h3("Import data from REDCap"),
|
||
fluidRow(
|
||
server_ui,
|
||
params_ui),
|
||
shiny::column(
|
||
width = 12,
|
||
# shiny::actionButton(inputId = ns("import"), label = "Import"),
|
||
bslib::input_task_button(
|
||
id = ns("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
|
||
),
|
||
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::br(),
|
||
shiny::br(),
|
||
shiny::br(),
|
||
DT::DTOutput(outputId = ns("table"))
|
||
# toastui::datagridOutput2(outputId = ns("table"))
|
||
)
|
||
# toastui::datagridOutput2(outputId = ns("table")),
|
||
# toastui::datagridOutput2(outputId = ns("data")),
|
||
# shiny::actionButton(inputId = ns("submit"), label = "Submit"),
|
||
# DT::DTOutput(outputId = ns("data_prev"))
|
||
)
|
||
}
|
||
|
||
#' @param output.format data.frame ("df") or teal data object ("teal")
|
||
#' @rdname redcap_read_shiny_module
|
||
#'
|
||
#' @return shiny server module
|
||
#' @export
|
||
#'
|
||
m_redcap_readServer <- function(id, output.format = c("df", "teal", "list")) {
|
||
output.format <- match.arg(output.format)
|
||
|
||
module <- function(input, output, session) {
|
||
# ns <- shiny::NS(id)
|
||
ns <- session$ns
|
||
|
||
# data_list <- shiny::reactiveValues(
|
||
# dict = NULL,
|
||
# stat = NULL,
|
||
# arms = NULL,
|
||
# data = NULL,
|
||
# name = NULL
|
||
# )
|
||
|
||
dd <- shiny::reactive({
|
||
shiny::req(input$api)
|
||
shiny::req(input$uri)
|
||
|
||
|
||
REDCapR::redcap_metadata_read(
|
||
redcap_uri = input$uri,
|
||
token = input$api
|
||
)$data
|
||
})
|
||
|
||
# dd <- shiny::reactive({
|
||
# shiny::req(input$api)
|
||
# shiny::req(input$uri)
|
||
#
|
||
#
|
||
# out <- REDCapR::redcap_metadata_read(
|
||
# redcap_uri = input$uri,
|
||
# token = input$api
|
||
# )
|
||
#
|
||
# data_list$dict <- out$data
|
||
# data_list$stat <- out$success
|
||
#
|
||
# out$data
|
||
# })
|
||
|
||
arms <- shiny::reactive({
|
||
shiny::req(input$api)
|
||
shiny::req(input$uri)
|
||
|
||
REDCapR::redcap_event_read(
|
||
redcap_uri = input$uri,
|
||
token = input$api
|
||
)$data
|
||
|
||
# data_list$arms <- out
|
||
# out
|
||
})
|
||
|
||
output$fields <- shiny::renderUI({
|
||
shinyWidgets::virtualSelectInput(
|
||
inputId = ns("fields"),
|
||
label = "Select fields/variables to import:",
|
||
choices = dd() |>
|
||
dplyr::select(field_name, form_name) |>
|
||
(\(.x){
|
||
split(.x$field_name, .x$form_name)
|
||
})() # |>
|
||
# stats::setNames(instr()[["data"]][[2]])
|
||
,
|
||
updateOn = "close",
|
||
multiple = TRUE,
|
||
search = TRUE,
|
||
showValueAsTags = TRUE
|
||
)
|
||
})
|
||
|
||
output$arms <- shiny::renderUI({
|
||
shiny::selectizeInput(
|
||
# inputId = "arms",
|
||
inputId = ns("arms"),
|
||
selected = NULL,
|
||
label = "Filter by events/arms",
|
||
choices = arms()[[3]],
|
||
multiple = TRUE
|
||
)
|
||
})
|
||
|
||
output$table <- DT::renderDT(
|
||
{
|
||
shiny::req(input$api)
|
||
shiny::req(input$uri)
|
||
# shiny::req(data_list$dict)
|
||
# dd()[["data"]][c(1,2,4,5,6,8)]
|
||
# browser()
|
||
data.df <- dd()[, c(1, 2, 4, 5, 6, 8)]
|
||
DT::datatable(data.df,
|
||
caption = "Subset of data dictionary"
|
||
)
|
||
},
|
||
server = TRUE
|
||
)
|
||
|
||
# Messes up the overlay of other objects. JS thing?
|
||
# output$table <- toastui::renderDatagrid2(
|
||
# {
|
||
# shiny::req(input$api)
|
||
# shiny::req(input$uri)
|
||
# # shiny::req(data_list$dict)
|
||
# # dd()[["data"]][c(1,2,4,5,6,8)]
|
||
# # browser()
|
||
# toastui::datagrid(dd()[,c(1, 2, 4, 5, 6, 8)]
|
||
# )
|
||
# }
|
||
# )
|
||
|
||
name <- shiny::reactive({
|
||
shiny::req(input$api)
|
||
REDCapR::redcap_project_info_read(
|
||
redcap_uri = input$uri,
|
||
token = input$api
|
||
)$data$project_title
|
||
})
|
||
|
||
shiny::eventReactive(input$import, {
|
||
shiny::req(input$api)
|
||
shiny::req(input$fields)
|
||
record_id <- dd()[[1]][1]
|
||
|
||
redcap_data <- REDCapCAST::read_redcap_tables(
|
||
uri = input$uri,
|
||
token = input$api,
|
||
fields = unique(c(record_id, input$fields)),
|
||
# forms = input$instruments,
|
||
events = input$arms,
|
||
raw_or_label = "both",
|
||
filter_logic = input$filter
|
||
) |>
|
||
REDCapCAST::redcap_wider() |>
|
||
dplyr::select(-dplyr::ends_with("_complete")) |>
|
||
dplyr::select(-dplyr::any_of(record_id)) |>
|
||
REDCapCAST::suffix2label()
|
||
|
||
out_object <- file_export(redcap_data,
|
||
output.format = output.format,
|
||
filename = name()
|
||
)
|
||
|
||
if (output.format == "list") {
|
||
out <- list(
|
||
data = shiny::reactive(redcap_data),
|
||
meta = dd(),
|
||
name = name(),
|
||
filter = input$filter
|
||
)
|
||
} else {
|
||
out <- out_object
|
||
}
|
||
|
||
return(out)
|
||
})
|
||
}
|
||
|
||
shiny::moduleServer(
|
||
id = id,
|
||
module = module
|
||
)
|
||
}
|
||
|
||
#' REDCap import teal data module
|
||
#'
|
||
#' @rdname redcap_read_shiny_module
|
||
tdm_redcap_read <- teal::teal_data_module(
|
||
|
||
ui <- function(id) {
|
||
shiny::fluidPage(
|
||
m_redcap_readUI(id)
|
||
)
|
||
},
|
||
server = function(id) {
|
||
m_redcap_readServer(id, output.format = "teal")
|
||
}
|
||
)
|
||
|
||
|
||
#' Test app for the redcap_read_shiny_module
|
||
#'
|
||
#' @rdname redcap_read_shiny_module
|
||
#'
|
||
#' @examples
|
||
#' \dontrun{
|
||
#' redcap_app()
|
||
#' }
|
||
redcap_app <- function() {
|
||
ui <- shiny::fluidPage(
|
||
m_redcap_readUI("data"),
|
||
# DT::DTOutput(outputId = "redcap_prev")
|
||
toastui::datagridOutput2(outputId = "redcap_prev"),
|
||
shiny::fluidRow(
|
||
shiny::column(
|
||
8,
|
||
# verbatimTextOutput("data_filter_code"),
|
||
DT::DTOutput("data_summary")
|
||
),
|
||
shiny::column(4, IDEAFilter::IDEAFilter_ui("data_filter"))
|
||
)
|
||
)
|
||
server <- function(input, output, session) {
|
||
data_val <- shiny::reactiveValues(data=NULL)
|
||
|
||
ds <- m_redcap_readServer("data", output.format = "df")
|
||
# output$redcap_prev <- DT::renderDT(
|
||
# {
|
||
# DT::datatable(purrr::pluck(ds(), "data")(),
|
||
# caption = "Observations"
|
||
# )
|
||
# },
|
||
# server = TRUE
|
||
# )
|
||
|
||
# shiny::reactive({
|
||
# data_val$data <- purrr::pluck(ds(), "data")()
|
||
# })
|
||
|
||
output$redcap_prev <- toastui::renderDatagrid2({
|
||
# toastui::datagrid(purrr::pluck(ds(), "data")())
|
||
# toastui::datagrid(data_val$data)
|
||
toastui::datagrid(ds())
|
||
})
|
||
|
||
filtered_data <- IDEAFilter::IDEAFilter("data_filter",
|
||
data = ds,
|
||
verbose = FALSE)
|
||
|
||
# filtered_data <- shiny::reactive({
|
||
# IDEAFilter::IDEAFilter("data_filter",
|
||
# data = purrr::pluck(ds(), "data")(),
|
||
# verbose = FALSE)
|
||
# })
|
||
|
||
# output$data_filter_code <- renderPrint({
|
||
# cat(gsub(
|
||
# "%>%", "%>% \n ",
|
||
# gsub(
|
||
# "\\s{2,}", " ",
|
||
# paste0(
|
||
# capture.output(attr(filtered_data(), "code")),
|
||
# collapse = " "
|
||
# )
|
||
# )
|
||
# ))
|
||
# })
|
||
|
||
output$data_summary <- DT::renderDataTable(
|
||
{
|
||
filtered_data()
|
||
},
|
||
options = list(
|
||
scrollX = TRUE,
|
||
pageLength = 5
|
||
)
|
||
)
|
||
}
|
||
shiny::shinyApp(ui, server)
|
||
}
|