Merge pull request #13 from pweigmann/extraColors

add extra colors
pik-piam · Sep 19, 2024 · f49e944 · f49e944
2 parents dc8524e + a2f698f
commit f49e944
Show file tree

Hide file tree

Showing 12 changed files with 88 additions and 44 deletions.
diff --git a/.buildlibrary b/.buildlibrary
@@ -1,4 +1,4 @@
-ValidationKey: '719460'
+ValidationKey: '739445'
 AutocreateReadme: yes
 AcceptedWarnings:
 - 'Warning: package ''.*'' was built under R version'

diff --git a/CITATION.cff b/CITATION.cff
@@ -2,7 +2,7 @@ cff-version: 1.2.0
 message: If you use this software, please cite it using the metadata from this file.
 type: software
 title: 'piamValidation: Validation Tools for PIK-PIAM'
-version: 0.3.6
+version: 0.3.7
 date-released: '2024-09-19'
 abstract: The piamValidation package provides validation tools for the Potsdam Integrated
   Assessment Modelling environment.

diff --git a/DESCRIPTION b/DESCRIPTION
@@ -1,7 +1,7 @@
 Type: Package
 Package: piamValidation
 Title: Validation Tools for PIK-PIAM
-Version: 0.3.6
+Version: 0.3.7
 Date: 2024-09-19
 Authors@R:
     c(person("Pascal", "Weigmann",, "[email protected]", role = c("aut", "cre")),

diff --git a/R/evaluateThresholds.R b/R/evaluateThresholds.R
@@ -2,7 +2,7 @@
 
 # cleanInf = TRUE: replace "Inf" and "-Inf" which were introduced
 #                  for ease of calculations with "-"
-evaluateThresholds <- function(df, cleanInf = TRUE) {
+evaluateThresholds <- function(df, cleanInf = TRUE, extraColors = TRUE) {
 
   # first calculate values that will be compared to thresholds for each category
   # ("check_value") and metric separately, then perform evaluation for all together
@@ -52,23 +52,54 @@ evaluateThresholds <- function(df, cleanInf = TRUE) {
   # evaluation ####
   # perform comparison to thresholds for whole data.frame at once
   # TODO: not as robust as previously thought. Partially fails if only max_red is given
-  df <- df %>%
-    mutate(check = ifelse(is.na(check_value) | is.infinite(check_value),
-                          "grey",
-                          ifelse(
-                            # first check whether red threshold is violated...
-                            check_value > max_red | check_value < min_red,
-                            "red",
-                            # otherwise check if yellow threshold is violated...
+  if (extraColors) {
+    df <- df %>%
+      mutate(check = ifelse(is.na(check_value) | is.infinite(check_value),
+                            "grey",
+                            # check thresholds from low to high
                             ifelse(
-                              check_value > max_yel | check_value < min_yel,
-                              "yellow",
-                              # ... else green
-                              "green"
+                              # first check whether min red is violated...
+                              check_value < min_red,
+                              "blue",
+                              # then check if min yellow is violated...
+                              ifelse(
+                                check_value < min_yel,
+                                "cyan",
+                                # now check max thresholds, first yel...
+                                ifelse(
+                                  check_value > max_red,
+                                  "red",
+                                  # then max red...
+                                  ifelse(
+                                    check_value > max_yel,
+                                    "yellow",
+                                    # ... else green
+                                    "green")
+                                  )
+                              )
                             )
                           )
-                        )
-           )
+             )
+  } else {
+    # if only
+    df <- df %>%
+      mutate(check = ifelse(is.na(check_value) | is.infinite(check_value),
+                            "grey",
+                            ifelse(
+                              # first check whether red threshold is violated...
+                              check_value > max_red | check_value < min_red,
+                              "red",
+                              # otherwise check if yellow threshold is violated...
+                              ifelse(
+                                check_value > max_yel | check_value < min_yel,
+                                "yellow",
+                                # ... else green
+                                "green"
+                                )
+                              )
+                            )
+             )
+    }
 
   if (any(is.infinite(df$check_value))) {
     cat(

diff --git a/R/validateScenarios.R b/R/validateScenarios.R
@@ -6,11 +6,14 @@
 #'        file on your computer
 #' @param outputFile give name of output file in case results should be exported;
 #'        include file extension
+#' @param extraColors if TRUE, use cyan and blue for violation of min thresholds
+#'        instead of using the same colors as for max thresholds (yel and red)
 #'
 #' @importFrom dplyr filter select mutate group_by %>% bind_rows
 #'
 #' @export
-validateScenarios <- function(dataPath, config, outputFile = NULL) {
+validateScenarios <- function(dataPath, config,
+                              outputFile = NULL, extraColors = TRUE) {
 
   data <- importScenarioData(dataPath)
 
@@ -34,7 +37,7 @@ validateScenarios <- function(dataPath, config, outputFile = NULL) {
 
   # combine scenario data (and reference data if needed) with the respective
   # thresholds for each row of the config and bind all into one data.frame
-  # TODO: parallelization works but makes development harder
+  # TODO: parallelization works but makes development harder, likely not needed
   # future::plan(future::multisession, workers = parallel::detectCores())
   valiData <- bind_rows(
     lapply(1:nrow(cfg), function(i) {
@@ -49,7 +52,7 @@ validateScenarios <- function(dataPath, config, outputFile = NULL) {
   valiData <- resolveDuplicates(valiData)
 
   # perform actual checks and write results in new columns of data.frame
-  valiData <- evaluateThresholds(valiData)
+  valiData <- evaluateThresholds(valiData, extraColors = extraColors)
 
   if (nrow(valiData) == 0) {
     stop("Something went wrong, returned data.frame is empty.")

diff --git a/R/validationHeatmap.R b/R/validationHeatmap.R
@@ -94,10 +94,12 @@ validationHeatmap <- function(df,
     # }
 
     d$period <- as.character(d$period)
-    colors <- c(green  = "#008450",
-                yellow = "#EFB700",
-                red    = "#B81D13",
-                grey   = "#808080")
+    colors <- c(green     = "#008450",
+                yellow    = "#EFB700",
+                red       = "#B81D13",
+                cyan      = "#66ccee",
+                blue      = "#4477aa",
+                grey      = "#808080")
 
 
     # gg tile plot using data along dimensions as given in function call

diff --git a/R/validationReport.R b/R/validationReport.R
@@ -7,13 +7,15 @@
 #' @param report name a .Rmd from inst/markdown ("validationReport_<name>.Rmd")
 #'        to be rendered or give a full path to a separate .Rmd file
 #' @param outputDir choose a directory to save validation reports to
+#' @param extraColors if TRUE, use cyan and blue for violation of min thresholds
+#'        instead of using the same colors as for max thresholds (yel and red)
 #'
 #' @importFrom piamutils getSystemFile
 #'
 #' @export
 
 validationReport <- function(dataPath, config, report = "default",
-                             outputDir = "output") {
+                             outputDir = "output", extraColors = TRUE) {
 
   # convert relative to absolute paths
   dataPath <- normalizePath(dataPath)
@@ -52,7 +54,7 @@ validationReport <- function(dataPath, config, report = "default",
   if (reportName != "default") infix <- paste0(infix, "_rep", reportName)
 
   # create specified report for given data and config
-  yamlParams <- list(mif = dataPath, cfg = config)
+  yamlParams <- list(mif = dataPath, cfg = config, extraColors = extraColors)
   rmarkdown::render(input = reportPath,
                     params = yamlParams,
                     output_file = paste0(outputPath, "/validation", infix,

diff --git a/README.md b/README.md
@@ -1,6 +1,6 @@
 # Validation Tools for PIK-PIAM
 
-R package **piamValidation**, version **0.3.6**
+R package **piamValidation**, version **0.3.7**
 
 [![CRAN status](https://www.r-pkg.org/badges/version/piamValidation)](https://cran.r-project.org/package=piamValidation)  [![R build status](https://github.com/pik-piam/piamValidation/workflows/check/badge.svg)](https://github.com/pik-piam/piamValidation/actions) [![codecov](https://codecov.io/gh/pik-piam/piamValidation/branch/master/graph/badge.svg)](https://app.codecov.io/gh/pik-piam/piamValidation) [![r-universe](https://pik-piam.r-universe.dev/badges/piamValidation)](https://pik-piam.r-universe.dev/builds)
 
@@ -46,7 +46,7 @@ In case of questions / problems please contact Pascal Weigmann <pascal.weigmann@
 
 To cite package **piamValidation** in publications use:
 
-Weigmann P, Richters O (2024). _piamValidation: Validation Tools for PIK-PIAM_. R package version 0.3.6, <https://github.com/pik-piam/piamValidation>.
+Weigmann P, Richters O (2024). _piamValidation: Validation Tools for PIK-PIAM_. R package version 0.3.7, <https://github.com/pik-piam/piamValidation>.
 
 A BibTeX entry for LaTeX users is
 
@@ -55,7 +55,7 @@ A BibTeX entry for LaTeX users is
   title = {piamValidation: Validation Tools for PIK-PIAM},
   author = {Pascal Weigmann and Oliver Richters},
   year = {2024},
-  note = {R package version 0.3.6},
+  note = {R package version 0.3.7},
   url = {https://github.com/pik-piam/piamValidation},
 }
 ```
diff --git a/inst/markdown/validationReport_ELEVATE.Rmd b/inst/markdown/validationReport_ELEVATE.Rmd
@@ -9,6 +9,7 @@ output:
 params:
   mif: ""
   cfg: ""
+  extraColors: true
   warning: false
   message: false
   figWidth: 8
@@ -47,19 +48,15 @@ cat(params$cfg, "\n")
 
 ```{r, message = FALSE, warning = TRUE}
 # Data Preparation
-df <- validateScenarios(params$mif, params$cfg)
+df <- validateScenarios(params$mif, params$cfg, extraColors = params$extraColors)
 df <- appendTooltips(df)
 ```
 
 ## Validation
 
 ### Summary
 ```{r}
-# find "critical == yes" data points, that are red/yellow
-colors <- c(green  = "#008450",
-            yellow = "#EFB700",
-            red    = "#B81D13",
-            grey   = "#808080")
+# find "critical == yes" data points of each color
 dplyr::count(df, critical, check)
 ```
 

diff --git a/inst/markdown/validationReport_default.Rmd b/inst/markdown/validationReport_default.Rmd
@@ -9,6 +9,7 @@ output:
 params:
   mif: ""
   cfg: ""
+  extraColors: true
   warning: false
   message: false
   figWidth: 8
@@ -47,19 +48,15 @@ cat(params$cfg, "\n")
 
 ```{r, message = FALSE, warning = TRUE}
 # Data Preparation
-df <- validateScenarios(params$mif, params$cfg)
+df <- validateScenarios(params$mif, params$cfg, extraColors = params$extraColors)
 df <- appendTooltips(df)
 ```
 
 ## Validation
 
 ### Summary
 ```{r}
-# find "critical == yes" data points, that are red/yellow
-colors <- c(green  = "#008450",
-            yellow = "#EFB700",
-            red    = "#B81D13",
-            grey   = "#808080")
+# find "critical == yes" data points of each color
 dplyr::count(df, critical, check)
 ```
 

diff --git a/man/validateScenarios.Rd b/man/validateScenarios.Rd
diff --git a/man/validationReport.Rd b/man/validationReport.Rd