mirror of
https://github.com/agdamsbo/FreesearchR.git
synced 2026-06-19 12:37:30 +02:00
a bit of trial and error. not completely satisfied with readcap_read-module yet
This commit is contained in:
parent
a5c0a01d8a
commit
00eb49c225
16 changed files with 1186 additions and 383 deletions
45
R/helpers.R
45
R/helpers.R
|
|
@ -10,13 +10,13 @@
|
|||
#' @examples
|
||||
#' getfun("stats::lm")
|
||||
getfun <- function(x) {
|
||||
if("character" %in% class(x)){
|
||||
if ("character" %in% class(x)) {
|
||||
if (length(grep("::", x)) > 0) {
|
||||
parts <- strsplit(x, "::")[[1]]
|
||||
requireNamespace(parts[1])
|
||||
getExportedValue(parts[1], parts[2])
|
||||
}
|
||||
}else {
|
||||
} else {
|
||||
x
|
||||
}
|
||||
}
|
||||
|
|
@ -29,20 +29,20 @@ getfun <- function(x) {
|
|||
#' @return output file name
|
||||
#' @export
|
||||
#'
|
||||
write_quarto <- function(data,...){
|
||||
|
||||
write_quarto <- function(data, ...) {
|
||||
# Exports data to temporary location
|
||||
#
|
||||
# I assume this is more secure than putting it in the www folder and deleting
|
||||
# on session end
|
||||
temp <- tempfile(fileext = ".rds")
|
||||
readr::write_rds(data,file=temp)
|
||||
readr::write_rds(data, file = temp)
|
||||
|
||||
## Specifying a output path will make the rendering fail
|
||||
## Ref: https://github.com/quarto-dev/quarto-cli/discussions/4041
|
||||
## Outputs to the same as the .qmd file
|
||||
quarto::quarto_render(execute_params = list(data.file=temp),
|
||||
...
|
||||
quarto::quarto_render(
|
||||
execute_params = list(data.file = temp),
|
||||
...
|
||||
)
|
||||
}
|
||||
|
||||
|
|
@ -87,7 +87,7 @@ read_input <- function(file, consider.na = c("NA", '""', "")) {
|
|||
#' @return list
|
||||
#' @export
|
||||
#'
|
||||
argsstring2list <- function(string){
|
||||
argsstring2list <- function(string) {
|
||||
eval(parse(text = paste0("list(", string, ")")))
|
||||
}
|
||||
|
||||
|
|
@ -99,7 +99,7 @@ argsstring2list <- function(string){
|
|||
#'
|
||||
#' @return data.frame
|
||||
#' @export
|
||||
factorize <- function(data,vars){
|
||||
factorize <- function(data, vars) {
|
||||
if (!is.null(vars)) {
|
||||
data |>
|
||||
dplyr::mutate(
|
||||
|
|
@ -123,29 +123,40 @@ dummy_Imports <- function() {
|
|||
parameters::ci(),
|
||||
DT::addRow(),
|
||||
bslib::accordion()
|
||||
)
|
||||
#https://github.com/hadley/r-pkgs/issues/828
|
||||
}
|
||||
)
|
||||
# https://github.com/hadley/r-pkgs/issues/828
|
||||
}
|
||||
|
||||
|
||||
file_export <- function(data,output.format=c("df","teal"),filename){
|
||||
file_export <- function(data, output.format = c("df", "teal", "list"), filename, ...) {
|
||||
output.format <- match.arg(output.format)
|
||||
|
||||
filename <- gsub("-","_",filename)
|
||||
filename <- gsub("-", "_", filename)
|
||||
|
||||
if (output.format=="teal"){
|
||||
if (output.format == "teal") {
|
||||
out <- within(
|
||||
teal_data(),
|
||||
{
|
||||
assign(name, value |> dplyr::bind_cols())
|
||||
assign(name, value |>
|
||||
dplyr::bind_cols() |>
|
||||
REDCapCAST::parse_data() |>
|
||||
REDCapCAST::as_factor() |>
|
||||
REDCapCAST::numchar2fct())
|
||||
},
|
||||
value = data,
|
||||
name = filename
|
||||
)
|
||||
|
||||
datanames(out) <- filename
|
||||
} else if (output.format=="df"){
|
||||
} else if (output.format == "df") {
|
||||
out <- data
|
||||
} else if (output.format == "list") {
|
||||
out <- list(
|
||||
data = data,
|
||||
name = filename
|
||||
)
|
||||
|
||||
out <- c(out,...)
|
||||
}
|
||||
|
||||
out
|
||||
|
|
|
|||
336
R/modules.R
336
R/modules.R
|
|
@ -30,7 +30,6 @@ m_datafileUI <- function(id) {
|
|||
}
|
||||
|
||||
m_datafileServer <- function(id, output.format = "df") {
|
||||
ns <- shiny::NS(id)
|
||||
shiny::moduleServer(id, function(input, output, session, ...) {
|
||||
ns <- shiny::NS(id)
|
||||
ds <- shiny::reactive({
|
||||
|
|
@ -54,7 +53,7 @@ m_datafileServer <- function(id, output.format = "df") {
|
|||
} else {
|
||||
out <- input$include_vars
|
||||
}
|
||||
return(out)
|
||||
out
|
||||
})
|
||||
|
||||
output$data_input <-
|
||||
|
|
@ -64,125 +63,262 @@ m_datafileServer <- function(id, output.format = "df") {
|
|||
})
|
||||
|
||||
shiny::eventReactive(input$submit, {
|
||||
shiny::req(input$file)
|
||||
# shiny::req(input$file)
|
||||
|
||||
file_export(
|
||||
data = ds()[base_vars()] |> REDCapCAST::numchar2fct(),
|
||||
data <- shiny::isolate({
|
||||
ds()[base_vars()]
|
||||
})
|
||||
|
||||
file_export(data,
|
||||
output.format = output.format,
|
||||
filename = tools::file_path_sans_ext(input$file$name)
|
||||
tools::file_path_sans_ext(input$file$name)
|
||||
)
|
||||
})
|
||||
})
|
||||
}
|
||||
|
||||
|
||||
#' Shiny module to browser and export REDCap data
|
||||
#'
|
||||
#' @param id Namespace id
|
||||
#' @rdname redcap_read_shiny_module
|
||||
#'
|
||||
#' @return shiny ui element
|
||||
#' @export
|
||||
m_redcap_readUI <- function(id) {
|
||||
ns <- shiny::NS(id)
|
||||
shiny::tagList(
|
||||
shiny::textInput(
|
||||
inputId = ns("uri"),
|
||||
label = "URI",
|
||||
value = "https://redcap.your.institution/api/"
|
||||
),
|
||||
shiny::textInput(
|
||||
inputId = ns("api"),
|
||||
label = "API token",
|
||||
value = ""
|
||||
),
|
||||
shiny::tableOutput(outputId = ns("table")),
|
||||
shiny::uiOutput(outputId = ns("fields")),
|
||||
shiny::uiOutput(outputId = ns("instruments")),
|
||||
shiny::uiOutput(outputId = ns("arms")),
|
||||
shiny::actionButton(inputId = ns("submit"), "Submit")
|
||||
|
||||
server_ui <- fluidRow(
|
||||
column(
|
||||
width = 6,
|
||||
shiny::textInput(
|
||||
inputId = ns("uri"),
|
||||
label = "URI",
|
||||
value = "https://redcap.your.institution/api/"
|
||||
),
|
||||
shiny::textInput(
|
||||
inputId = ns("api"),
|
||||
label = "API token",
|
||||
value = ""
|
||||
)
|
||||
)
|
||||
)
|
||||
|
||||
params_ui <- fluidRow(
|
||||
column(
|
||||
width = 6,
|
||||
shiny::uiOutput(outputId = ns("fields")),
|
||||
shinyWidgets::switchInput(
|
||||
inputId = "do_filter",
|
||||
label = "Apply filter?",
|
||||
value = FALSE,
|
||||
inline = TRUE
|
||||
),
|
||||
# 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(
|
||||
server_ui,
|
||||
params_ui,
|
||||
shiny::actionButton(inputId = ns("import"), label = "Import"),
|
||||
shiny::br(),
|
||||
DT::DTOutput(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"))
|
||||
)
|
||||
}
|
||||
|
||||
m_redcap_readServer <- function(id, output.format="df") {
|
||||
ns <- shiny::NS(id)
|
||||
shiny::moduleServer(
|
||||
id,
|
||||
function(input, output, session,...) {
|
||||
ns <- shiny::NS(id)
|
||||
instr <- shiny::reactive({
|
||||
#' @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
|
||||
|
||||
dd <- shiny::reactive({
|
||||
shiny::req(input$api)
|
||||
shiny::req(input$uri)
|
||||
|
||||
REDCapR::redcap_metadata_read(
|
||||
redcap_uri = input$uri,
|
||||
token = input$api
|
||||
)$data
|
||||
})
|
||||
|
||||
arms <- shiny::reactive({
|
||||
shiny::req(input$api)
|
||||
shiny::req(input$uri)
|
||||
|
||||
REDCapR::redcap_event_read(
|
||||
redcap_uri = input$uri,
|
||||
token = input$api
|
||||
)$data
|
||||
})
|
||||
|
||||
output$fields <- shiny::renderUI({
|
||||
shinyWidgets::virtualSelectInput(
|
||||
inputId = ns("fields"),
|
||||
label = "Multiple select:",
|
||||
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
|
||||
)
|
||||
})
|
||||
|
||||
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)
|
||||
REDCapR::redcap_instruments(redcap_uri = input$uri, token = input$api)
|
||||
})
|
||||
|
||||
output$instruments <- shiny::renderUI({
|
||||
shiny::selectizeInput(
|
||||
inputId = ns("instruments"),
|
||||
# inputId = "instruments",
|
||||
selected = NULL,
|
||||
label = "Instruments to include",
|
||||
choices = instr()[["data"]][[1]],
|
||||
multiple = TRUE
|
||||
# dd()[["data"]][c(1,2,4,5,6,8)]
|
||||
data.df <- dd()[c(1, 2, 4, 5, 6, 8)]
|
||||
DT::datatable(data.df,
|
||||
caption = "Subset of data dictionary"
|
||||
)
|
||||
})
|
||||
},
|
||||
server = TRUE
|
||||
)
|
||||
|
||||
dd <- shiny::reactive({
|
||||
shiny::req(input$api)
|
||||
shiny::req(input$uri)
|
||||
REDCapR::redcap_metadata_read(redcap_uri = input$uri, token = input$api)
|
||||
})
|
||||
name <- reactive({
|
||||
shiny::req(input$api)
|
||||
REDCapR::redcap_project_info_read(
|
||||
redcap_uri = input$uri,
|
||||
token = input$api
|
||||
)$data$project_title
|
||||
})
|
||||
|
||||
output$fields <- shiny::renderUI({
|
||||
shiny::selectizeInput(
|
||||
# inputId = "fields",
|
||||
inputId = ns("fields"),
|
||||
selected = NULL,
|
||||
label = "Fields/variables to include",
|
||||
choices = dd()[["data"]][[1]],
|
||||
multiple = TRUE
|
||||
)
|
||||
})
|
||||
shiny::eventReactive(input$import, {
|
||||
shiny::req(input$api)
|
||||
record_id <- dd()[[1]][1]
|
||||
|
||||
arms <- shiny::reactive({
|
||||
shiny::req(input$api)
|
||||
shiny::req(input$uri)
|
||||
REDCapR::redcap_event_read(redcap_uri = input$uri, token = input$api)
|
||||
})
|
||||
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()
|
||||
|
||||
output$arms <- shiny::renderUI({
|
||||
shiny::selectizeInput(
|
||||
# inputId = "arms",
|
||||
inputId = ns("arms"),
|
||||
selected = NULL,
|
||||
label = "Arms/events to include",
|
||||
choices = arms()[["data"]][[3]],
|
||||
multiple = TRUE
|
||||
)
|
||||
})
|
||||
out_object <- file_export(redcap_data,
|
||||
output.format = output.format,
|
||||
filename = name()
|
||||
)
|
||||
|
||||
output$table <- shiny::renderTable({
|
||||
dd()[["data"]]
|
||||
})
|
||||
|
||||
shiny::eventReactive(input$submit, {
|
||||
shiny::req(input$api)
|
||||
data <- REDCapCAST::read_redcap_tables(
|
||||
uri = input$uri,
|
||||
token = input$api,
|
||||
fields = unique(c(dd()[["data"]][[1]][1], input$fields)),
|
||||
forms = input$instruments,
|
||||
events = input$arms,
|
||||
raw_or_label = "both"
|
||||
)
|
||||
|
||||
info <- REDCapR::redcap_project_info_read(redcap_uri = input$uri,
|
||||
token = input$api)
|
||||
|
||||
data |>
|
||||
REDCapCAST::redcap_wider() |>
|
||||
REDCapCAST::suffix2label() |>
|
||||
REDCapCAST::as_factor() |>
|
||||
dplyr::select(-dplyr::ends_with("_complete")) |>
|
||||
dplyr::select(-dplyr::any_of(dd()[["data"]][[1]][1])) |>
|
||||
file_export(
|
||||
output.format = output.format,
|
||||
filename = info$data$project_title
|
||||
if (output.format == "list") {
|
||||
out <- list(
|
||||
data = shiny::reactive(redcap_data)
|
||||
# meta = dd()[["dd"]],
|
||||
# name = name,
|
||||
# filter = input$filter
|
||||
)
|
||||
})
|
||||
}
|
||||
|
||||
} else {
|
||||
out <- out_object
|
||||
}
|
||||
|
||||
return(out)
|
||||
})
|
||||
}
|
||||
|
||||
shiny::moduleServer(
|
||||
id = id,
|
||||
module = 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")
|
||||
}
|
||||
)
|
||||
|
||||
tdm_data_upload <- teal::teal_data_module(
|
||||
ui <- function(id) {
|
||||
shiny::fluidPage(
|
||||
m_datafileUI(id)
|
||||
)
|
||||
},
|
||||
server = function(id) {
|
||||
m_datafileServer(id, output.format = "teal")
|
||||
}
|
||||
)
|
||||
|
||||
|
||||
redcap_app <- function() {
|
||||
ui <- fluidPage(
|
||||
m_redcap_readUI("data"),
|
||||
DT::DTOutput(outputId = "redcap_prev")
|
||||
)
|
||||
server <- function(input, output, session) {
|
||||
ds <- m_redcap_readServer("data")
|
||||
output$redcap_prev <- DT::renderDT(
|
||||
{
|
||||
|
||||
# df <- shiny::isolate(data_redcap())
|
||||
# browser()
|
||||
#
|
||||
DT::datatable(ds(),
|
||||
caption = "Observations"
|
||||
)
|
||||
},
|
||||
server = TRUE
|
||||
)
|
||||
}
|
||||
shinyApp(ui, server)
|
||||
}
|
||||
|
||||
redcap_app()
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue