feat: introduction of validation alerts

This commit is contained in:
Andreas Gammelgaard Damsbo 2025-09-10 12:00:24 +02:00
parent 96e08e44d8
commit 545874f71b
No known key found for this signature in database
5 changed files with 736 additions and 0 deletions

390
R/validation.R Normal file
View file

@ -0,0 +1,390 @@
# Description of warning with text description incl metric
# Color coded (green (OK) or yellow (WARNING))
# option to ignore/accept warnings ### to simplify things, this is gone for now ###
# Only show warnings based on performed analyses
## 250825
## Works in demo
## Not alert is printed in app interface
## I believe it comes down to the reactivity
########################################################################
############# Server and UI
########################################################################
#' @title Validation module
#'
#' @description Check that a dataset respect some validation expectations.
#'
#' @param id Module's ID.
#' @param max_height Maximum height for validation results element, useful if you have many rules.
#' @param ... Arguments passed to \code{actionButton} or \code{uiOutput} depending on display mode,
#' you cannot use \code{inputId}/\code{outputId}, \code{label} or \code{icon} (button only).
#'
#' @return
#' * UI: HTML tags that can be included in shiny's UI
#' * Server: a \code{list} with two slots:
#' + **status**: a \code{reactive} function returning the best status available between \code{"OK"}, \code{"Failed"} or \code{"Error"}.
#' + **details**: a \code{reactive} function returning a \code{list} with validation details.
#' @export
#'
#' @rdname validation
#'
#' @example examples/validation_module_demo.R
validation_ui <- function(id, max_height = NULL, ...) {
ns <- shiny::NS(id)
max_height <- if (!is.null(max_height)) {
paste0("overflow-y: auto; max-height:", htmltools::validateCssUnit(max_height), ";")
}
ui <- shiny::uiOutput(
outputId = ns("results"),
...,
style = max_height
)
htmltools::tagList(
ui, datamods:::html_dependency_datamods()
)
}
#' @export
#'
#' @param data a \code{reactive} function returning a \code{data.frame}.
#'
#' @rdname validation
#'
validation_server <- function(id,
data) {
moduleServer(
id = id,
module = function(input, output, session) {
valid_ui <- reactiveValues(x = NULL)
data_r <- if (shiny::is.reactive(data)) data else shiny::reactive(data)
# observeEvent(data_r(), {
# to_validate <- data()
# valid_dims <- check_data(to_validate, n_row = n_row, n_col = n_col)
#
# if (all(c(valid_dims$nrows, valid_dims$ncols))) {
# valid_status <- "OK"
# } else {
# valid_status <- "Failed"
# }
#
# valid_results <- lapply(
# X = c("nrows", "ncols"),
# FUN = function(x) {
# if (is.null(valid_dims[[x]]))
# return(NULL)
# label <- switch(
# x,
# "nrows" = n_row_label,
# "ncols" = n_col_label
# )
# list(
# status = ifelse(valid_dims[[x]], "OK", "Failed"),
# label = paste0("<b>", label, "</b>")
# )
# }
# )
shiny::observeEvent(
data_r(),
{
# browser()
to_validate <- data_r()
if (is.reactivevalues(to_validate))
out <- lapply(
reactiveValuesToList(to_validate),
make_validation_alerts) |>
purrr::list_flatten()
if (length(to_validate) > 0) {
out <- make_validation_alerts(to_validate)
}
valid_ui$x <- tagList(out)
}
)
output$results <- renderUI({
valid_ui$x
})
}
)
}
########################################################################
############# Validation functions
########################################################################
#' Dimensions validation
#'
#' @param before data before
#' @param after data after
#' @param fun dimension function. ncol or nrow
#'
#' @returns data.frame
#'
dim_change_call <- function(before, after, fun) {
# browser()
if (!0 %in% c(dim(before), dim(after))) {
n_before <- fun(before)
n_after <- fun(after)
n_out <- n_before - n_after
p_after <- n_after / fun(before) * 100
p_out <- 100 - p_after
data.frame(
n_before = n_before,
n_after = n_after,
n_out = n_out,
p_after = p_after,
p_out = p_out
) |>
dplyr::mutate(
dplyr::across(
dplyr::where(
is.numeric
),
\(.y) round(.y, 0)
)
)
} else {
data.frame(NULL)
}
}
#' Variable filter test wrapper
#'
#' @param before data before
#' @param after data after
#'
#' @returns vector
#'
#' @examples
#' vars_filter_validate(mtcars, mtcars[1:6])
#' vars_filter_validate(mtcars, mtcars[0])
vars_filter_validate <- function(before, after) {
dim_change_call(before, after, ncol)
}
#' Observations filter test wrapper
#'
#' @param before data before
#' @param after data after
#'
#' @returns vector
#'
obs_filter_validate <- function(before, after) {
dim_change_call(before, after, nrow)
}
#' Validate function of missingness in data
#'
#' @param data data set
#'
#' @returns data.frame
#' @export
#'
#' @examples
#' df <- mtcars
#' df[1,2:4] <- NA
#' missings_validate(df)
missings_validate <- function(data){
if (!0 %in% dim(data)) {
# browser()
p_miss <- sum(is.na(data))/prod(dim(data))*100
data.frame(
p_miss = p_miss
) |>
dplyr::mutate(
dplyr::across(
dplyr::where(
is.numeric
),
\(.y) signif(.y, 2)
)
)
} else {
data.frame(NULL)
}
}
########################################################################
############# Collected validation functions in a library-like function
########################################################################
#' Validation library
#'
#' @param name Index name
#'
#' @returns list
#'
#' @examples
#' validation_lib()
#' validation_lib("missings")
validation_lib <- function(name=NULL) {
ls <- list(
"obs_filter" = function(x, y) {
## Validation function for observations filter
list(
string = i18n$t("You removed {p_out} % of observations."),
summary.fun = obs_filter_validate,
summary.fun.args = list(
before = x,
after = y
),
test.fun = function(x, var, cut) {
test.var <- x[var]
ifelse(test.var > cut, "warning", "succes")
},
test.fun.args = list(var = "p_out", cut = 50)
)
},
"var_filter" = function(x, y) {
## Validation function for variables filter
list(
string = i18n$t("You removed {p_out} % of variables."),
summary.fun = vars_filter_validate,
summary.fun.args = list(
before = x,
after = y
),
test.fun = function(x, var, cut) {
test.var <- x[var]
ifelse(test.var > cut, "warning", "succes")
},
test.fun.args = list(var = "p_out", cut = 50)
)
},
"missings" = function(x, y) {
### Placeholder for missingness validation
list(
string = "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)
)
}
)
if (!is.null(name)){
name <- match.arg(name,choices = names(ls))
ls[[name]]
} else {
ls
}
}
########################################################################
############# Validation creation
########################################################################
#' Create validation data.frame
#'
#' @param ls validation list
#' @param ... magic dots
#'
#' @returns data.frame
#' @export
#'
#' @examples
#' 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_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)),
#' make_validation
#' )
#' val |> make_validation_alerts()
#'
#' val2 <- purrr::map2(
#' .x = validation_lib()[2],
#' .y = list(list(x = mtcars, y = mtcars[0])),
#' make_validation
#' )
#' val2 |> make_validation_alerts()
#'
#' val3 <- make_validation(
#' ls = validation_lib()[[2]],
#' list(x = mtcars, y = mtcars[0])
#' )
make_validation <- function(ls, ...) {
ls <- do.call(ls, ...)
df <- do.call(ls$summary.fun, ls$summary.fun.args)
if (!any(dim(df) == c(0))) {
label <- with(df, {
glue::glue(ls$string)
})
# browser()
status <- do.call(ls$test.fun, modifyList(ls$test.fun.args, list(x = df)))
data.frame(
label = label,
status = status[1]
)
} else {
data.frame(NULL)
}
}
#' Create alert from validation data.frame
#'
#' @param data
#'
#' @export
make_validation_alerts <- function(data) {
# browser()
if (is.data.frame(data)){
ls <- list(data)
} else {
ls <- data
}
lapply(
X = ls,
FUN = function(x) {
# browser()
if (!is.null(dim(x)) && !any(dim(x) == c(0))) {
icon <- switch(x$status,
"succes" = phosphoricons::ph("check", title = "OK"),
"warning" = phosphoricons::ph("warning", title = "Warning")
)
shinyWidgets::alert(
icon,
htmltools::HTML(x$label),
status = x$status,
style = "margin-bottom: 10px; padding: 10px;"
)
} else {
return(NULL)
}
}
)
}

View file

@ -0,0 +1,133 @@
#' Data and analyses validation demo
#'
#' @returns
#' @export
#'
#' @examples
#' \dontrun{
#' validation_demo_app()
#' }
validation_demo_app <- function() {
ui <- shiny::fluidPage(
shiny::tags$h2("Validation"),
IDEAFilter::IDEAFilter_ui("data_filter"),
shiny::br(),
DT::DTOutput("data_final"),
shiny::br(),
validation_ui("validation_demo_2")
)
server <- function(input, output, session) {
rv <- shiny::reactiveValues(
data_original = shiny::reactive(mtcars),
data_filtered = NULL
)
rv_validation <- shiny::reactiveValues(
obs_filter = NULL,
vars_filter = NULL
)
data_filter <- IDEAFilter::IDEAFilter(
id = "data_filter",
data = mtcars,
verbose = TRUE
)
shiny::observeEvent(
data_filter(),
{
rv$data_filtered <- data_filter()
}
)
output$data_final <- DT::renderDT(
data_filter()
)
shiny::observeEvent(
list(
data_filter()
),
{
to_make_validation <- data_filter()
## Validation
if (!is.null(to_make_validation)) {
validation <-
make_validation(
ls = validation_lib("obs_filter"),
list(
x = mtcars,
y = to_make_validation
)
)
rv_validation$vars_filter <- validation
validation_server(id = "validation_demo_2", data = rv_validation$vars_filter)
}
}
)
# shiny::observeEvent(
# list(
# shiny::reactive(rv_validation$vars_filter)(),
# data_filter()
# ),
# {
# # browser()
# # to_make_alert <- shiny::isolate(rv_validation$vars_filter)
# to_make_alert <- shiny::reactive(rv_validation$vars_filter)()
# if (!is.null(rv_validation$vars_filter)) {
# validation_server(id = "validation_demo_2", data = to_make_alert)
# }
# }
# )
}
shiny::shinyApp(ui, server)
}
#' Title
#'
#' @returns
#' @export
#'
#' @examples
#' validation_nr_demo_app()
validation_nr_demo_app <- function() {
ui <- shiny::fluidPage(
shiny::tags$h2("Validation"),
shiny::br(),
validation_ui("validation_demo_1", max_height = "30px"),
shiny::br(),
validation_ui("validation_demo_2")
)
server <- function(input, output, session) {
df_original <- mtcars
df_obs <- mtcars |> dplyr::filter(mpg > 20)
df_vars <- df_obs[1:6]
val1 <- purrr::map2(
.x = validation_lib()[1],
.y = list(list(x = df_original, y = df_obs)),
make_validation
)
val2 <- make_validation(
ls = validation_lib()[[2]],
list(x = df_original, y = df_vars)
)
validation_server(id = "validation_demo_1", data = val1)
validation_server(id = "validation_demo_2", data = val2)
}
shiny::shinyApp(ui, server)
}

169
man/validation.Rd Normal file
View file

@ -0,0 +1,169 @@
% Generated by roxygen2: do not edit by hand
% Please edit documentation in R/validation.R
\name{validation_ui}
\alias{validation_ui}
\alias{validation_server}
\title{Validation module}
\usage{
validation_ui(id, max_height = NULL, ...)
validation_server(id, data)
}
\arguments{
\item{id}{Module's ID.}
\item{max_height}{Maximum height for validation results element, useful if you have many rules.}
\item{...}{Arguments passed to \code{actionButton} or \code{uiOutput} depending on display mode,
you cannot use \code{inputId}/\code{outputId}, \code{label} or \code{icon} (button only).}
\item{data}{a \code{reactive} function returning a \code{data.frame}.}
}
\value{
\itemize{
\item UI: HTML tags that can be included in shiny's UI
\item Server: a \code{list} with two slots:
\itemize{
\item \strong{status}: a \code{reactive} function returning the best status available between \code{"OK"}, \code{"Failed"} or \code{"Error"}.
\item \strong{details}: a \code{reactive} function returning a \code{list} with validation details.
}
}
}
\description{
Check that a dataset respect some validation expectations.
}
\examples{
#' Data and analyses validation demo
#'
#' @returns
#' @export
#'
#' @examples
#' \dontrun{
#' validation_demo_app()
#' }
validation_demo_app <- function() {
ui <- shiny::fluidPage(
shiny::tags$h2("Validation"),
IDEAFilter::IDEAFilter_ui("data_filter"),
shiny::br(),
DT::DTOutput("data_final"),
shiny::br(),
validation_ui("validation_demo_2")
)
server <- function(input, output, session) {
rv <- shiny::reactiveValues(
data_original = shiny::reactive(mtcars),
data_filtered = NULL
)
rv_validation <- shiny::reactiveValues(
obs_filter = NULL,
vars_filter = NULL
)
data_filter <- IDEAFilter::IDEAFilter(
id = "data_filter",
data = mtcars,
verbose = TRUE
)
shiny::observeEvent(
data_filter(),
{
rv$data_filtered <- data_filter()
}
)
output$data_final <- DT::renderDT(
data_filter()
)
shiny::observeEvent(
list(
data_filter()
),
{
to_make_validation <- data_filter()
## Validation
if (!is.null(to_make_validation)) {
validation <-
make_validation(
ls = validation_lib("obs_filter"),
list(
x = mtcars,
y = to_make_validation
)
)
rv_validation$vars_filter <- validation
validation_server(id = "validation_demo_2", data = rv_validation$vars_filter)
}
}
)
# shiny::observeEvent(
# list(
# shiny::reactive(rv_validation$vars_filter)(),
# data_filter()
# ),
# {
# # browser()
# # to_make_alert <- shiny::isolate(rv_validation$vars_filter)
# to_make_alert <- shiny::reactive(rv_validation$vars_filter)()
# if (!is.null(rv_validation$vars_filter)) {
# validation_server(id = "validation_demo_2", data = to_make_alert)
# }
# }
# )
}
shiny::shinyApp(ui, server)
}
#' Title
#'
#' @returns
#' @export
#'
#' @examples
#' validation_nr_demo_app()
validation_nr_demo_app <- function() {
ui <- shiny::fluidPage(
shiny::tags$h2("Validation"),
shiny::br(),
validation_ui("validation_demo_1", max_height = "30px"),
shiny::br(),
validation_ui("validation_demo_2")
)
server <- function(input, output, session) {
df_original <- mtcars
df_obs <- mtcars |> dplyr::filter(mpg > 20)
df_vars <- df_obs[1:6]
val1 <- purrr::map2(
.x = validation_lib()[1],
.y = list(list(x = df_original, y = df_obs)),
make_validation
)
val2 <- make_validation(
ls = validation_lib()[[2]],
list(x = df_original, y = df_vars)
)
validation_server(id = "validation_demo_1", data = val1)
validation_server(id = "validation_demo_2", data = val2)
}
shiny::shinyApp(ui, server)
}
}

21
man/validation_lib.Rd Normal file
View file

@ -0,0 +1,21 @@
% Generated by roxygen2: do not edit by hand
% Please edit documentation in R/validation.R
\name{validation_lib}
\alias{validation_lib}
\title{Validation library}
\usage{
validation_lib(name = NULL)
}
\arguments{
\item{name}{Index name}
}
\value{
list
}
\description{
Validation library
}
\examples{
validation_lib()
validation_lib("missings")
}

View file

@ -0,0 +1,23 @@
% Generated by roxygen2: do not edit by hand
% Please edit documentation in R/validation.R
\name{vars_filter_validate}
\alias{vars_filter_validate}
\title{Variable filter test wrapper}
\usage{
vars_filter_validate(before, after)
}
\arguments{
\item{before}{data before}
\item{after}{data after}
}
\value{
vector
}
\description{
Variable filter test wrapper
}
\examples{
vars_filter_validate(mtcars, mtcars[1:6])
vars_filter_validate(mtcars, mtcars[0])
}