From 9daec36e9072c6775faf88298791371f9cb00855 Mon Sep 17 00:00:00 2001 From: Helene Koester Date: Mon, 30 Oct 2023 14:43:38 +0000 Subject: [PATCH] Time compare --- NAMESPACE | 2 + R/app_utils.R | 18 +++ R/moduleDashboard.R | 56 ++++++++ R/moduleDescriptive.R | 2 +- R/moduleDifferences.R | 236 +++++++++++++++++++++++++++++++ inst/application/server.R | 13 ++ inst/application/ui.R | 5 + man/module_differences_server.Rd | 41 ++++++ man/module_differences_ui.Rd | 33 +++++ 9 files changed, 405 insertions(+), 1 deletion(-) create mode 100644 R/moduleDifferences.R create mode 100644 man/module_differences_server.Rd create mode 100644 man/module_differences_ui.Rd diff --git a/NAMESPACE b/NAMESPACE index 6863100..5e99f51 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -13,6 +13,8 @@ export(module_dashboard_server) export(module_dashboard_ui) export(module_descriptive_server) export(module_descriptive_ui) +export(module_differences_server) +export(module_differences_ui) export(module_log_server) export(module_log_ui) export(module_mdr_server) diff --git a/R/app_utils.R b/R/app_utils.R index a05e9cf..a8b879c 100644 --- a/R/app_utils.R +++ b/R/app_utils.R @@ -819,3 +819,21 @@ get_from_env <- function(sysname) { return(outlist[outlist != ""]) } + + +# render quick check tables +render_difference_checks <- function(dat_table) { + out <- + DT::datatable( + dat_table, + options = list( + dom = "t", + scrollY = "30vh", + pageLength = nrow(dat_table) + ), + rownames = FALSE + ) + + return(out) +} + diff --git a/R/moduleDashboard.R b/R/moduleDashboard.R index 64dcd61..909ea68 100644 --- a/R/moduleDashboard.R +++ b/R/moduleDashboard.R @@ -274,6 +274,28 @@ module_dashboard_server <- # set flag that we have all data rv$getdata_target <- FALSE + # time-compare for differences + waiter::waiter_update(html = shiny::tagList( + waiter::spin_timer(), + "Calculate differences ..." + )) + rv$time_compare_results <- DQAstats::time_compare( + rv = rv, + logfile_dir = rv$log$logfile_dir, + headless = rv$headless) + + # delete the TIMESTAMP columns + fun <- function(x) { + if ("TIMESTAMP" %in% names(x)) { + x$TIMESTAMP <- NULL + } + return(x) + } + + rv$data_source <- lapply(rv$data_source, fun) + rv$data_target <- lapply(rv$data_target, fun) + + # plausibility checks waiter::waiter_update(html = shiny::tagList( waiter::spin_timer(), "Applying plausibility checks ..." @@ -417,6 +439,10 @@ module_dashboard_server <- rv$checks$etl <- DQAstats::etl_checks(results = rv$results_descriptive) + # checks$difference + rv$checks$differences <- + DQAstats::difference_checks(results = rv$results_descriptive) + # set flag to create report here rv$create_report <- TRUE } @@ -519,6 +545,20 @@ module_dashboard_server <- }) }) + observe({ + req(rv$aggregated_exported) + + # workaround to tell ui, that db_connection is there + output$differences_results <- reactive({ + return(TRUE) + }) + outputOptions(output, "differences_results", suspendWhenHidden = FALSE) + + output$dash_quick_difference_checks <- DT::renderDataTable({ + render_difference_checks(rv$checks$differences) + }) + }) + observe({ req(rv$aggregated_exported) @@ -632,6 +672,21 @@ module_dashboard_ui <- function(id) { width = 12 ) ), + conditionalPanel( + condition = "output['moduleDashboard-differences_results']", + box( + title = "Difference Monitor: ", + helpText( + paste0( + "Difference checks to monitor the discrepancies between ", + "source and target database. It calculates the difference ", + "in absolute values as well as percentage. " + ) + ), + DT::dataTableOutput(ns("dash_quick_difference_checks")), + width = 12 + ) + ), conditionalPanel( condition = "output['moduleDashboard-valueconformance_results']", box( @@ -650,6 +705,7 @@ module_dashboard_ui <- function(id) { ) ) ), + column( 6, conditionalPanel( diff --git a/R/moduleDescriptive.R b/R/moduleDescriptive.R index 9556622..0cd3815 100644 --- a/R/moduleDescriptive.R +++ b/R/moduleDescriptive.R @@ -77,7 +77,7 @@ module_descriptive_server <- output$descr_description <- renderText({ d <- desc_out$source_data$description # https://community.rstudio.com/t/rendering-markdown-text/11588 - out <- knitr::knit2html(text = d, fragment.only = TRUE) + out <- knitr::knit2html(text = d, template = FALSE, output = NULL) # output non-escaped HTML string shiny::HTML(out) }) diff --git a/R/moduleDifferences.R b/R/moduleDifferences.R new file mode 100644 index 0000000..bf79134 --- /dev/null +++ b/R/moduleDifferences.R @@ -0,0 +1,236 @@ +# DQAgui - A graphical user interface (GUI) to the functions implemented in the +# R package 'DQAstats'. +# Copyright (C) 2019-2022 Universitätsklinikum Erlangen +# +# This program is free software: you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation, either version 3 of the License, or +# (at your option) any later version. +# +# This program is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with this program. If not, see . + + +#' @title module_differences_server +#' +#' @param input Shiny server input object +#' @param output Shiny server output object +#' @param session Shiny session object +#' @param rv The global 'reactiveValues()' object, defined in server.R +#' @param input_re The Shiny server input object, wrapped into a reactive +#' expression: input_re = reactive({input}) +#' +#' @return The function returns a shiny server module. +#' +#' @seealso \url{https://shiny.rstudio.com/articles/modules.html} +#' +#' @examples +#' if (interactive()) { +#' rv <- list() +#' shiny::callModule( +#' module_differences_server, +#' "moduleDifferences", +#' rv = rv, +#' input_re = reactive(input) +#' ) +#' } +#' +#' @export +#' +# module_differences_server +module_differences_server <- + function(input, output, session, rv, input_re) { + observe({ + req(rv$time_compare_results) + + # render select input here + output$descr_selection_uiout <- renderUI({ + selectInput( + inputId = "moduleDifferences-var_select", + label = "Select variable", + choices = names(rv$time_compare_results), + multiple = FALSE, + selectize = FALSE, + size = 10 + ) + }) + + output$source_database <- renderText({ + paste0("Source Data (", rv$source$system_name, ")") + }) + + output$target_database <- renderText({ + paste0("Target Data (", rv$target$system_name, ")") + }) + + # generate output tables + observeEvent(input_re()[["moduleDifferences-var_select"]], { + cat(input_re()[["moduleDifferences-var_select"]], "\n") + + sel_ob <- input_re()[["moduleDifferences-var_select"]] + # get description object + desc_out <- rv$results_descriptive[[sel_ob]]$description + summary_out <- rv$time_compare_results[[sel_ob]]$result_table + count_out <- rv$results_descriptive[[sel_ob]]$counts + target_out <- rv$time_compare_results[[sel_ob]]$suspect_data_target + source_out <- rv$time_compare_results[[sel_ob]]$suspect_data_source + + value_conf <- rv$conformance$value_conformance[[sel_ob]] + + + output$descr_description <- renderTable({ + summary_out + }) + + # render source statistics + output$descr_selection_source_table <- renderTable({ + source_out + } + ) + + # render target statistics + output$descr_selection_target_table <- renderTable({ + target_out + }) + + # handling the download options + output$download_data <- downloadHandler( + filename = function() { + time <- format(Sys.time(), "%Y_%m_%d_%H_%M") + paste("DQA-Difference-Data-", time, ".rds", sep = "") + }, + content = function(file) { + difference_results <- list() + difference_results$source <- rv$source$system_name + difference_results$target <- rv$target$system_name + difference_results$time_restriction <- rv$restricting_date + difference_results$start_time <- rv$start_time + difference_results$time_compare_results <- rv$time_compare_results + saveRDS(difference_results, file) + }, + contentType = "application/rds" + ) + + output$download_source <- downloadHandler( + filename = function() { + time <- format(Sys.time(), "%Y_%m_%d_%H_%M") + paste("Diff-source-",sel_ob ,time , ".csv", sep = "") + }, + content = function(file) { + write.csv(source_out, file, row.names = FALSE) + }, + contentType = "text/csv" + ) + + output$download_target <- downloadHandler( + filename = function() { + time <- format(Sys.time(), "%Y_%m_%d_%H_%M") + paste("Diff-target-",sel_ob ,time , ".csv", sep = "") + }, + content = function(file) { + write.csv(target_out, file, row.names = FALSE) + }, + contentType = "text/csv" + ) + }) + }) + + } + + +#' @title module_differences_ui +#' +#' @param id A character. The identifier of the shiny object +#' +#' @return The function returns a shiny ui module. +#' +#' @seealso \url{https://shiny.rstudio.com/articles/modules.html} +#' +#' @examples +#' if (interactive()) { +#' shinydashboard::tabItems( +#' shinydashboard::tabItem( +#' tabName = "differences", +#' module_differences_ui( +#' "moduleDifferences" +#' ) +#' ) +#' ) +#' } +#' +#' @export +#' +# module_differences_ui +module_differences_ui <- function(id) { + ns <- NS(id) + + tagList( + fluidRow( + box(title = "Select variable", + uiOutput(ns("descr_selection_uiout")), + width = 4), + + box(title = "Summary", + style = "height: 300px; overflow-y: scroll;", + htmlOutput(ns("descr_description")), + width = 8) + ), + fluidRow( + box( + width = 4, + "If the available resources for a given TIMESTAMP", + "differ, it is likely that a resource is missing in either the source", + "or the target database. The following tables contain all resources", + "with differences in their TIMESTAMP count." + ), + box( + width = 8, + column( + width = 6, + "The .pdf report contains only the first 25 lines ", + "of the summary table. You can download the shown source or target", + "result-table as .csv file. Or you can download all results ", + "including some metadata as .rds file for further analysis in R." + ), + column( + width = 2, + downloadButton( + ns("download_data"), "All (.rds)" + ) + ), + column( + width = 4, + downloadButton( + ns("download_source"), "Source Data (.csv)", + style = "width: 140px; margin-bottom: 6px;" + ), + tags$br(), + downloadButton( + ns("download_target"), "Target Data (.csv)", + style = "width: 140px;" + ) + ) + ) + ), + fluidRow( + box( + title = textOutput(ns("source_database")), + width = 6, + style = "overflow-x: scroll; overflow-y: scroll; height: 600px;", + tableOutput( + ns("descr_selection_source_table")) + ), + box( + title = textOutput(ns("target_database")), + width = 6, + style = "overflow-X: scroll; overflow-y: scroll; height: 600px;", + tableOutput( + ns("descr_selection_target_table")) + ) + )) +} diff --git a/inst/application/server.R b/inst/application/server.R index 5c71231..cc5c8f2 100644 --- a/inst/application/server.R +++ b/inst/application/server.R @@ -252,6 +252,11 @@ shiny::shinyServer(function(input, output, session) { tabName = "tab_completeness", icon = icon("chart-line") ), + shinydashboard::menuItem( + text = "Difference Checks", + tabName = "tab_differences", + icon = icon("not-equal") + ), shinydashboard::menuItem( text = "Reporting", tabName = "tab_report", @@ -341,6 +346,14 @@ shiny::shinyServer(function(input, output, session) { rv, input_re = input_reactive) + ######################## + # tab_differences + ######################## + shiny::callModule(module_differences_server, + "moduleDifferences", + rv, + input_re = input_reactive) + ######################## # tab_report ######################## diff --git a/inst/application/ui.R b/inst/application/ui.R index a45922e..21ee6ec 100644 --- a/inst/application/ui.R +++ b/inst/application/ui.R @@ -141,6 +141,11 @@ shiny::shinyUI( module_uniq_plaus_ui("moduleUniquePlausibility") ), + shinydashboard::tabItem( + tabName = "tab_differences", + module_differences_ui("moduleDifferences") + ), + shinydashboard::tabItem( tabName = "tab_completeness", module_completeness_ui("moduleCompleteness") diff --git a/man/module_differences_server.Rd b/man/module_differences_server.Rd new file mode 100644 index 0000000..ce874e5 --- /dev/null +++ b/man/module_differences_server.Rd @@ -0,0 +1,41 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/moduleDifferences.R +\name{module_differences_server} +\alias{module_differences_server} +\title{module_differences_server} +\usage{ +module_differences_server(input, output, session, rv, input_re) +} +\arguments{ +\item{input}{Shiny server input object} + +\item{output}{Shiny server output object} + +\item{session}{Shiny session object} + +\item{rv}{The global 'reactiveValues()' object, defined in server.R} + +\item{input_re}{The Shiny server input object, wrapped into a reactive +expression: input_re = reactive({input})} +} +\value{ +The function returns a shiny server module. +} +\description{ +module_differences_server +} +\examples{ +if (interactive()) { +rv <- list() +shiny::callModule( + module_differences_server, + "moduleDifferences", + rv = rv, + input_re = reactive(input) +) +} + +} +\seealso{ +\url{https://shiny.rstudio.com/articles/modules.html} +} diff --git a/man/module_differences_ui.Rd b/man/module_differences_ui.Rd new file mode 100644 index 0000000..bb75d97 --- /dev/null +++ b/man/module_differences_ui.Rd @@ -0,0 +1,33 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/moduleDifferences.R +\name{module_differences_ui} +\alias{module_differences_ui} +\title{module_differences_ui} +\usage{ +module_differences_ui(id) +} +\arguments{ +\item{id}{A character. The identifier of the shiny object} +} +\value{ +The function returns a shiny ui module. +} +\description{ +module_differences_ui +} +\examples{ +if (interactive()) { +shinydashboard::tabItems( + shinydashboard::tabItem( + tabName = "differences", + module_differences_ui( + "moduleDifferences" + ) + ) +) +} + +} +\seealso{ +\url{https://shiny.rstudio.com/articles/modules.html} +}