#' 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, ...) { ns <- shiny::NS(id) 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("gear"), 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 ) ), do.call( bslib::accordion_panel, c( list( 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 #' #' @param data data #' @param output.format output format #' #' @name data-missings #' @returns shiny server module #' @export data_missings_server <- function(id, data, max_level = 20, ...) { shiny::moduleServer( id = id, module = function(input, output, session) { ns <- session$ns datar <- if (is.reactive(data)) data else reactive(data) rv <- shiny::reactiveValues( data = NULL, table = NULL ) ## Notes ## ## Code export is still missing ## Direct table export would be nice shiny::observe( output$missings_method <- shiny::renderUI({ shiny::req(data()) vectorSelectInput( inputId = ns("missings_method"), label = i18n$t("Analysis method for missingness overview"), choices = setNames( c( "predictors", "outcome" ), c( i18n$t("Overview of missings across variables"), i18n$t("Overview of difference in variables by missing status in outcome") ) ) ) }) ) shiny::observe({ output$missings_var <- shiny::renderUI({ shiny::req(datar()) shiny::req(input$missings_method) # browser() if (input$missings_method == "predictors") { label <- i18n$t("Select a variable for grouped overview") df <- data_type_filter(data(), type = c("categorical", "dichotomous")) col_subset <- c("none", names(df)) } else { label <- i18n$t("Select outcome variable for overview") df <- datar()[apply(datar(), 2, anyNA)] col_subset <- names(df) } columnSelectInput( inputId = ns("missings_var"), label = label, data = df, col_subset = col_subset, none_label = i18n$t("No variable") ) }) }) 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())) { if (input$missings_method == "predictors") { title <- i18n$t("Overview of missing observations") } else { title <- i18n$t("No outcome measure chosen") } } 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 }) } ) table_download_server( id = "tbl_dwn", data = shiny::reactive(rv$table), file_name = "missings_table" ) return(shiny::reactive(rv$table)) } ) } missing_demo_app <- function() { ui <- do.call( bslib::page, c( list( title = i18n$t("Missings"), icon = bsicons::bs_icon("x-circle") ), data_missings_ui(id = "data"), gt::gt_output("table_p") ) ) server <- function(input, output, session) { data_demo <- mtcars data_demo[sample(1:32, 10), "cyl"] <- NA data_demo[sample(1:32, 8), "vs"] <- NA rv <- shiny::reactiveValues( table = NULL ) rv$table <- data_missings_server(id = "data", data = data_demo) output$table_p <- gt::render_gt({ rv$table }) # 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") # } # ) # }) } shiny::shinyApp(ui, server) } # missing_demo_app() #' Pairwise comparison of missings across covariables #' #' @param data data frame #' @param by_var variable to stratify by missingness #' #' @returns gtsummary list object #' @export #' 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){ if (is.factor(.x)) { cut_var(.x, breaks = 20, type = "top") } else { .x } }) |> dplyr::bind_cols() 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)) }