mirror of
https://github.com/agdamsbo/FreesearchR.git
synced 2026-06-19 04:27:30 +02:00
feat: collapsed options and alert when no missings
This commit is contained in:
parent
1b31743898
commit
13c5603245
1 changed files with 174 additions and 154 deletions
|
|
@ -9,45 +9,49 @@
|
||||||
data_missings_ui <- function(id, ...) {
|
data_missings_ui <- function(id, ...) {
|
||||||
ns <- shiny::NS(id)
|
ns <- shiny::NS(id)
|
||||||
|
|
||||||
list(
|
list(bslib::layout_sidebar(
|
||||||
bslib::layout_sidebar(
|
uiOutput(outputId = ns("feedback")),
|
||||||
sidebar = bslib::sidebar(
|
sidebar = bslib::sidebar(
|
||||||
bslib::accordion(
|
bslib::accordion(
|
||||||
id = ns("acc_mis"),
|
id = ns("acc_mis"),
|
||||||
open = "acc_chars",
|
open = "acc_chars",
|
||||||
multiple = FALSE,
|
multiple = FALSE,
|
||||||
bslib::accordion_panel(
|
bslib::accordion_panel(
|
||||||
value = "acc_pan_mis",
|
value = "acc_pan_mis",
|
||||||
title = "Settings",
|
title = "Settings",
|
||||||
icon = bsicons::bs_icon("gear"),
|
icon = bsicons::bs_icon("gear"),
|
||||||
|
shiny::conditionalPanel(
|
||||||
|
condition = "output.missings == true",
|
||||||
shiny::uiOutput(ns("missings_method")),
|
shiny::uiOutput(ns("missings_method")),
|
||||||
shiny::uiOutput(ns("missings_var")),
|
shiny::uiOutput(ns("missings_var")),
|
||||||
shiny::helpText(i18n$t("Evaluate missingness by either comparing missing values across variables (optionally grouped by af categorical or dichotomous variable) or compare variables grouped by the missing status (missing or not) of an outcome variable. If there is a significant difference i the missingness, this may cause a bias in you data and should be considered carefully interpreting the data and analyses as data may not be missing at random.")),
|
ns = ns
|
||||||
shiny::br(),
|
),
|
||||||
shiny::actionButton(
|
shiny::helpText(
|
||||||
inputId = ns("act_miss"),
|
i18n$t(
|
||||||
label = i18n$t("Evaluate"),
|
"Evaluate missingness by either comparing missing values across variables (optionally grouped by af categorical or dichotomous variable) or compare variables grouped by the missing status (missing or not) of an outcome variable. If there is a significant difference i the missingness, this may cause a bias in you data and should be considered carefully interpreting the data and analyses as data may not be missing at random."
|
||||||
width = "100%",
|
|
||||||
icon = shiny::icon("calculator"),
|
|
||||||
disabled = FALSE
|
|
||||||
)
|
)
|
||||||
),
|
),
|
||||||
do.call(
|
shiny::br(),
|
||||||
bslib::accordion_panel,
|
shiny::actionButton(
|
||||||
c(
|
inputId = ns("act_miss"),
|
||||||
list(
|
label = i18n$t("Evaluate"),
|
||||||
title = "Download",
|
width = "100%",
|
||||||
icon = bsicons::bs_icon("file-earmark-arrow-down")
|
icon = shiny::icon("calculator"),
|
||||||
),
|
disabled = FALSE
|
||||||
table_download_ui(id = ns("tbl_dwn"), title = NULL)
|
|
||||||
)
|
|
||||||
)
|
)
|
||||||
)
|
),
|
||||||
),
|
do.call(bslib::accordion_panel, c(
|
||||||
...,
|
list(
|
||||||
gt::gt_output(outputId = ns("missings_table"))
|
title = "Download",
|
||||||
)
|
icon = bsicons::bs_icon("file-earmark-arrow-down")
|
||||||
)
|
),
|
||||||
|
table_download_ui(id = ns("tbl_dwn"), title = NULL)
|
||||||
|
))
|
||||||
|
)
|
||||||
|
),
|
||||||
|
...,
|
||||||
|
gt::gt_output(outputId = ns("missings_table"))
|
||||||
|
))
|
||||||
}
|
}
|
||||||
|
|
||||||
## This should really just be rebuild to only contain a function
|
## This should really just be rebuild to only contain a function
|
||||||
|
|
@ -59,46 +63,65 @@ data_missings_ui <- function(id, ...) {
|
||||||
#' @name data-missings
|
#' @name data-missings
|
||||||
#' @returns shiny server module
|
#' @returns shiny server module
|
||||||
#' @export
|
#' @export
|
||||||
data_missings_server <- function(id,
|
data_missings_server <- function(id, data, max_level = 20, ...) {
|
||||||
data,
|
|
||||||
max_level = 20,
|
|
||||||
...) {
|
|
||||||
shiny::moduleServer(
|
shiny::moduleServer(
|
||||||
id = id,
|
id = id,
|
||||||
module = function(input, output, session) {
|
module = function(input, output, session) {
|
||||||
ns <- session$ns
|
ns <- session$ns
|
||||||
|
|
||||||
datar <- if (is.reactive(data)) data else reactive(data)
|
datar <- if (is.reactive(data))
|
||||||
|
data
|
||||||
|
else
|
||||||
|
reactive(data)
|
||||||
|
|
||||||
rv <- shiny::reactiveValues(
|
rv <- shiny::reactiveValues(data = NULL,
|
||||||
data = NULL,
|
table = NULL,
|
||||||
table = NULL
|
feedback = NULL)
|
||||||
|
|
||||||
|
## Case with no missings
|
||||||
|
|
||||||
|
info_alert <- shinyWidgets::alert(
|
||||||
|
status = "info",
|
||||||
|
phosphoricons::ph("question"),
|
||||||
|
i18n$t("You have provided a complete dataset with no missing values.")
|
||||||
)
|
)
|
||||||
|
|
||||||
|
output$missings <- shiny::reactive({
|
||||||
|
shiny::req(data())
|
||||||
|
any(is.na(data()))
|
||||||
|
})
|
||||||
|
shiny::outputOptions(output, "missings", suspendWhenHidden = FALSE)
|
||||||
|
|
||||||
|
observe({
|
||||||
|
shiny::req(data())
|
||||||
|
if (!any(is.na(data()))) {
|
||||||
|
rv$feedback <- info_alert
|
||||||
|
} else {
|
||||||
|
rv$feedback <- NULL
|
||||||
|
}
|
||||||
|
})
|
||||||
|
|
||||||
|
|
||||||
|
output$feedback <- renderUI(rv$feedback)
|
||||||
|
|
||||||
## Notes
|
## Notes
|
||||||
##
|
##
|
||||||
## Code export is still missing
|
## Code export is still missing
|
||||||
## Direct table export would be nice
|
## Direct table export would be nice
|
||||||
|
|
||||||
shiny::observe(
|
shiny::observe(output$missings_method <- shiny::renderUI({
|
||||||
output$missings_method <- shiny::renderUI({
|
shiny::req(data())
|
||||||
shiny::req(data())
|
vectorSelectInput(
|
||||||
vectorSelectInput(
|
inputId = ns("missings_method"),
|
||||||
inputId = ns("missings_method"),
|
label = i18n$t("Analysis method for missingness overview"),
|
||||||
label = i18n$t("Analysis method for missingness overview"),
|
choices = setNames(c("predictors", "outcome"), c(
|
||||||
choices = setNames(
|
i18n$t("Overview of missings across variables"),
|
||||||
c(
|
i18n$t(
|
||||||
"predictors",
|
"Overview of difference in variables by missing status in outcome"
|
||||||
"outcome"
|
|
||||||
),
|
|
||||||
c(
|
|
||||||
i18n$t("Overview of missings across variables"),
|
|
||||||
i18n$t("Overview of difference in variables by missing status in outcome")
|
|
||||||
)
|
|
||||||
)
|
)
|
||||||
)
|
))
|
||||||
})
|
)
|
||||||
)
|
}))
|
||||||
|
|
||||||
shiny::observe({
|
shiny::observe({
|
||||||
output$missings_var <- shiny::renderUI({
|
output$missings_var <- shiny::renderUI({
|
||||||
|
|
@ -125,94 +148,93 @@ data_missings_server <- function(id,
|
||||||
})
|
})
|
||||||
|
|
||||||
|
|
||||||
shiny::observeEvent(
|
shiny::observeEvent(list(input$act_miss), {
|
||||||
list(input$act_miss),
|
shiny::req(datar())
|
||||||
{
|
shiny::req(input$missings_var)
|
||||||
shiny::req(datar())
|
# browser()
|
||||||
shiny::req(input$missings_var)
|
df_tbl <- datar()
|
||||||
# browser()
|
by_var <- input$missings_var
|
||||||
df_tbl <- datar()
|
|
||||||
by_var <- input$missings_var
|
|
||||||
|
|
||||||
parameters <- list(
|
parameters <- list(
|
||||||
by_var = by_var,
|
by_var = by_var,
|
||||||
max_level = max_level,
|
max_level = max_level,
|
||||||
type = input$missings_method
|
type = input$missings_method
|
||||||
)
|
)
|
||||||
|
|
||||||
tryCatch(
|
tryCatch({
|
||||||
{
|
shiny::withProgress(message = i18n$t("Calculating. Hold tight for a moment.."), {
|
||||||
shiny::withProgress(message = i18n$t("Calculating. Hold tight for a moment.."), {
|
out <- do.call(compare_missings, modifyList(parameters, list(data = df_tbl)))
|
||||||
out <- do.call(
|
})
|
||||||
compare_missings,
|
}, error = function(err) {
|
||||||
modifyList(parameters, list(data = df_tbl))
|
showNotification(paste0("Error: ", err), type = "err")
|
||||||
)
|
})
|
||||||
})
|
|
||||||
},
|
|
||||||
error = function(err) {
|
|
||||||
showNotification(paste0("Error: ", err), type = "err")
|
|
||||||
}
|
|
||||||
)
|
|
||||||
|
|
||||||
if (is.null(input$missings_var) || input$missings_var == "" || !input$missings_var %in% names(datar()) || input$missings_var == "none") {
|
if (is.null(input$missings_var) ||
|
||||||
# if (is.null(variabler()) || variabler() == "" || !variabler() %in% names(data()) || variabler() == "none") {
|
input$missings_var == "" ||
|
||||||
# tbl <- rv$data()
|
!input$missings_var %in% names(datar()) ||
|
||||||
if (anyNA(datar())) {
|
input$missings_var == "none") {
|
||||||
if (input$missings_method == "predictors") {
|
# if (is.null(variabler()) || variabler() == "" || !variabler() %in% names(data()) || variabler() == "none") {
|
||||||
title <- i18n$t("Overview of missing observations")
|
# tbl <- rv$data()
|
||||||
} else {
|
if (anyNA(datar())) {
|
||||||
title <- i18n$t("No outcome measure chosen")
|
if (input$missings_method == "predictors") {
|
||||||
}
|
title <- i18n$t("Overview of missing observations")
|
||||||
} else {
|
} else {
|
||||||
title <- i18n$t("No missing observations")
|
title <- i18n$t("No outcome measure chosen")
|
||||||
}
|
}
|
||||||
} else {
|
} else {
|
||||||
## Due to reactivity, the table updates too quickly. this mitigates that issue..
|
title <- i18n$t("No missing observations")
|
||||||
|
}
|
||||||
|
} else {
|
||||||
|
## Due to reactivity, the table updates too quickly. this mitigates that issue..
|
||||||
|
|
||||||
|
|
||||||
if (input$missings_var == "predictors") {
|
if (input$missings_var == "predictors") {
|
||||||
title <- glue::glue(i18n$t("Missings across variables by the variable **'{input$missings_var}'**"))
|
title <- glue::glue(
|
||||||
} else {
|
i18n$t(
|
||||||
title <- glue::glue(i18n$t("Missing vs non-missing observations in the variable **'{input$missings_var}'**"))
|
"Missings across variables by the variable **'{input$missings_var}'**"
|
||||||
}
|
)
|
||||||
|
)
|
||||||
|
} else {
|
||||||
|
title <- glue::glue(
|
||||||
|
i18n$t(
|
||||||
|
"Missing vs non-missing observations in the variable **'{input$missings_var}'**"
|
||||||
|
)
|
||||||
|
)
|
||||||
|
}
|
||||||
|
}
|
||||||
|
|
||||||
|
attr(out, "tbl_title") <- title
|
||||||
|
|
||||||
|
rv$data <- shiny::reactive(out)
|
||||||
|
})
|
||||||
|
|
||||||
|
shiny::observeEvent(list(
|
||||||
|
# input$act_miss
|
||||||
|
rv$data
|
||||||
|
), {
|
||||||
|
output$missings_table <- gt::render_gt({
|
||||||
|
shiny::req(rv$data)
|
||||||
|
# shiny::req(input$missings_var)
|
||||||
|
# browser()
|
||||||
|
if ("p.value" %in% names(rv$data()[["table_body"]])) {
|
||||||
|
tbl <- rv$data() |>
|
||||||
|
gtsummary::bold_p()
|
||||||
|
} else {
|
||||||
|
tbl <- rv$data()
|
||||||
}
|
}
|
||||||
|
|
||||||
attr(out, "tbl_title") <- title
|
|
||||||
|
|
||||||
rv$data <- shiny::reactive(out)
|
out <- tbl |>
|
||||||
}
|
gtsummary::as_gt() |>
|
||||||
)
|
gt::tab_header(title = gt::md(attr(tbl, "tbl_title")))
|
||||||
|
|
||||||
shiny::observeEvent(
|
attr(out, "strat_var") <- input$missings_var
|
||||||
list(
|
|
||||||
# input$act_miss
|
|
||||||
rv$data
|
|
||||||
),
|
|
||||||
{
|
|
||||||
output$missings_table <- gt::render_gt({
|
|
||||||
shiny::req(rv$data)
|
|
||||||
# shiny::req(input$missings_var)
|
|
||||||
# browser()
|
|
||||||
if ("p.value" %in% names(rv$data()[["table_body"]])) {
|
|
||||||
tbl <- rv$data() |>
|
|
||||||
gtsummary::bold_p()
|
|
||||||
} else {
|
|
||||||
tbl <- rv$data()
|
|
||||||
}
|
|
||||||
|
|
||||||
|
rv$table <- out
|
||||||
|
|
||||||
out <- tbl |>
|
out
|
||||||
gtsummary::as_gt() |>
|
})
|
||||||
gt::tab_header(title = gt::md(attr(tbl, "tbl_title")))
|
})
|
||||||
|
|
||||||
attr(out, "strat_var") <- input$missings_var
|
|
||||||
|
|
||||||
rv$table <- out
|
|
||||||
|
|
||||||
out
|
|
||||||
})
|
|
||||||
}
|
|
||||||
)
|
|
||||||
|
|
||||||
|
|
||||||
table_download_server(
|
table_download_server(
|
||||||
|
|
@ -228,25 +250,20 @@ data_missings_server <- function(id,
|
||||||
|
|
||||||
|
|
||||||
missing_demo_app <- function() {
|
missing_demo_app <- function() {
|
||||||
ui <- do.call(
|
ui <- do.call(bslib::page, c(
|
||||||
bslib::page,
|
list(
|
||||||
c(
|
title = i18n$t("Missings"),
|
||||||
list(
|
icon = bsicons::bs_icon("x-circle")
|
||||||
title = i18n$t("Missings"),
|
),
|
||||||
icon = bsicons::bs_icon("x-circle")
|
data_missings_ui(id = "data"),
|
||||||
),
|
gt::gt_output("table_p")
|
||||||
data_missings_ui(id = "data"),
|
))
|
||||||
gt::gt_output("table_p")
|
|
||||||
)
|
|
||||||
)
|
|
||||||
server <- function(input, output, session) {
|
server <- function(input, output, session) {
|
||||||
data_demo <- mtcars
|
data_demo <- mtcars
|
||||||
data_demo[sample(1:32, 10), "cyl"] <- NA
|
data_demo[sample(1:32, 10), "cyl"] <- NA
|
||||||
data_demo[sample(1:32, 8), "vs"] <- NA
|
data_demo[sample(1:32, 8), "vs"] <- NA
|
||||||
|
|
||||||
rv <- shiny::reactiveValues(
|
rv <- shiny::reactiveValues(table = NULL)
|
||||||
table = NULL
|
|
||||||
)
|
|
||||||
|
|
||||||
rv$table <- data_missings_server(id = "data", data = data_demo)
|
rv$table <- data_missings_server(id = "data", data = data_demo)
|
||||||
|
|
||||||
|
|
@ -280,17 +297,15 @@ missing_demo_app <- function() {
|
||||||
#' @returns gtsummary list object
|
#' @returns gtsummary list object
|
||||||
#' @export
|
#' @export
|
||||||
#'
|
#'
|
||||||
compare_missings <- function(
|
compare_missings <- function(data,
|
||||||
data,
|
by_var,
|
||||||
by_var,
|
max_level = 20,
|
||||||
max_level = 20,
|
type = c("predictors", "outcome")) {
|
||||||
type = c("predictors", "outcome")
|
|
||||||
) {
|
|
||||||
type <- match.arg(type)
|
type <- match.arg(type)
|
||||||
|
|
||||||
if (!is.null(by_var) && by_var != "" && by_var %in% names(data)) {
|
if (!is.null(by_var) && by_var != "" && by_var %in% names(data)) {
|
||||||
data <- data |>
|
data <- data |>
|
||||||
lapply(\(.x){
|
lapply(\(.x) {
|
||||||
if (is.factor(.x)) {
|
if (is.factor(.x)) {
|
||||||
cut_var(.x, breaks = 20, type = "top")
|
cut_var(.x, breaks = 20, type = "top")
|
||||||
} else {
|
} else {
|
||||||
|
|
@ -334,7 +349,7 @@ compare_missings <- function(
|
||||||
missings_logic_across <- function(data, exclude = NULL) {
|
missings_logic_across <- function(data, exclude = NULL) {
|
||||||
# This function includes a approach way to preserve variable labels
|
# This function includes a approach way to preserve variable labels
|
||||||
names(data) |>
|
names(data) |>
|
||||||
lapply(\(.x){
|
lapply(\(.x) {
|
||||||
# browser()
|
# browser()
|
||||||
# Saving original labels
|
# Saving original labels
|
||||||
lab <- REDCapCAST::get_attr(data[[.x]], attr = "label")
|
lab <- REDCapCAST::get_attr(data[[.x]], attr = "label")
|
||||||
|
|
@ -345,7 +360,12 @@ missings_logic_across <- function(data, exclude = NULL) {
|
||||||
}
|
}
|
||||||
if (!is.na(lab)) {
|
if (!is.na(lab)) {
|
||||||
# Restoring original labels, if not NA
|
# Restoring original labels, if not NA
|
||||||
REDCapCAST::set_attr(data = out, label = lab, attr = "label", overwrite = TRUE)
|
REDCapCAST::set_attr(
|
||||||
|
data = out,
|
||||||
|
label = lab,
|
||||||
|
attr = "label",
|
||||||
|
overwrite = TRUE
|
||||||
|
)
|
||||||
} else {
|
} else {
|
||||||
out
|
out
|
||||||
}
|
}
|
||||||
|
|
|
||||||
Loading…
Add table
Add a link
Reference in a new issue