Compare commits

...

3 commits

Author SHA1 Message Date
6ea46ea233
updated vignette
Some checks are pending
pkgdown.yaml / pkgdown (push) Waiting to run
2025-04-03 14:31:34 +02:00
2800177fc5
improved import ui and redcap import with status messages 2025-04-03 13:11:02 +02:00
3e49868ff4
ui on modify pane 2025-04-03 06:31:05 +02:00
16 changed files with 556 additions and 345 deletions

View file

@ -42,6 +42,7 @@ export(getfun)
export(gg_theme_export)
export(gg_theme_shiny)
export(grepl_fix)
export(if_not_missing)
export(import_delim)
export(import_dta)
export(import_file_server)

View file

@ -1,3 +1,7 @@
# FreesearchR 25.4.12
Polished and simplified data import module including a much improved REDCap import module.
# FreesearchR 25.4.1
Focus is on polish and improved ui/ux.

View file

@ -1 +1 @@
app_version <- function()'250402_1131'
app_version <- function()'Version: 25.4.1.250403_1409'

View file

@ -128,7 +128,7 @@ sentence_paste <- function(data, and.str = "and") {
} else if (length(data) == 2) {
paste(data, collapse = glue::glue(" {and.str} "))
} else if (length(data) > 2) {
paste(paste(data[-length(data)], collapse = ", "), data[length(data)], collapse = glue::glue(" {and.str} "))
paste(paste(data[-length(data)], collapse = ", "), data[length(data)], sep = glue::glue(" {and.str} "))
}
}

View file

@ -335,7 +335,7 @@ data_description <- function(data) {
p_complete <- n_complete/n
sprintf(
i18n("Data has %s observations and %s variables, with %s (%s%%) complete cases"),
i18n("Data has %s observations and %s variables, with %s (%s%%) complete cases."),
n,
n_var,
n_complete,
@ -369,3 +369,26 @@ get_ggplot_label <- function(data,label){
assertthat::assert_that(ggplot2::is.ggplot(data))
data$labels[[label]]
}
#' Return if available
#'
#' @param data vector
#' @param default assigned value for missings
#'
#' @returns vector
#' @export
#'
#' @examples
#' NULL |> if_not_missing("new")
#' c(2,"a",NA) |> if_not_missing()
#' "See" |> if_not_missing()
if_not_missing <- function(data,default=NULL){
if (length(data)>1){
Reduce(c,lapply(data,if_not_missing))
} else if (is.na(data) || is.null(data)){
return(default)
} else {
return(data)
}
}

View file

@ -7,7 +7,7 @@
#'
#' @return shiny ui element
#' @export
m_redcap_readUI <- function(id, title = TRUE) {
m_redcap_readUI <- function(id, title = TRUE, url = NULL) {
ns <- shiny::NS(id)
if (isTRUE(title)) {
@ -23,7 +23,7 @@ m_redcap_readUI <- function(id, title = TRUE) {
shiny::textInput(
inputId = ns("uri"),
label = "Web address",
value = "https://redcap.your.institution/"
value = if_not_missing(url, "https://redcap.your.institution/")
),
shiny::helpText("Format should be either 'https://redcap.your.institution/' or 'https://your.institution/redcap/'"),
shiny::textInput(
@ -32,11 +32,13 @@ m_redcap_readUI <- function(id, title = TRUE) {
value = ""
),
shiny::helpText("The token is a string of 32 numbers and letters."),
shiny::br(),
shiny::br(),
shiny::actionButton(
inputId = ns("data_connect"),
label = "Connect",
icon = shiny::icon("link", lib = "glyphicon"),
# width = NULL,
width = "100%",
disabled = TRUE
),
shiny::br(),
@ -53,6 +55,15 @@ m_redcap_readUI <- function(id, title = TRUE) {
shiny::br()
)
filter_ui <-
shiny::tagList(
# width = 6,
shiny::uiOutput(outputId = ns("arms")),
shiny::textInput(
inputId = ns("filter"),
label = "Optional filter logic (e.g., [gender] = 'female')"
)
)
params_ui <-
shiny::tagList(
@ -60,41 +71,28 @@ m_redcap_readUI <- function(id, title = TRUE) {
shiny::tags$h4("Data import parameters"),
shiny::helpText("Options here will show, when API and uri are typed"),
shiny::uiOutput(outputId = ns("fields")),
shiny::tags$div(
class = "shiny-input-container",
shiny::tags$label(
class = "control-label",
`for` = ns("dropdown_params"),
"...",
style = htmltools::css(visibility = "hidden")
),
shinyWidgets::dropMenu(
shiny::actionButton(
inputId = ns("dropdown_params"),
label = "Add data filters",
icon = shiny::icon("filter"),
width = "100%",
class = "px-1"
),
filter_ui
),
shiny::helpText("Optionally filter project arms if logitudinal or apply server side data filters")
),
shiny::uiOutput(outputId = ns("data_type")),
shiny::uiOutput(outputId = ns("fill")),
shinyWidgets::switchInput(
inputId = "do_filter",
label = "Apply filter?",
value = FALSE,
inline = FALSE,
onLabel = "YES",
offLabel = "NO"
),
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(
title=title,
bslib::layout_columns(
server_ui,
params_ui,
col_widths = bslib::breakpoints(
sm = c(12, 12),
md = c(12, 12)
)
),
shiny::column(
width = 12,
# shiny::actionButton(inputId = ns("import"), label = "Import"),
## TODO: Use busy indicator like on download to have button activate/deactivate
shiny::actionButton(
inputId = ns("data_import"),
label = "Import",
@ -102,6 +100,18 @@ m_redcap_readUI <- function(id, title = TRUE) {
width = "100%",
disabled = TRUE
),
shiny::tags$br(),
shiny::tags$br(),
tags$div(
id = ns("retrieved-placeholder"),
shinyWidgets::alert(
id = ns("retrieved-result"),
status = "info",
tags$p(phosphoricons::ph("info", weight = "bold"), "Please specify data to download, then press 'Import'.")
),
dismissible = TRUE
)#,
## TODO: Use busy indicator like on download to have button activate/deactivate
# bslib::input_task_button(
# id = ns("data_import"),
# label = "Import",
@ -114,12 +124,20 @@ m_redcap_readUI <- function(id, title = TRUE) {
# type = "primary",
# auto_reset = TRUE#,state="busy"
# ),
shiny::br(),
shiny::br(),
shiny::helpText("Press 'Import' to get data from the REDCap server. Check the preview below before proceeding."),
shiny::br(),
shiny::br()
# shiny::br(),
# shiny::helpText("Press 'Import' to get data from the REDCap server. Check the preview below before proceeding.")
)
shiny::fluidPage(
title = title,
server_ui,
shiny::conditionalPanel(
condition = "output.connect_success == true",
params_ui,
ns = ns
),
shiny::br()
)
}
@ -149,8 +167,8 @@ m_redcap_readServer <- function(id) {
shiny::observeEvent(list(input$api, input$uri), {
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/")
if (!is.null(input$uri)) {
uri <- paste0(ifelse(endsWith(input$uri, "/"), input$uri, paste0(input$uri, "/")), "api/")
} else {
uri <- input$uri
}
@ -204,9 +222,11 @@ m_redcap_readServer <- function(id) {
datamods:::insert_alert(
selector = ns("connect"),
status = "success",
include_data_alert(see_data_text = "Click to see data dictionary",
include_data_alert(
see_data_text = "Click to see data dictionary",
dataIdName = "see_data",
extra = tags$p(tags$b(phosphoricons::ph("check", weight = "bold"), "Connected to server!"), tags$p(paste0(data_rv$info$project_title, " loaded."))),
extra = tags$p(tags$b(phosphoricons::ph("check", weight = "bold"), "Connected to server!"),
glue::glue("The {data_rv$info$project_title} project is loaded.")),
btn_show_data = TRUE
)
)
@ -225,6 +245,9 @@ m_redcap_readServer <- function(id) {
}
)
output$connect_success <- shiny::reactive(identical(data_rv$dd_status, "success"))
shiny::outputOptions(output, "connect_success", suspendWhenHidden = FALSE)
shiny::observeEvent(input$see_data, {
datamods::show_data(
purrr::pluck(data_rv$dd_list, "data"),
@ -313,17 +336,21 @@ m_redcap_readServer <- function(id) {
})
output$arms <- shiny::renderUI({
vectorSelectInput(
inputId = ns("arms"),
selected = NULL,
label = "Filter by events/arms",
choices = stats::setNames(arms()[[3]], arms()[[1]]),
multiple = TRUE
)
if (NROW(arms()) > 0) {
vectorSelectInput(
inputId = ns("arms"),
selected = NULL,
label = "Filter by events/arms",
choices = stats::setNames(arms()[[3]], arms()[[1]]),
multiple = TRUE
)
}
})
shiny::observeEvent(input$data_import, {
shiny::req(input$fields)
# browser()
record_id <- purrr::pluck(data_rv$dd_list, "data")[[1]][1]
@ -334,7 +361,11 @@ m_redcap_readServer <- function(id) {
events = input$arms,
raw_or_label = "both",
filter_logic = input$filter,
split_forms = if (input$data_type == "long") "none" else "all"
split_forms = ifelse(
input$data_type == "long" && !is.null(input$data_type),
"none",
"all"
)
)
shiny::withProgress(message = "Downloading REDCap data. Hold on for a moment..", {
@ -342,19 +373,24 @@ m_redcap_readServer <- function(id) {
})
code <- rlang::call2("read_redcap_tables",
!!!utils::modifyList(parameters,list(token="PERSONAL_API_TOKEN")),
, .ns = "REDCapCAST")
!!!utils::modifyList(parameters, list(token = "PERSONAL_API_TOKEN")), ,
.ns = "REDCapCAST"
)
# browser()
if (inherits(imported, "try-error") || NROW(imported) < 1) {
data_rv$data_status <- "error"
data_rv$data_list <- NULL
data_rv$data_message <- imported$raw_text
} else {
data_rv$data_status <- "success"
data_rv$data_message <- "Requested data was retrieved!"
## The data management below should be separated to allow for changing
## "wide"/"long" without re-importing data
if (input$data_type != "long") {
if (parameters$split_form == "all") {
# browser()
out <- imported |>
# redcap_wider()
@ -378,6 +414,20 @@ m_redcap_readServer <- function(id) {
}
}
# browser()
in_data_check <- parameters$fields %in% names(out) |
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 <- "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 <- "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$data <- out |>
@ -387,13 +437,33 @@ m_redcap_readServer <- function(id) {
}
})
# shiny::observe({
# shiny::req(data_rv$imported)
#
# imported <- data_rv$imported
#
#
# })
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
)
)
} 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),
@ -553,13 +623,12 @@ drop_empty_event <- function(data, event = "redcap_event_name") {
#' }
redcap_demo_app <- function() {
ui <- shiny::fluidPage(
m_redcap_readUI("data"),
m_redcap_readUI("data", url = NULL),
DT::DTOutput("data"),
shiny::tags$b("Code:"),
shiny::verbatimTextOutput(outputId = "code")
)
server <- function(input, output, session) {
data_val <- m_redcap_readServer(id = "data")
output$data <- DT::renderDataTable(

View file

@ -2,12 +2,14 @@
#'
#' @param x (`tbl_regression`, `tbl_uvregression`)\cr
#' A 'tbl_regression' or 'tbl_uvregression' object
## #' @param remove_header_rows (scalar `logical`)\cr
## #' logical indicating whether to remove header rows
## #' for categorical variables. Default is `TRUE`
## #' @param remove_reference_rows (scalar `logical`)\cr
## #' logical indicating whether to remove reference rows
## #' for categorical variables. Default is `FALSE`.
#' @param plot_ref (scalar `logical`)\cr
#' plot reference values
#' @param remove_header_rows (scalar `logical`)\cr
#' logical indicating whether to remove header rows
#' for categorical variables. Default is `TRUE`
#' @param remove_reference_rows (scalar `logical`)\cr
#' logical indicating whether to remove reference rows
#' for categorical variables. Default is `FALSE`.
#' @param ... arguments passed to `ggstats::ggcoef_plot(...)`
#'
#' @returns ggplot object

View file

@ -118,8 +118,8 @@ update_variables_server <- function(id,
output$data_info <- shiny::renderUI({
shiny::req(data_r())
data <- data_r()
sprintf(i18n("Data has %s observations and %s variables."), nrow(data), ncol(data))
data_description(data_r())
# sprintf(i18n("Data has %s observations and %s variables."), nrow(data), ncol(data))
})
variables_r <- shiny::reactive({
@ -645,10 +645,10 @@ convert_to <- function(data,
setNames(list(expr(as.character(!!sym(variable)))), variable)
)
} else if (identical(new_class, "factor")) {
data[[variable]] <- as.factor(x = data[[variable]])
data[[variable]] <- REDCapCAST::as_factor(x = data[[variable]])
attr(data, "code_03_convert") <- c(
attr(data, "code_03_convert"),
setNames(list(expr(as.factor(!!sym(variable)))), variable)
setNames(list(expr(REDCapCAST::as_factor(!!sym(variable)))), variable)
)
} else if (identical(new_class, "numeric")) {
data[[variable]] <- as.numeric(data[[variable]], ...)

View file

@ -10,7 +10,7 @@
#### Current file: /Users/au301842/FreesearchR/R//app_version.R
########
app_version <- function()'250402_1131'
app_version <- function()'Version: 25.4.1.250403_1409'
########
@ -287,7 +287,7 @@ sentence_paste <- function(data, and.str = "and") {
} else if (length(data) == 2) {
paste(data, collapse = glue::glue(" {and.str} "))
} else if (length(data) > 2) {
paste(paste(data[-length(data)], collapse = ", "), data[length(data)], collapse = glue::glue(" {and.str} "))
paste(paste(data[-length(data)], collapse = ", "), data[length(data)], sep = glue::glue(" {and.str} "))
}
}
@ -2808,7 +2808,7 @@ data_description <- function(data) {
p_complete <- n_complete/n
sprintf(
i18n("Data has %s observations and %s variables, with %s (%s%%) complete cases"),
i18n("Data has %s observations and %s variables, with %s (%s%%) complete cases."),
n,
n_var,
n_complete,
@ -2844,6 +2844,29 @@ get_ggplot_label <- function(data,label){
}
#' Return if available
#'
#' @param data vector
#' @param default assigned value for missings
#'
#' @returns vector
#' @export
#'
#' @examples
#' NULL |> if_not_missing("new")
#' c(2,"a",NA) |> if_not_missing()
#' "See" |> if_not_missing()
if_not_missing <- function(data,default=NULL){
if (length(data)>1){
Reduce(c,lapply(data,if_not_missing))
} else if (is.na(data) || is.null(data)){
return(default)
} else {
return(data)
}
}
########
#### Current file: /Users/au301842/FreesearchR/R//import-file-ext.R
########
@ -4168,7 +4191,7 @@ plot_download_server <- function(id,
#'
#' @return shiny ui element
#' @export
m_redcap_readUI <- function(id, title = TRUE) {
m_redcap_readUI <- function(id, title = TRUE, url = NULL) {
ns <- shiny::NS(id)
if (isTRUE(title)) {
@ -4184,7 +4207,7 @@ m_redcap_readUI <- function(id, title = TRUE) {
shiny::textInput(
inputId = ns("uri"),
label = "Web address",
value = "https://redcap.your.institution/"
value = if_not_missing(url, "https://redcap.your.institution/")
),
shiny::helpText("Format should be either 'https://redcap.your.institution/' or 'https://your.institution/redcap/'"),
shiny::textInput(
@ -4193,11 +4216,13 @@ m_redcap_readUI <- function(id, title = TRUE) {
value = ""
),
shiny::helpText("The token is a string of 32 numbers and letters."),
shiny::br(),
shiny::br(),
shiny::actionButton(
inputId = ns("data_connect"),
label = "Connect",
icon = shiny::icon("link", lib = "glyphicon"),
# width = NULL,
width = "100%",
disabled = TRUE
),
shiny::br(),
@ -4214,6 +4239,15 @@ m_redcap_readUI <- function(id, title = TRUE) {
shiny::br()
)
filter_ui <-
shiny::tagList(
# width = 6,
shiny::uiOutput(outputId = ns("arms")),
shiny::textInput(
inputId = ns("filter"),
label = "Optional filter logic (e.g., [gender] = 'female')"
)
)
params_ui <-
shiny::tagList(
@ -4221,41 +4255,28 @@ m_redcap_readUI <- function(id, title = TRUE) {
shiny::tags$h4("Data import parameters"),
shiny::helpText("Options here will show, when API and uri are typed"),
shiny::uiOutput(outputId = ns("fields")),
shiny::tags$div(
class = "shiny-input-container",
shiny::tags$label(
class = "control-label",
`for` = ns("dropdown_params"),
"...",
style = htmltools::css(visibility = "hidden")
),
shinyWidgets::dropMenu(
shiny::actionButton(
inputId = ns("dropdown_params"),
label = "Add data filters",
icon = shiny::icon("filter"),
width = "100%",
class = "px-1"
),
filter_ui
),
shiny::helpText("Optionally filter project arms if logitudinal or apply server side data filters")
),
shiny::uiOutput(outputId = ns("data_type")),
shiny::uiOutput(outputId = ns("fill")),
shinyWidgets::switchInput(
inputId = "do_filter",
label = "Apply filter?",
value = FALSE,
inline = FALSE,
onLabel = "YES",
offLabel = "NO"
),
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(
title=title,
bslib::layout_columns(
server_ui,
params_ui,
col_widths = bslib::breakpoints(
sm = c(12, 12),
md = c(12, 12)
)
),
shiny::column(
width = 12,
# shiny::actionButton(inputId = ns("import"), label = "Import"),
## TODO: Use busy indicator like on download to have button activate/deactivate
shiny::actionButton(
inputId = ns("data_import"),
label = "Import",
@ -4263,6 +4284,18 @@ m_redcap_readUI <- function(id, title = TRUE) {
width = "100%",
disabled = TRUE
),
shiny::tags$br(),
shiny::tags$br(),
tags$div(
id = ns("retrieved-placeholder"),
shinyWidgets::alert(
id = ns("retrieved-result"),
status = "info",
tags$p(phosphoricons::ph("info", weight = "bold"), "Please specify data to download, then press 'Import'.")
),
dismissible = TRUE
)#,
## TODO: Use busy indicator like on download to have button activate/deactivate
# bslib::input_task_button(
# id = ns("data_import"),
# label = "Import",
@ -4275,12 +4308,20 @@ m_redcap_readUI <- function(id, title = TRUE) {
# type = "primary",
# auto_reset = TRUE#,state="busy"
# ),
shiny::br(),
shiny::br(),
shiny::helpText("Press 'Import' to get data from the REDCap server. Check the preview below before proceeding."),
shiny::br(),
shiny::br()
# shiny::br(),
# shiny::helpText("Press 'Import' to get data from the REDCap server. Check the preview below before proceeding.")
)
shiny::fluidPage(
title = title,
server_ui,
shiny::conditionalPanel(
condition = "output.connect_success == true",
params_ui,
ns = ns
),
shiny::br()
)
}
@ -4310,8 +4351,8 @@ m_redcap_readServer <- function(id) {
shiny::observeEvent(list(input$api, input$uri), {
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/")
if (!is.null(input$uri)) {
uri <- paste0(ifelse(endsWith(input$uri, "/"), input$uri, paste0(input$uri, "/")), "api/")
} else {
uri <- input$uri
}
@ -4365,9 +4406,11 @@ m_redcap_readServer <- function(id) {
datamods:::insert_alert(
selector = ns("connect"),
status = "success",
include_data_alert(see_data_text = "Click to see data dictionary",
include_data_alert(
see_data_text = "Click to see data dictionary",
dataIdName = "see_data",
extra = tags$p(tags$b(phosphoricons::ph("check", weight = "bold"), "Connected to server!"), tags$p(paste0(data_rv$info$project_title, " loaded."))),
extra = tags$p(tags$b(phosphoricons::ph("check", weight = "bold"), "Connected to server!"),
glue::glue("The {data_rv$info$project_title} project is loaded.")),
btn_show_data = TRUE
)
)
@ -4386,6 +4429,9 @@ m_redcap_readServer <- function(id) {
}
)
output$connect_success <- shiny::reactive(identical(data_rv$dd_status, "success"))
shiny::outputOptions(output, "connect_success", suspendWhenHidden = FALSE)
shiny::observeEvent(input$see_data, {
datamods::show_data(
purrr::pluck(data_rv$dd_list, "data"),
@ -4474,17 +4520,21 @@ m_redcap_readServer <- function(id) {
})
output$arms <- shiny::renderUI({
vectorSelectInput(
inputId = ns("arms"),
selected = NULL,
label = "Filter by events/arms",
choices = stats::setNames(arms()[[3]], arms()[[1]]),
multiple = TRUE
)
if (NROW(arms()) > 0) {
vectorSelectInput(
inputId = ns("arms"),
selected = NULL,
label = "Filter by events/arms",
choices = stats::setNames(arms()[[3]], arms()[[1]]),
multiple = TRUE
)
}
})
shiny::observeEvent(input$data_import, {
shiny::req(input$fields)
# browser()
record_id <- purrr::pluck(data_rv$dd_list, "data")[[1]][1]
@ -4495,7 +4545,11 @@ m_redcap_readServer <- function(id) {
events = input$arms,
raw_or_label = "both",
filter_logic = input$filter,
split_forms = if (input$data_type == "long") "none" else "all"
split_forms = ifelse(
input$data_type == "long" && !is.null(input$data_type),
"none",
"all"
)
)
shiny::withProgress(message = "Downloading REDCap data. Hold on for a moment..", {
@ -4503,19 +4557,24 @@ m_redcap_readServer <- function(id) {
})
code <- rlang::call2("read_redcap_tables",
!!!utils::modifyList(parameters,list(token="PERSONAL_API_TOKEN")),
, .ns = "REDCapCAST")
!!!utils::modifyList(parameters, list(token = "PERSONAL_API_TOKEN")), ,
.ns = "REDCapCAST"
)
# browser()
if (inherits(imported, "try-error") || NROW(imported) < 1) {
data_rv$data_status <- "error"
data_rv$data_list <- NULL
data_rv$data_message <- imported$raw_text
} else {
data_rv$data_status <- "success"
data_rv$data_message <- "Requested data was retrieved!"
## The data management below should be separated to allow for changing
## "wide"/"long" without re-importing data
if (input$data_type != "long") {
if (parameters$split_form == "all") {
# browser()
out <- imported |>
# redcap_wider()
@ -4539,6 +4598,20 @@ m_redcap_readServer <- function(id) {
}
}
# browser()
in_data_check <- parameters$fields %in% names(out) |
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 <- "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 <- "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$data <- out |>
@ -4548,13 +4621,33 @@ m_redcap_readServer <- function(id) {
}
})
# shiny::observe({
# shiny::req(data_rv$imported)
#
# imported <- data_rv$imported
#
#
# })
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
)
)
} 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),
@ -4714,13 +4807,12 @@ drop_empty_event <- function(data, event = "redcap_event_name") {
#' }
redcap_demo_app <- function() {
ui <- shiny::fluidPage(
m_redcap_readUI("data"),
m_redcap_readUI("data", url = NULL),
DT::DTOutput("data"),
shiny::tags$b("Code:"),
shiny::verbatimTextOutput(outputId = "code")
)
server <- function(input, output, session) {
data_val <- m_redcap_readServer(id = "data")
output$data <- DT::renderDataTable(
@ -5422,12 +5514,14 @@ regression_model_uv_list <- function(data,
#'
#' @param x (`tbl_regression`, `tbl_uvregression`)\cr
#' A 'tbl_regression' or 'tbl_uvregression' object
## #' @param remove_header_rows (scalar `logical`)\cr
## #' logical indicating whether to remove header rows
## #' for categorical variables. Default is `TRUE`
## #' @param remove_reference_rows (scalar `logical`)\cr
## #' logical indicating whether to remove reference rows
## #' for categorical variables. Default is `FALSE`.
#' @param plot_ref (scalar `logical`)\cr
#' plot reference values
#' @param remove_header_rows (scalar `logical`)\cr
#' logical indicating whether to remove header rows
#' for categorical variables. Default is `TRUE`
#' @param remove_reference_rows (scalar `logical`)\cr
#' logical indicating whether to remove reference rows
#' for categorical variables. Default is `FALSE`.
#' @param ... arguments passed to `ggstats::ggcoef_plot(...)`
#'
#' @returns ggplot object
@ -6911,8 +7005,8 @@ update_variables_server <- function(id,
output$data_info <- shiny::renderUI({
shiny::req(data_r())
data <- data_r()
sprintf(i18n("Data has %s observations and %s variables."), nrow(data), ncol(data))
data_description(data_r())
# sprintf(i18n("Data has %s observations and %s variables."), nrow(data), ncol(data))
})
variables_r <- shiny::reactive({
@ -7438,10 +7532,10 @@ convert_to <- function(data,
setNames(list(expr(as.character(!!sym(variable)))), variable)
)
} else if (identical(new_class, "factor")) {
data[[variable]] <- as.factor(x = data[[variable]])
data[[variable]] <- REDCapCAST::as_factor(x = data[[variable]])
attr(data, "code_03_convert") <- c(
attr(data, "code_03_convert"),
setNames(list(expr(as.factor(!!sym(variable)))), variable)
setNames(list(expr(REDCapCAST::as_factor(!!sym(variable)))), variable)
)
} else if (identical(new_class, "numeric")) {
data[[variable]] <- as.numeric(data[[variable]], ...)
@ -7840,6 +7934,8 @@ ui_elements <- list(
condition = "input.source=='redcap'",
DT::DTOutput(outputId = "redcap_prev")
),
shiny::conditionalPanel(
condition = "output.data_loaded == true",
shiny::br(),
shiny::br(),
shiny::h5("Specify variables to include"),
@ -7856,7 +7952,7 @@ ui_elements <- list(
shinyWidgets::noUiSliderInput(
inputId = "complete_cutoff",
label = NULL,
update_on = "change",
update_on = "end",
min = 0,
max = 100,
step = 5,
@ -7864,12 +7960,13 @@ ui_elements <- list(
format = shinyWidgets::wNumbFormat(decimals = 0),
color = datamods:::get_primary_color()
),
shiny::helpText("Filter variables with completeness above the specified percentage."),
shiny::helpText("Exclude variables with completeness below the specified percentage."),
shiny::br(),
shiny::br(),
shiny::uiOutput(outputId = "import_var"),
shiny::uiOutput(outputId = "data_info_import", inline = TRUE)
)
)
),
shiny::br(),
shiny::br(),
@ -7952,90 +8049,47 @@ ui_elements <- list(
fluidRow(
shiny::column(
width = 9,
shiny::tags$p(shiny::markdown("Below, are several options to update variables (rename, set new labels (for nicer tables in the report) and change variable classes (numeric, factor/categorical etc.).), modify factor/categorical variables as well as create new factor from a continous variable or new variables with *R* code."))
shiny::tags$p(shiny::markdown("Below, are several options for simple data manipulation like update variables by renaming, creating new labels (for nicer tables in the report) and changing variable classes (numeric, factor/categorical etc.)."),
shiny::tags$p("There are also more advanced options to modify factor/categorical variables as well as create new factor from a continous variable or new variables with *R* code. At the bottom you can restore the original data."))
)
),
shiny::tags$br(),
shiny::tags$br(),
# shiny::tags$br(),
update_variables_ui("modal_variables"),
shiny::tags$br(),
shiny::tags$br(),
fluidRow(
tags$h4("Advanced data manipulation"),
shiny::tags$br(),
shiny::tags$br(),
shiny::fluidRow(
shiny::column(
width = 2
),
shiny::column(
width = 8,
tags$h4("Advanced data manipulation"),
width = 4,
shiny::actionButton(
inputId = "modal_update",
label = "Reorder factor levels",
width = "100%"
),
shiny::tags$br(),
fluidRow(
shiny::column(
width = 6,
# tags$h4("Update or modify variables"),
# shiny::tags$br(),
# shiny::actionButton(
# inputId = "modal_variables",
# label = "Subset, rename and change class/type",
# width = "100%"
# ),
# shiny::tags$br(),
# shiny::helpText("Subset variables, rename variables and labels, and apply new class to variables"),
# shiny::tags$br(),
# shiny::tags$br(),
shiny::actionButton(
inputId = "modal_update",
label = "Reorder factor levels",
width = "100%"
),
shiny::tags$br(),
shiny::helpText("Reorder the levels of factor/categorical variables."),
shiny::tags$br(),
shiny::tags$br(),
shiny::actionButton(
inputId = "data_reset",
label = "Restore original data",
width = "100%"
),
shiny::tags$br(),
shiny::helpText("Reset to original imported dataset. Careful! There is no un-doing."),
shiny::tags$br(),
shiny::tags$br()
),
shiny::column(
width = 6,
# tags$h4("Create new variables"),
# shiny::tags$br(),
shiny::actionButton(
inputId = "modal_cut",
label = "New factor",
width = "100%"
),
shiny::tags$br(),
shiny::helpText("Create factor/categorical variable from a continous variable (number/date/time)."),
shiny::tags$br(),
shiny::tags$br(),
shiny::actionButton(
inputId = "modal_column",
label = "New variable",
width = "100%"
),
shiny::tags$br(),
shiny::helpText(shiny::markdown("Create a new variable/column based on an *R*-expression.")),
shiny::tags$br(),
shiny::tags$br()
)
) # ,
# tags$h4("Restore"),
# shiny::actionButton(
# inputId = "data_reset",
# label = "Restore original data",
# width = "100%"
# ),
# shiny::tags$br(),
# shiny::helpText("Reset to original imported dataset. Careful! There is no un-doing.")
shiny::helpText("Reorder the levels of factor/categorical variables."),
),
shiny::column(
width = 2
width = 4,
shiny::actionButton(
inputId = "modal_cut",
label = "New factor",
width = "100%"
),
shiny::tags$br(),
shiny::helpText("Create factor/categorical variable from a continous variable (number/date/time).")
),
shiny::column(
width = 4,
shiny::actionButton(
inputId = "modal_column",
label = "New variable",
width = "100%"
),
shiny::tags$br(),
shiny::helpText(shiny::markdown("Create a new variable/column based on an *R*-expression."))
)
),
shiny::tags$br(),
@ -8043,24 +8097,32 @@ ui_elements <- list(
tags$h4("Compare modified data to original"),
shiny::tags$br(),
shiny::tags$p(
"Here is a overview of the original vs the modified data."
"Raw print of the original vs the modified data."
),
shiny::tags$br(),
shiny::tags$br(),
fluidRow(
column(
shiny::fluidRow(
shiny::column(
width = 6,
tags$b("Original data:"),
shiny::tags$b("Original data:"),
# verbatimTextOutput("original"),
verbatimTextOutput("original_str")
shiny::verbatimTextOutput("original_str")
),
column(
shiny::column(
width = 6,
tags$b("Modified data:"),
shiny::tags$b("Modified data:"),
# verbatimTextOutput("modified"),
verbatimTextOutput("modified_str")
shiny::verbatimTextOutput("modified_str")
)
)
),
shiny::tags$br(),
shiny::actionButton(
inputId = "data_reset",
label = "Restore original data",
width = "100%"
),
shiny::tags$br(),
shiny::helpText("Reset to original imported dataset. Careful! There is no un-doing."),
shiny::tags$br()
)
)
),
@ -8603,19 +8665,34 @@ server <- function(input, output, session) {
)
})
output$data_loaded <- shiny::reactive({
!is.null(rv$data_temp)
})
shiny::observeEvent(input$source,{
rv$data_temp <- NULL
})
shiny::outputOptions(output, "data_loaded", suspendWhenHidden = FALSE)
shiny::observeEvent(
eventExpr = list(
input$import_var,
input$complete_cutoff
input$complete_cutoff,
rv$data_temp
),
handlerExpr = {
shiny::req(rv$data_temp)
# browser()
rv$data_original <- rv$data_temp |>
dplyr::select(input$import_var) |>
temp_data <- rv$data_temp
if (all(input$import_var %in% names(temp_data))){
temp_data <- temp_data |> dplyr::select(input$import_var)
}
rv$data_original <- temp_data |>
default_parsing()
rv$code$import <- rv$code$import |>
deparse() |>
paste(collapse = "") |>
@ -8628,7 +8705,7 @@ server <- function(input, output, session) {
rv$code$filter <- NULL
rv$code$modify <- NULL
}
},ignoreNULL = FALSE
)
output$data_info_import <- shiny::renderUI({
@ -8653,8 +8730,7 @@ server <- function(input, output, session) {
shiny::observeEvent(
eventExpr = list(
rv$data_original,
input$complete_cutoff
rv$data_original
),
handlerExpr = {
shiny::req(rv$data_original)

View file

@ -5,6 +5,6 @@ account: agdamsbo
server: shinyapps.io
hostUrl: https://api.shinyapps.io/v1
appId: 13611288
bundleId: 10042980
bundleId: 10049531
url: https://agdamsbo.shinyapps.io/freesearcheR/
version: 1

View file

@ -158,19 +158,34 @@ server <- function(input, output, session) {
)
})
output$data_loaded <- shiny::reactive({
!is.null(rv$data_temp)
})
shiny::observeEvent(input$source,{
rv$data_temp <- NULL
})
shiny::outputOptions(output, "data_loaded", suspendWhenHidden = FALSE)
shiny::observeEvent(
eventExpr = list(
input$import_var,
input$complete_cutoff
input$complete_cutoff,
rv$data_temp
),
handlerExpr = {
shiny::req(rv$data_temp)
# browser()
rv$data_original <- rv$data_temp |>
dplyr::select(input$import_var) |>
temp_data <- rv$data_temp
if (all(input$import_var %in% names(temp_data))){
temp_data <- temp_data |> dplyr::select(input$import_var)
}
rv$data_original <- temp_data |>
default_parsing()
rv$code$import <- rv$code$import |>
deparse() |>
paste(collapse = "") |>
@ -183,7 +198,7 @@ server <- function(input, output, session) {
rv$code$filter <- NULL
rv$code$modify <- NULL
}
},ignoreNULL = FALSE
)
output$data_info_import <- shiny::renderUI({
@ -208,8 +223,7 @@ server <- function(input, output, session) {
shiny::observeEvent(
eventExpr = list(
rv$data_original,
input$complete_cutoff
rv$data_original
),
handlerExpr = {
shiny::req(rv$data_original)

View file

@ -68,6 +68,8 @@ ui_elements <- list(
condition = "input.source=='redcap'",
DT::DTOutput(outputId = "redcap_prev")
),
shiny::conditionalPanel(
condition = "output.data_loaded == true",
shiny::br(),
shiny::br(),
shiny::h5("Specify variables to include"),
@ -84,7 +86,7 @@ ui_elements <- list(
shinyWidgets::noUiSliderInput(
inputId = "complete_cutoff",
label = NULL,
update_on = "change",
update_on = "end",
min = 0,
max = 100,
step = 5,
@ -92,12 +94,13 @@ ui_elements <- list(
format = shinyWidgets::wNumbFormat(decimals = 0),
color = datamods:::get_primary_color()
),
shiny::helpText("Filter variables with completeness above the specified percentage."),
shiny::helpText("Exclude variables with completeness below the specified percentage."),
shiny::br(),
shiny::br(),
shiny::uiOutput(outputId = "import_var"),
shiny::uiOutput(outputId = "data_info_import", inline = TRUE)
)
)
),
shiny::br(),
shiny::br(),
@ -180,90 +183,47 @@ ui_elements <- list(
fluidRow(
shiny::column(
width = 9,
shiny::tags$p(shiny::markdown("Below, are several options to update variables (rename, set new labels (for nicer tables in the report) and change variable classes (numeric, factor/categorical etc.).), modify factor/categorical variables as well as create new factor from a continous variable or new variables with *R* code."))
shiny::tags$p(shiny::markdown("Below, are several options for simple data manipulation like update variables by renaming, creating new labels (for nicer tables in the report) and changing variable classes (numeric, factor/categorical etc.)."),
shiny::tags$p("There are also more advanced options to modify factor/categorical variables as well as create new factor from a continous variable or new variables with *R* code. At the bottom you can restore the original data."))
)
),
shiny::tags$br(),
shiny::tags$br(),
# shiny::tags$br(),
update_variables_ui("modal_variables"),
shiny::tags$br(),
shiny::tags$br(),
fluidRow(
tags$h4("Advanced data manipulation"),
shiny::tags$br(),
shiny::tags$br(),
shiny::fluidRow(
shiny::column(
width = 2
),
shiny::column(
width = 8,
tags$h4("Advanced data manipulation"),
width = 4,
shiny::actionButton(
inputId = "modal_update",
label = "Reorder factor levels",
width = "100%"
),
shiny::tags$br(),
fluidRow(
shiny::column(
width = 6,
# tags$h4("Update or modify variables"),
# shiny::tags$br(),
# shiny::actionButton(
# inputId = "modal_variables",
# label = "Subset, rename and change class/type",
# width = "100%"
# ),
# shiny::tags$br(),
# shiny::helpText("Subset variables, rename variables and labels, and apply new class to variables"),
# shiny::tags$br(),
# shiny::tags$br(),
shiny::actionButton(
inputId = "modal_update",
label = "Reorder factor levels",
width = "100%"
),
shiny::tags$br(),
shiny::helpText("Reorder the levels of factor/categorical variables."),
shiny::tags$br(),
shiny::tags$br(),
shiny::actionButton(
inputId = "data_reset",
label = "Restore original data",
width = "100%"
),
shiny::tags$br(),
shiny::helpText("Reset to original imported dataset. Careful! There is no un-doing."),
shiny::tags$br(),
shiny::tags$br()
),
shiny::column(
width = 6,
# tags$h4("Create new variables"),
# shiny::tags$br(),
shiny::actionButton(
inputId = "modal_cut",
label = "New factor",
width = "100%"
),
shiny::tags$br(),
shiny::helpText("Create factor/categorical variable from a continous variable (number/date/time)."),
shiny::tags$br(),
shiny::tags$br(),
shiny::actionButton(
inputId = "modal_column",
label = "New variable",
width = "100%"
),
shiny::tags$br(),
shiny::helpText(shiny::markdown("Create a new variable/column based on an *R*-expression.")),
shiny::tags$br(),
shiny::tags$br()
)
) # ,
# tags$h4("Restore"),
# shiny::actionButton(
# inputId = "data_reset",
# label = "Restore original data",
# width = "100%"
# ),
# shiny::tags$br(),
# shiny::helpText("Reset to original imported dataset. Careful! There is no un-doing.")
shiny::helpText("Reorder the levels of factor/categorical variables."),
),
shiny::column(
width = 2
width = 4,
shiny::actionButton(
inputId = "modal_cut",
label = "New factor",
width = "100%"
),
shiny::tags$br(),
shiny::helpText("Create factor/categorical variable from a continous variable (number/date/time).")
),
shiny::column(
width = 4,
shiny::actionButton(
inputId = "modal_column",
label = "New variable",
width = "100%"
),
shiny::tags$br(),
shiny::helpText(shiny::markdown("Create a new variable/column based on an *R*-expression."))
)
),
shiny::tags$br(),
@ -271,24 +231,32 @@ ui_elements <- list(
tags$h4("Compare modified data to original"),
shiny::tags$br(),
shiny::tags$p(
"Here is a overview of the original vs the modified data."
"Raw print of the original vs the modified data."
),
shiny::tags$br(),
shiny::tags$br(),
fluidRow(
column(
shiny::fluidRow(
shiny::column(
width = 6,
tags$b("Original data:"),
shiny::tags$b("Original data:"),
# verbatimTextOutput("original"),
verbatimTextOutput("original_str")
shiny::verbatimTextOutput("original_str")
),
column(
shiny::column(
width = 6,
tags$b("Modified data:"),
shiny::tags$b("Modified data:"),
# verbatimTextOutput("modified"),
verbatimTextOutput("modified_str")
shiny::verbatimTextOutput("modified_str")
)
)
),
shiny::tags$br(),
shiny::actionButton(
inputId = "data_reset",
label = "Restore original data",
width = "100%"
),
shiny::tags$br(),
shiny::helpText("Reset to original imported dataset. Careful! There is no un-doing."),
shiny::tags$br()
)
)
),

24
man/if_not_missing.Rd Normal file
View file

@ -0,0 +1,24 @@
% Generated by roxygen2: do not edit by hand
% Please edit documentation in R/helpers.R
\name{if_not_missing}
\alias{if_not_missing}
\title{Return if available}
\usage{
if_not_missing(data, default = NULL)
}
\arguments{
\item{data}{vector}
\item{default}{assigned value for missings}
}
\value{
vector
}
\description{
Return if available
}
\examples{
NULL |> if_not_missing("new")
c(2,"a",NA) |> if_not_missing()
"See" |> if_not_missing()
}

View file

@ -16,6 +16,17 @@
\item{x}{(\code{tbl_regression}, \code{tbl_uvregression})\cr
A 'tbl_regression' or 'tbl_uvregression' object}
\item{plot_ref}{(scalar \code{logical})\cr
plot reference values}
\item{remove_header_rows}{(scalar \code{logical})\cr
logical indicating whether to remove header rows
for categorical variables. Default is \code{TRUE}}
\item{remove_reference_rows}{(scalar \code{logical})\cr
logical indicating whether to remove reference rows
for categorical variables. Default is \code{FALSE}.}
\item{...}{arguments passed to \code{ggstats::ggcoef_plot(...)}}
}
\value{

View file

@ -6,7 +6,7 @@
\alias{redcap_demo_app}
\title{Shiny module to browser and export REDCap data}
\usage{
m_redcap_readUI(id, title = TRUE)
m_redcap_readUI(id, title = TRUE, url = NULL)
m_redcap_readServer(id)

View file

@ -9,6 +9,7 @@ vignette: >
```{r setup, include=FALSE}
knitr::opts_chunk$set(echo = TRUE,eval = FALSE)
source(here::here("functions.R"))
```
# Getting started with ***FreesearchR***
@ -57,7 +58,25 @@ Currently several data file formats are supported for easy import (csv, txt, xls
## Visualise
- Would be nice to have a table of possible plots, their description and data options
Below are the available plot types listed.
```{r echo = FALSE, eval = TRUE}
c("continuous", "dichotomous", "ordinal", "categorical") |>
lapply(\(.x){
dplyr::bind_cols(
dplyr::tibble("Data type"=.x),
supported_plots() |>
lapply(\(.y){
if (.x %in% .y$primary.type){
.y[c("descr","note")]|> dplyr::bind_cols()
}
})|>
dplyr::bind_rows() |>
setNames(c("Plot type","Description")))
}) |>
dplyr::bind_rows() |>
toastui::datagrid(filters=TRUE,theme="striped")
```
## Regression