andreas/FreesearchR
1
0
Fork 0
mirror of https://github.com/agdamsbo/FreesearchR.git synced 2025-12-16 01:22:10 +01:00
Code Issues Projects Releases Packages Wiki Activity Actions

two additional validation alerts

Browse source
This commit is contained in:
Andreas Gammelgaard Damsbo 2025-09-23 12:25:25 +02:00
parent 39a0fcd858
commit 2cc4831998
No known key found for this signature in database
2 changed files with 80 additions and 39 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

107
R/validation.R
View file

@ -97,13 +97,17 @@ validation_server <- function(id,
{ {
# browser() # browser()
to_validate <- data_r() 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( out <- lapply(
reactiveValuesToList(to_validate), to_validate,
make_validation_alerts) |> make_validation_alerts
purrr::list_flatten() ) |>
purrr::list_flatten()
if (length(to_validate) > 0) { } else if (length(to_validate) > 0) {
out <- make_validation_alerts(to_validate) out <- make_validation_alerts(to_validate)
} }
valid_ui$x <- tagList(out) valid_ui$x <- tagList(out)
@ -193,12 +197,12 @@ obs_filter_validate <- function(before, after) {
#' #'
#' @examples #' @examples
#' df <- mtcars #' df <- mtcars
#' df[1,2:4] <- NA #' df[1, 2:4] <- NA
#' missings_validate(df) #' missings_validate(df)
missings_validate <- function(data){ missings_validate <- function(data) {
if (!0 %in% dim(data)) { if (!0 %in% dim(data)) {
# browser() # browser()
p_miss <- sum(is.na(data))/prod(dim(data))*100 p_miss <- sum(is.na(data)) / prod(dim(data)) * 100
data.frame( data.frame(
p_miss = p_miss 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 data_s <- if (shiny::is.reactive(data)) data() else data
if (!0 %in% dim(data_s)) { if (!0 %in% dim(data_s)) {
# browser() # 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 ############# Collected validation functions in a library-like function
@ -243,7 +280,7 @@ corr_pairs_validate <- function(data){
#' @examples #' @examples
#' validation_lib() #' validation_lib()
#' validation_lib("missings") #' validation_lib("missings")
validation_lib <- function(name=NULL) { validation_lib <- function(name = NULL) {
ls <- list( ls <- list(
"obs_filter" = function(x, y) { "obs_filter" = function(x, y) {
## Validation function for observations filter ## Validation function for observations filter
@ -292,21 +329,22 @@ validation_lib <- function(name=NULL) {
test.fun.args = list(var = "p_miss", cut = 30) test.fun.args = list(var = "p_miss", cut = 30)
) )
}, },
# "mcar" = function(x) { "mcar" = function(x, y) {
# ### Placeholder for missingness validation ### Placeholder for missingness validation
# list( list(
# string = i18n$t("There are {p_miss} % missing observations."), string = i18n$t("There is a significant correlation between {n_nonmcar} variables and missing observations in the outcome variable {outcome}."),
# summary.fun = missings_validate, summary.fun = mcar_validate,
# summary.fun.args = list( summary.fun.args = list(
# data = x data = x,
# ), outcome = y
# test.fun = function(x, var, cut) { ),
# test.var <- x[var] test.fun = function(x, var, cut) {
# ifelse(test.var > cut, "warning", "succes") test.var <- x[var]
# }, ifelse(test.var > cut, "warning", "succes")
# test.fun.args = list(var = "p_miss", cut = 30) },
# ) test.fun.args = list(var = "n_nonmcar", cut = 0)
# }, )
},
"corr_pairs" = function(x) { "corr_pairs" = function(x) {
### Placeholder for missingness validation ### Placeholder for missingness validation
list( list(
@ -324,8 +362,8 @@ validation_lib <- function(name=NULL) {
} }
) )
if (!is.null(name)){ if (!is.null(name)) {
name <- match.arg(name,choices = names(ls)) name <- match.arg(name, choices = names(ls))
ls[[name]] ls[[name]]
} else { } else {
ls ls
@ -349,15 +387,16 @@ validation_lib <- function(name=NULL) {
#' i18n <- shiny.i18n::Translator$new(translation_csvs_path = here::here("inst/translations")) #' i18n <- shiny.i18n::Translator$new(translation_csvs_path = here::here("inst/translations"))
#' i18n$set_translation_language("en") #' i18n$set_translation_language("en")
#' df_original <- mtcars #' df_original <- mtcars
#' df_original[1,2:4] <- NA #' df_original[1, 2:4] <- NA
#' df_obs <- df_original |> dplyr::filter(carb==4) #' df_obs <- df_original |> dplyr::filter(carb == 4)
#' df_vars <- df_original[1:7] #' df_vars <- df_original[1:7]
#' val <- purrr::map2( #' val <- purrr::map2(
#' .x = validation_lib(), #' .x = validation_lib(),
#' .y = list( #' .y = list(
#' list(x = df_original, y = df_obs), #' list(x = df_original, y = df_obs),
#' list(x = df_original, y = df_vars), #' list(x = df_original, y = df_vars),
#' list(x=df_original)), #' list(x = df_original)
#' ),
#' make_validation #' make_validation
#' ) #' )
#' val |> make_validation_alerts() #' val |> make_validation_alerts()
@ -403,7 +442,7 @@ make_validation <- function(ls, ...) {
#' @export #' @export
make_validation_alerts <- function(data) { make_validation_alerts <- function(data) {
# browser() # browser()
if (is.data.frame(data)){ if (is.data.frame(data)) {
ls <- list(data) ls <- list(data)
} else { } else {
ls <- data ls <- data

12
inst/apps/FreesearchR/app.R
View file

@ -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 #### 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 = 2),
shiny::column( shiny::column(
width = 8, width = 8,
shiny::uiOutput(outputId = "language_select"), # shiny::uiOutput(outputId = "language_select"),
htmlOutput("intro_text") htmlOutput("intro_text")
# shiny::includeHTML(i18n$t("www/intro.html")) # shiny::includeHTML(i18n$t("www/intro.html"))
# shiny::markdown(readLines(i18n$t("www/intro.md"))) # 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(){ header_include <- function(){
shiny::tags$head( shiny::tags$head(
includeHTML("www/umami-app.html"),
tags$link(rel = "stylesheet", type = "text/css", href = "style.css"), tags$link(rel = "stylesheet", type = "text/css", href = "style.css"),
tags$script(src="scripts.js")) tags$script(src="scripts.js"))
} }
@ -11026,6 +11027,7 @@ ui <- bslib::page_fixed(
fillable = FALSE, fillable = FALSE,
footer = shiny::tags$footer( footer = shiny::tags$footer(
style = "background-color: #14131326; padding: 4px; text-align: center; bottom: 0; width: 100%;", style = "background-color: #14131326; padding: 4px; text-align: center; bottom: 0; width: 100%;",
shiny::uiOutput(outputId = "language_select"),
shiny::p( shiny::p(
style = "margin: 1", 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.") "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", inputId = "language_select",
label = "", label = "",
selected = "en", selected = "en",
choices = language_choices(), choices = language_choices()
) )
}) })