From 2cc4831998a87cea2efac64d0241c467fdff9968 Mon Sep 17 00:00:00 2001 From: Andreas Gammelgaard Damsbo Date: Tue, 23 Sep 2025 12:25:25 +0200 Subject: [PATCH] two additional validation alerts --- R/validation.R | 107 ++++++++++++++++++++++++------------ inst/apps/FreesearchR/app.R | 12 ++-- 2 files changed, 80 insertions(+), 39 deletions(-) diff --git a/R/validation.R b/R/validation.R index 598af029..7929f65a 100644 --- a/R/validation.R +++ b/R/validation.R @@ -97,13 +97,17 @@ validation_server <- function(id, { # browser() to_validate <- data_r() - if (is.reactivevalues(to_validate)) + if (is.reactivevalues(to_validate)) { + to_validate <- reactiveValuesToList(to_validate) + } + if (!is.data.frame(to_validate)) { + # browser() out <- lapply( - reactiveValuesToList(to_validate), - make_validation_alerts) |> - purrr::list_flatten() - - if (length(to_validate) > 0) { + to_validate, + make_validation_alerts + ) |> + purrr::list_flatten() + } else if (length(to_validate) > 0) { out <- make_validation_alerts(to_validate) } valid_ui$x <- tagList(out) @@ -193,12 +197,12 @@ obs_filter_validate <- function(before, after) { #' #' @examples #' df <- mtcars -#' df[1,2:4] <- NA +#' df[1, 2:4] <- NA #' missings_validate(df) -missings_validate <- function(data){ +missings_validate <- function(data) { if (!0 %in% dim(data)) { # browser() - p_miss <- sum(is.na(data))/prod(dim(data))*100 + p_miss <- sum(is.na(data)) / prod(dim(data)) * 100 data.frame( p_miss = p_miss ) |> @@ -215,7 +219,16 @@ missings_validate <- function(data){ } } -corr_pairs_validate <- function(data){ +#' Correlation pairs validation +#' +#' @param data data.frame +#' +#' @returns data.frame +#' @export +#' +#' @examples +#' # correlation_pairs(mtcars) |> corr_pairs_validate() +corr_pairs_validate <- function(data) { data_s <- if (shiny::is.reactive(data)) data() else data if (!0 %in% dim(data_s)) { # browser() @@ -228,6 +241,30 @@ corr_pairs_validate <- function(data){ } } +#' MCAR validation based on a gtsummary table bady +#' +#' @param data data +#' @param outcome outcome variable +#' +#' @returns data.frame +#' @export +#' +mcar_validate <- function(data, outcome=NULL) { + data_s <- if (shiny::is.reactive(data)) data() else data + + if (is.data.frame(data_s) && "p.value" %in% names(data_s) && !is.null(outcome)) { + # browser() + n_nonmcar <- sum(data_s["p.value"][!is.na(data_s["p.value"])] < 0.05) + + data.frame( + n_nonmcar = n_nonmcar, + outcome = outcome + ) + } else { + data.frame(NULL) + } +} + ######################################################################## ############# Collected validation functions in a library-like function @@ -243,7 +280,7 @@ corr_pairs_validate <- function(data){ #' @examples #' validation_lib() #' validation_lib("missings") -validation_lib <- function(name=NULL) { +validation_lib <- function(name = NULL) { ls <- list( "obs_filter" = function(x, y) { ## Validation function for observations filter @@ -292,21 +329,22 @@ validation_lib <- function(name=NULL) { test.fun.args = list(var = "p_miss", cut = 30) ) }, - # "mcar" = function(x) { - # ### Placeholder for missingness validation - # list( - # string = i18n$t("There are {p_miss} % missing observations."), - # summary.fun = missings_validate, - # summary.fun.args = list( - # data = x - # ), - # test.fun = function(x, var, cut) { - # test.var <- x[var] - # ifelse(test.var > cut, "warning", "succes") - # }, - # test.fun.args = list(var = "p_miss", cut = 30) - # ) - # }, + "mcar" = function(x, y) { + ### Placeholder for missingness validation + list( + string = i18n$t("There is a significant correlation between {n_nonmcar} variables and missing observations in the outcome variable {outcome}."), + summary.fun = mcar_validate, + summary.fun.args = list( + data = x, + outcome = y + ), + test.fun = function(x, var, cut) { + test.var <- x[var] + ifelse(test.var > cut, "warning", "succes") + }, + test.fun.args = list(var = "n_nonmcar", cut = 0) + ) + }, "corr_pairs" = function(x) { ### Placeholder for missingness validation list( @@ -324,8 +362,8 @@ validation_lib <- function(name=NULL) { } ) - if (!is.null(name)){ - name <- match.arg(name,choices = names(ls)) + if (!is.null(name)) { + name <- match.arg(name, choices = names(ls)) ls[[name]] } else { ls @@ -349,15 +387,16 @@ validation_lib <- function(name=NULL) { #' i18n <- shiny.i18n::Translator$new(translation_csvs_path = here::here("inst/translations")) #' i18n$set_translation_language("en") #' df_original <- mtcars -#' df_original[1,2:4] <- NA -#' df_obs <- df_original |> dplyr::filter(carb==4) +#' df_original[1, 2:4] <- NA +#' df_obs <- df_original |> dplyr::filter(carb == 4) #' df_vars <- df_original[1:7] #' val <- purrr::map2( #' .x = validation_lib(), #' .y = list( -#' list(x = df_original, y = df_obs), -#' list(x = df_original, y = df_vars), -#' list(x=df_original)), +#' list(x = df_original, y = df_obs), +#' list(x = df_original, y = df_vars), +#' list(x = df_original) +#' ), #' make_validation #' ) #' val |> make_validation_alerts() @@ -403,7 +442,7 @@ make_validation <- function(ls, ...) { #' @export make_validation_alerts <- function(data) { # browser() - if (is.data.frame(data)){ + if (is.data.frame(data)) { ls <- list(data) } else { ls <- data diff --git a/inst/apps/FreesearchR/app.R b/inst/apps/FreesearchR/app.R index 95f287ea..1873202f 100644 --- a/inst/apps/FreesearchR/app.R +++ b/inst/apps/FreesearchR/app.R @@ -1,10 +1,10 @@ ######## -#### Current file: /Users/au301842/FreesearchR/app/global_vars.R +#### Current file: /var/folders/9l/xbc19wxx0g79jdd2sf_0v291mhwh7f/T//Rtmp4BY9Rb/file17e654c25f197.R ######## -trans_path <- here::here("inst/translations") +trans_path <- system.file("translations", package = "FreesearchR") ######## @@ -4068,7 +4068,7 @@ simple_snake <- function(data){ #### Current file: /Users/au301842/FreesearchR/R//hosted_version.R ######## -hosted_version <- function()'v25.8.3-250911' +hosted_version <- function()'v25.8.3-250922' ######## @@ -8398,7 +8398,7 @@ ui_elements <- function(selection) { shiny::column(width = 2), shiny::column( width = 8, - shiny::uiOutput(outputId = "language_select"), + # shiny::uiOutput(outputId = "language_select"), htmlOutput("intro_text") # shiny::includeHTML(i18n$t("www/intro.html")) # shiny::markdown(readLines(i18n$t("www/intro.md"))) @@ -10955,6 +10955,7 @@ grepl_fix <- function(data, pattern, type = c("prefix", "infix", "suffix")) { header_include <- function(){ shiny::tags$head( + includeHTML("www/umami-app.html"), tags$link(rel = "stylesheet", type = "text/css", href = "style.css"), tags$script(src="scripts.js")) } @@ -11026,6 +11027,7 @@ ui <- bslib::page_fixed( fillable = FALSE, footer = shiny::tags$footer( style = "background-color: #14131326; padding: 4px; text-align: center; bottom: 0; width: 100%;", + shiny::uiOutput(outputId = "language_select"), shiny::p( style = "margin: 1", "Data is only stored for analyses and deleted when the app is closed.", shiny::markdown("Consider [running ***FreesearchR*** locally](https://agdamsbo.github.io/FreesearchR/#run-locally-on-your-own-machine) if working with sensitive data.") @@ -11142,7 +11144,7 @@ server <- function(input, output, session) { inputId = "language_select", label = "", selected = "en", - choices = language_choices(), + choices = language_choices() ) })