mirror of
https://github.com/agdamsbo/FreesearchR.git
synced 2026-06-19 04:27:30 +02:00
feat: the missingness module was overhauled to include two different analysis methods and a better, standalone module
Some checks are pending
pkgdown.yaml / pkgdown (push) Waiting to run
Some checks are pending
pkgdown.yaml / pkgdown (push) Waiting to run
This commit is contained in:
parent
fab5c6cf22
commit
af523edc00
25 changed files with 1049 additions and 720 deletions
|
|
@ -1,18 +1,46 @@
|
|||
#' Data correlations evaluation module
|
||||
#'
|
||||
#' @param id Module id
|
||||
#' @param ... additional UI elements to show before the table overview
|
||||
#'
|
||||
#' @name data-missings
|
||||
#' @returns Shiny ui module
|
||||
#' @export
|
||||
data_missings_ui <- function(id) {
|
||||
data_missings_ui <- function(id, ...) {
|
||||
ns <- shiny::NS(id)
|
||||
|
||||
shiny::tagList(
|
||||
gt::gt_output(outputId = ns("missings_table"))
|
||||
list(
|
||||
bslib::layout_sidebar(
|
||||
sidebar = bslib::sidebar(
|
||||
bslib::accordion(
|
||||
id = ns("acc_mis"),
|
||||
open = "acc_chars",
|
||||
multiple = FALSE,
|
||||
bslib::accordion_panel(
|
||||
value = "acc_pan_mis",
|
||||
title = "Settings",
|
||||
icon = bsicons::bs_icon("x-circle"),
|
||||
shiny::uiOutput(ns("missings_method")),
|
||||
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.")),
|
||||
shiny::br(),
|
||||
shiny::actionButton(
|
||||
inputId = ns("act_miss"),
|
||||
label = i18n$t("Evaluate"),
|
||||
width = "100%",
|
||||
icon = shiny::icon("calculator"),
|
||||
disabled = FALSE
|
||||
)
|
||||
)
|
||||
)
|
||||
),
|
||||
...,
|
||||
gt::gt_output(outputId = ns("missings_table"))
|
||||
)
|
||||
)
|
||||
}
|
||||
|
||||
## This should really just be rebuild to only contain a function
|
||||
|
||||
#'
|
||||
#' @param data data
|
||||
|
|
@ -23,108 +51,192 @@ data_missings_ui <- function(id) {
|
|||
#' @export
|
||||
data_missings_server <- function(id,
|
||||
data,
|
||||
variable,
|
||||
max_level=20,
|
||||
max_level = 20,
|
||||
...) {
|
||||
shiny::moduleServer(
|
||||
id = id,
|
||||
module = function(input, output, session) {
|
||||
# ns <- session$ns
|
||||
ns <- session$ns
|
||||
|
||||
datar <- if (is.reactive(data)) data else reactive(data)
|
||||
variabler <- if (is.reactive(variable)) variable else reactive(variable)
|
||||
|
||||
rv <- shiny::reactiveValues(
|
||||
data = NULL,
|
||||
table = NULL
|
||||
)
|
||||
|
||||
rv$data <- shiny::reactive({
|
||||
df_tbl <- datar()
|
||||
by_var <- variabler()
|
||||
## Notes
|
||||
##
|
||||
## Code export is still missing
|
||||
## Direct table export would be nice
|
||||
|
||||
tryCatch(
|
||||
{
|
||||
out <- compare_missings(df_tbl,by_var,max_level = max_level)
|
||||
},
|
||||
error = function(err) {
|
||||
showNotification(paste0("Error: ", err), type = "err")
|
||||
}
|
||||
)
|
||||
shiny::observe(
|
||||
output$missings_method <- shiny::renderUI({
|
||||
shiny::req(data())
|
||||
vectorSelectInput(
|
||||
inputId = ns("missings_method"),
|
||||
label = i18n$t("Select missings analysis to apply"),
|
||||
choices = setNames(
|
||||
c(
|
||||
"predictors",
|
||||
"outcome"
|
||||
),
|
||||
c(
|
||||
i18n$t("Variables"),
|
||||
i18n$t("By outcome")
|
||||
)
|
||||
)
|
||||
)
|
||||
})
|
||||
)
|
||||
|
||||
out
|
||||
})
|
||||
|
||||
output$missings_table <- gt::render_gt({
|
||||
shiny::req(datar)
|
||||
shiny::req(variabler)
|
||||
|
||||
if (is.null(variabler()) || variabler() == "" || !variabler() %in% names(datar())) {
|
||||
tbl <- rv$data()
|
||||
if (anyNA(datar())){
|
||||
title <- i18n$t("No variable chosen for analysis")
|
||||
shiny::observe({
|
||||
output$missings_var <- shiny::renderUI({
|
||||
shiny::req(datar())
|
||||
shiny::req(input$missings_method)
|
||||
# browser()
|
||||
if (input$missings_method == "predictors") {
|
||||
df <- data_type_filter(data(), type = c("categorical", "dichotomous"))
|
||||
} else {
|
||||
title <- i18n$t("No missing observations")
|
||||
df <- datar()[apply(datar(), 2, anyNA)]
|
||||
}
|
||||
} else {
|
||||
tbl <- rv$data()|>
|
||||
gtsummary::bold_p()
|
||||
title <- glue::glue(i18n$t("Missing vs non-missing observations in the variable **'{variabler()}'**"))
|
||||
}
|
||||
|
||||
out <- tbl |>
|
||||
gtsummary::as_gt() |>
|
||||
gt::tab_header(title = gt::md(title))
|
||||
|
||||
rv$table <- out
|
||||
|
||||
out
|
||||
columnSelectInput(
|
||||
inputId = ns("missings_var"),
|
||||
label = i18n$t("Select variable to stratify analysis"),
|
||||
data = df,
|
||||
col_subset = c("none", names(df)),
|
||||
none_label = i18n$t("No variable")
|
||||
)
|
||||
})
|
||||
})
|
||||
|
||||
return(reactive(rv$table))
|
||||
|
||||
shiny::observeEvent(
|
||||
list(input$act_miss),
|
||||
{
|
||||
shiny::req(datar())
|
||||
shiny::req(input$missings_var)
|
||||
# browser()
|
||||
df_tbl <- datar()
|
||||
by_var <- input$missings_var
|
||||
|
||||
parameters <- list(
|
||||
by_var = by_var,
|
||||
max_level = max_level,
|
||||
type = input$missings_method
|
||||
)
|
||||
|
||||
tryCatch(
|
||||
{
|
||||
shiny::withProgress(message = i18n$t("Calculating. Hold tight for a moment.."), {
|
||||
out <- do.call(
|
||||
compare_missings,
|
||||
modifyList(parameters, list(data = df_tbl))
|
||||
)
|
||||
})
|
||||
},
|
||||
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(variabler()) || variabler() == "" || !variabler() %in% names(data()) || variabler() == "none") {
|
||||
# tbl <- rv$data()
|
||||
if (anyNA(datar())) {
|
||||
title <- i18n$t("No variable chosen for analysis")
|
||||
} else {
|
||||
title <- i18n$t("No missing observations")
|
||||
}
|
||||
} else {
|
||||
## Due to reactivity, the table updates too quickly. this mitigates that issue..
|
||||
|
||||
|
||||
if (input$missings_var == "predictors") {
|
||||
title <- glue::glue(i18n$t("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()
|
||||
}
|
||||
|
||||
|
||||
out <- tbl |>
|
||||
gtsummary::as_gt() |>
|
||||
gt::tab_header(title = gt::md(attr(tbl, "tbl_title")))
|
||||
|
||||
attr(out, "strat_var") <- input$missings_var
|
||||
|
||||
rv$table <- out
|
||||
|
||||
out
|
||||
})
|
||||
}
|
||||
)
|
||||
|
||||
return(shiny::reactive(rv$table))
|
||||
}
|
||||
)
|
||||
}
|
||||
|
||||
|
||||
missing_demo_app <- function() {
|
||||
ui <- shiny::fluidPage(
|
||||
shiny::actionButton(
|
||||
inputId = "modal_missings",
|
||||
label = "Browse data",
|
||||
width = "100%",
|
||||
disabled = FALSE
|
||||
),
|
||||
shiny::selectInput(
|
||||
inputId = "missings_var",
|
||||
label = "Select variable to stratify analysis", choices = c("cyl", "vs")
|
||||
),
|
||||
data_missings_ui("data")
|
||||
ui <- do.call(
|
||||
bslib::page,
|
||||
c(
|
||||
list(
|
||||
title = i18n$t("Missings"),
|
||||
icon = bsicons::bs_icon("x-circle")
|
||||
),
|
||||
data_missings_ui(id = "data")
|
||||
)
|
||||
)
|
||||
server <- function(input, output, session) {
|
||||
data_demo <- mtcars
|
||||
data_demo[sample(1:32, 10), "cyl"] <- NA
|
||||
data_demo[sample(1:32, 8), "vs"] <- NA
|
||||
|
||||
data_missings_server(id = "data", data = data_demo, variable = shiny::reactive(input$missings_var))
|
||||
data_missings_server(id = "data", data = data_demo)
|
||||
|
||||
visual_summary_server(id = "visual", data = data_demo)
|
||||
# visual_summary_server(id = "visual", data = data_demo)
|
||||
|
||||
observeEvent(input$modal_missings, {
|
||||
tryCatch(
|
||||
{
|
||||
modal_visual_summary(id = "visual")
|
||||
},
|
||||
error = function(err) {
|
||||
showNotification(paste0("We encountered the following error browsing your data: ", err), type = "err")
|
||||
}
|
||||
)
|
||||
})
|
||||
# observeEvent(input$modal_missings, {
|
||||
# tryCatch(
|
||||
# {
|
||||
# modal_visual_summary(id = "visual")
|
||||
# },
|
||||
# error = function(err) {
|
||||
# showNotification(paste0("We encountered the following error browsing your data: ", err), type = "err")
|
||||
# }
|
||||
# )
|
||||
# })
|
||||
}
|
||||
shiny::shinyApp(ui, server)
|
||||
}
|
||||
|
||||
missing_demo_app()
|
||||
# missing_demo_app()
|
||||
|
||||
#' Pairwise comparison of missings across covariables
|
||||
#'
|
||||
|
|
@ -134,24 +246,76 @@ missing_demo_app()
|
|||
#' @returns gtsummary list object
|
||||
#' @export
|
||||
#'
|
||||
compare_missings <- function(data,by_var,max_level=20){
|
||||
compare_missings <- function(
|
||||
data,
|
||||
by_var,
|
||||
max_level = 20,
|
||||
type = c("predictors", "outcome")
|
||||
) {
|
||||
type <- match.arg(type)
|
||||
|
||||
if (!is.null(by_var) && by_var != "" && by_var %in% names(data)) {
|
||||
data <- data |>
|
||||
lapply(\(.x){
|
||||
# browser()
|
||||
if (is.factor(.x)){
|
||||
cut_var(.x,breaks=20,type="top")
|
||||
if (is.factor(.x)) {
|
||||
cut_var(.x, breaks = 20, type = "top")
|
||||
} else {
|
||||
.x
|
||||
}
|
||||
}) |> dplyr::bind_cols()
|
||||
}) |>
|
||||
dplyr::bind_cols()
|
||||
|
||||
data[[by_var]] <- ifelse(is.na(data[[by_var]]), "Missing", "Non-missing")
|
||||
if (type == "predictors") {
|
||||
data <- missings_logic_across(data, exclude = by_var)
|
||||
} else {
|
||||
data[[by_var]] <- ifelse(is.na(data[[by_var]]), "Missing", "Non-missing")
|
||||
}
|
||||
|
||||
out <- gtsummary::tbl_summary(data, by = by_var) |>
|
||||
gtsummary::add_p()
|
||||
} else {
|
||||
if (type == "predictors") {
|
||||
data <- missings_logic_across(data)
|
||||
}
|
||||
|
||||
out <- gtsummary::tbl_summary(data)
|
||||
}
|
||||
|
||||
out
|
||||
}
|
||||
|
||||
#' Converting all variables to logicals by missing status
|
||||
#'
|
||||
#' @param data data
|
||||
#' @param exclude character vector of variable names to be excluded
|
||||
#'
|
||||
#' @returns data frame
|
||||
#' @export
|
||||
#'
|
||||
#' @examples
|
||||
#' mtcars |> missings_logic_across("cyl")
|
||||
#' ## gtsummary::trial |>
|
||||
#' ## missings_logic_across() |>
|
||||
#' ## gtsummary::tbl_summary()
|
||||
missings_logic_across <- function(data, exclude = NULL) {
|
||||
# This function includes a approach way to preserve variable labels
|
||||
names(data) |>
|
||||
lapply(\(.x){
|
||||
# browser()
|
||||
# Saving original labels
|
||||
lab <- REDCapCAST::get_attr(data[[.x]], attr = "label")
|
||||
if (!.x %in% exclude) {
|
||||
out <- is.na(data[[.x]])
|
||||
} else {
|
||||
out <- data[[.x]]
|
||||
}
|
||||
if (!is.na(lab)) {
|
||||
# Restoring original labels, if not NA
|
||||
REDCapCAST::set_attr(data = out, label = lab, attr = "label", overwrite = TRUE)
|
||||
} else {
|
||||
out
|
||||
}
|
||||
}) |>
|
||||
dplyr::bind_cols(.name_repair = "unique_quiet") |>
|
||||
setNames(names(data))
|
||||
}
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue