Merge pull request #14 from pweigmann/plotting

Plotting

.buildlibrary

@@ -1,4 +1,4 @@
-ValidationKey: '739445'
+ValidationKey: '801840'
 AutocreateReadme: yes
 AcceptedWarnings:
 - 'Warning: package ''.*'' was built under R version'
@@ -11,3 +11,4 @@ AcceptedNotes:
 - Non-standard file/directory found at top level: output
 allowLinterWarnings: yes
 enforceVersionUpdate: no
+skipCoverage: no

.github/workflows/check.yaml

@@ -23,14 +23,14 @@ jobs:
       - uses: r-lib/actions/setup-r-dependencies@v2
         with:
           extra-packages: |
-            any::lucode2
-            any::covr
-            any::madrat
-            any::magclass
-            any::citation
-            any::gms
-            any::goxygen
-            any::GDPuc
+            lucode2
+            covr
+            madrat
+            magclass
+            citation
+            gms
+            goxygen
+            GDPuc
           # piam packages also available on CRAN (madrat, magclass, citation,
           # gms, goxygen, GDPuc) will usually have an outdated binary version
           # available; by using extra-packages we get the newest version
@@ -63,6 +63,6 @@ jobs:
         shell: Rscript {0}
         run: |
           nonDummyTests <- setdiff(list.files("./tests/testthat/"), c("test-dummy.R", "_snaps"))
-          if(length(nonDummyTests) > 0) covr::codecov(quiet = FALSE)
+          if(length(nonDummyTests) > 0 && !lucode2:::loadBuildLibraryConfig()[["skipCoverage"]]) covr::codecov(quiet = FALSE)
         env:
           NOT_CRAN: "true"

CITATION.cff

@@ -2,8 +2,8 @@ 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.7
-date-released: '2024-09-19'
+version: 0.4.0
+date-released: '2024-11-19'
 abstract: The piamValidation package provides validation tools for the Potsdam Integrated
   Assessment Modelling environment.
 authors:

DESCRIPTION

@@ -1,8 +1,8 @@
 Type: Package
 Package: piamValidation
 Title: Validation Tools for PIK-PIAM
-Version: 0.3.7
-Date: 2024-09-19
+Version: 0.4.0
+Date: 2024-11-19
 Authors@R:
     c(person("Pascal", "Weigmann",, "[email protected]", role = c("aut", "cre")),
       person("Oliver", "Richters",, role = "aut"))

NAMESPACE

@@ -19,7 +19,6 @@ importFrom(dplyr,ungroup)
 importFrom(ggthemes,theme_tufte)
 importFrom(piamInterfaces,areUnitsIdentical)
 importFrom(piamutils,getSystemFile)
-importFrom(plotly,ggplotly)
 importFrom(readxl,excel_sheets)
 importFrom(readxl,read_excel)
 importFrom(utils,read.csv2)

R/importFunctions.R

@@ -68,13 +68,13 @@ getConfig <- function(configName) {
   return(cfg)
 }
 
-# fill empty threshold columns with Infinity for easier evaluation
+# fill empty and NA threshold columns with Infinity for easier evaluation
 fillInf <- function(cfg) {
   cfg <- cfg %>%
-    mutate(min_red = as.numeric(ifelse(is.na(min_red), -Inf, min_red)),
-           min_yel = as.numeric(ifelse(is.na(min_yel), -Inf, min_yel)),
-           max_yel = as.numeric(ifelse(is.na(max_yel),  Inf, max_yel)),
-           max_red = as.numeric(ifelse(is.na(max_red),  Inf, max_red))
+    mutate(min_red = as.numeric(ifelse(is.na(min_red) | min_red == "NA", -Inf, min_red)),
+           min_yel = as.numeric(ifelse(is.na(min_yel) | min_yel == "NA", -Inf, min_yel)),
+           max_yel = as.numeric(ifelse(is.na(max_yel) | max_yel == "NA",  Inf, max_yel)),
+           max_red = as.numeric(ifelse(is.na(max_red) | max_red == "NA",  Inf, max_red))
            )
 
   return(cfg)

R/validationHeatmap.R

@@ -1,138 +1,176 @@
-#' takes the output of "validateScenarios()" and plots heatmaps per variable
+#' takes the output of "validateScenarios()" and plots heat maps per variable
 #'
-#' @param df data.frame as returned by ``validateScenarios()``
-#'        and ``appendTooltips()``
-#' @param var variable to be plotted
-#' @param met choose metric from "relative", "difference", "absolute" or
-#'        "growthrate"
-#' @param historical should this be a plot comparing to historical data
+#' @param df data.frame to be plotted, as returned by ``validateScenarios()``
+#'        (and ``appendTooltips()`` if interactive), plus optional filtering.
+#'        Needs to have at least one dimension with only one unique element.
+#' @param main_dim out of the 5-dim df, 1 dim has to contain only on element,
+#'        this is the main dimension of the plot, default: variable
 #' @param interactive return plots as interactive plotly plots by default
-#' @param x_plot choose dimension to display on x-axis of plot, default: region
-#' @param y_plot choose dimension to display on y-axis of plot, default: period
-#' @param x_facet choose dimension to display on x-dim of facets, default: model
-#' @param y_facet choose dimension to display on x-dim of facets, default: scenario
+#' @param x_plot choose dimension to display on x-axis of plot, if any
+#'        is NULL, arrangement is chosen automatically based on data dimensions
+#' @param y_plot choose dimension to display on y-axis of plot
+#' @param x_facet choose dimension to display on x-dim of facets
+#' @param y_facet choose dimension to display on x-dim of facets
 #'
 #' @importFrom dplyr filter select mutate %>%
 #' @import ggplot2
 #' @importFrom ggthemes theme_tufte
-#' @importFrom plotly ggplotly
 #' @export
 
 validationHeatmap <- function(df,
-                              var,
-                              met,
-                              historical = TRUE,
-                              interactive = TRUE,
-                              x_plot = "region",
-                              y_plot = "period",
-                              x_facet = "model",
-                              y_facet = "scenario") {
-
-  # wip: when giving multiple vars, plot as facets in same row
-  if (length(var) > 1) {
-    d <- df3 %>%
-      filter(.data$metric == met)
-    if (historical) {
-      d <- filter(d, ref_scenario == "historical")
-      plot_title <- paste0("Summary ", met, " (historical)")
-    } else {
-      d <- filter(d, (ref_scenario != "historical" | is.na(ref_scenario)))
-      plot_title <- paste0("Summary ", met)
-    }
+                              main_dim = "variable",
+                              x_plot  = NULL, y_plot  = NULL,
+                              x_facet = NULL, y_facet = NULL,
+                              interactive = TRUE) {
+
+  # setup ####
+
+  plot_title <- paste0(df[1, main_dim])
+
+  # prepare data
+  df$period <- as.character(df$period)
+  standard_dims <- c("model", "scenario", "variable", "region", "period")
+  colors <- c(green     = "#008450",
+              yellow    = "#EFB700",
+              red       = "#B81D13",
+              cyan      = "#66ccee",
+              blue      = "#4477aa",
+              grey      = "#808080")
+
+  # check arguments ####
+
+  # check if valid name for main_dim is passed
+  if (!main_dim %in% standard_dims) {
+    stop("Please choose 'main_dim' from the standard dimensions: \n",
+         "model, scenario, variable, region or period\n")
+  }
 
-    # gg tile plot using data along dimensions as given in function call
-    x_plot <- "scenario"
-    y_plot <- "variable"
-
-    p <- ggplot(d, aes(x = .data[[x_plot,]],
-                       y = .data[[y_plot,]],
-                       fill = score)) +
-      geom_tile(color="white", linewidth=0.0) +
-      scale_fill_gradient2(low="#008450", high="#B81D13", guide="colorbar") +
-      labs(x = NULL, y = NULL, title = plot_title) +
-      theme_tufte(base_family = "Helvetica") +  # creates warnings
-      theme(axis.ticks = element_blank()) +
-      theme(axis.text = element_text(size = 10)) +
-      theme(axis.text.x = element_text(angle = 90, vjust = 0.5, hjust=1)) +
-      theme(strip.text.x = element_text(angle = 90, vjust = 0.5, hjust=1)) +
-      coord_equal() +
-      theme(legend.position = "none")
-
-    # create small gap to "World" data by creating white outline
-    if("World" %in% d$region) {
-      p <- p + geom_vline(xintercept = 1.5, linewidth = 0.8, color = "white")
-    }
-    fig <- ggplotly(p, tooltip = "text")
+  # check if data.frame has at least one dimension of only one element
+  if (length(unique(df[, main_dim])) > 1) {
+    cat("Data dimensions: \n")
+    print(lengths(lapply(df[, standard_dims], unique)))
+    stop(main_dim, " (main_dim) can only contain one unique element,
+  Please filter data before plotting or select a different main_dim.\n")
+  }
 
-    # if only one variable if passed to function
-  } else {
+  # check validation categories, only one per plot allowed
+  # TODO: ref_scenario is not checked, but important as "historical" signals a
+  # different type of check. Problem: how to deal with "regular" scenario
+  # comparison to multiple different scenarios
+  if (length(unique(df[, c("metric")])) > 1) {
+    cat("Validation types: \n")
+    print(unique(df[, c("metric")]))
+    stop("Multiple categories of checks found in data, please filter the data
+  object to contain only one metric.\n")
+  }
 
-    # prepare data slice which will be plotted
-    d <- df %>%
-      filter(.data$variable == var,
-             .data$metric == met)
+  # check if an incomplete set of x/y_plot/facet arguments is passed
+  null_args <- sum(sapply(list(x_plot, y_plot, x_facet, y_facet), is.null))
+  if (null_args %in% c(1, 2, 3)) {
+    stop("Please define either all 'plot' and 'facet' arguments or none.")
+  }
 
-    if (historical) {
-      d <- filter(d, ref_scenario == "historical")
-      plot_title <- paste0(var, " [", d$unit[1], "] - ", met, " (historical)")
+  # arranging dimensions ####
+  if (any(is.null(c(x_plot, y_plot, x_facet, y_facet)))) {
+    # select dimensions except main_dim and how they should be plotted
+    # length of each dim important to find the best arrangement of axis and facets
+    # generally preferred, period and region as axis, scenario and model as facets
+    # variable wherever there is space
+    dim_length <- sort(lengths(
+      lapply(df[, setdiff(standard_dims, main_dim)], unique)
+      ))
+    other_dims <- names(dim_length)
+
+    # 3 possible ways to form 2 groups of 2 dimensions each
+    # start by creating possible dimension products
+    p <- as.data.frame(matrix(NA, 3, 2))
+    p[1, ] <- c(dim_length[1]*dim_length[2], dim_length[3]*dim_length[4])
+    p[2, ] <- c(dim_length[1]*dim_length[3], dim_length[2]*dim_length[4])
+    p[3, ] <- c(dim_length[1]*dim_length[4], dim_length[2]*dim_length[3])
+
+    # select combination that is closest to ideal plot layout ratio (x/y)
+    ideal <- 2
+    # determine ratio of bigger to smaller dim products,
+    # V1 is the first product, V2 the second product
+    p <- mutate(p, ratio = ifelse(V2 > V1, abs(V2/V1 - ideal), abs(V1/V2 - ideal)))
+    # find idx of row closest to ideal
+    ideal_idx <- which(p[, "ratio"] == min(p[, "ratio"]), arr.ind = TRUE)[1]
+
+    # idx is found, but we don't know if the first or second product is the larger
+    # one and thus should be on the y-axis and y-facet
+    if (p[ideal_idx, "V1"] < p[ideal_idx, "V2"]) {
+      # V1 always contains the the first other dim "other_dims[1]"
+      # (dim_length and other_dims have same order of elements)
+      # other element of V1 product has index "ideal_idx" + 1 by definition
+      # region or period should be "plot" if possible
+      y_plot  <- ifelse(other_dims[1] %in% c("period", "region"),
+                        other_dims[1],
+                        other_dims[ideal_idx + 1])
+      y_facet <- ifelse(other_dims[1] %in% c("period", "region"),
+                        other_dims[ideal_idx + 1],
+                        other_dims[1])
+
+      # remaining two dimensions are used for x axis and facet
+      x_dims <- setdiff(c(2,3,4), ideal_idx + 1)
+      x_plot <- ifelse(other_dims[x_dims[1]] %in% c("period", "region"),
+                       other_dims[x_dims[1]],
+                       other_dims[x_dims[2]])
+      x_facet <- ifelse(other_dims[x_dims[1]] %in% c("period", "region"),
+                        other_dims[x_dims[2]],
+                        other_dims[x_dims[1]])
     } else {
-      d <- filter(d, (ref_scenario != "historical" | is.na(ref_scenario)))
-      plot_title <- paste0(var, " [", d$unit[1], "] - ", met)
-    }
-
-    # warn if no data is found for combination of var, cat and met
-    # TODO: fix for case without category
-    # if (nrow(d) == 0) {
-    #   data$cm <- paste(metric, sep = "-")
-    #   warning(
-    #     paste0(
-    #       "No data found for variable in this category and metric.\n
-    #       variable ", var ," is available for the following category-metric
-    #       combinations: ", unique(data[data$variable == var, "cm"])
-    #       )
-    #     )
-    # }
-
-    d$period <- as.character(d$period)
-    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
-    p <- ggplot(d, aes(x = .data[[x_plot,]],
-                       y = .data[[y_plot,]],
-                       fill = check,
-                       text = text)) +
-      geom_tile(color="white", linewidth=0.0) +
-      scale_fill_manual(values = colors, breaks = colors) +
-      facet_grid(.data[[y_facet,]] ~ .data[[x_facet,]]) +
-      labs(x = NULL, y = NULL, title = plot_title) +
-      theme_tufte(base_family = "Helvetica") +  # creates warnings
-      theme(axis.ticks = element_blank()) +
-      theme(axis.text = element_text(size = 9)) +
-      theme(axis.text.x = element_text(angle = 90, vjust = 0.5, hjust=1)) +
-      coord_equal() +
-      theme(legend.position = "none")
-
-    # tweak for ELEVATE: to make facet labels and title readable
-    if (x_facet == "scenario") {
-      p <- p +
-        theme(strip.text.x = element_text(angle = 30, vjust = 0.5, hjust=1)) +
-        theme(strip.text.y = element_text(angle = 0, vjust = 0.5, hjust=1))
+      # same as "if", just switched x and y
+      x_plot  <- ifelse(other_dims[1] %in% c("period", "region"),
+                        other_dims[1],
+                        other_dims[ideal_idx + 1])
+      x_facet <- ifelse(other_dims[1] %in% c("period", "region"),
+                        other_dims[ideal_idx + 1],
+                        other_dims[1])
+
+      y_dims <- setdiff(c(2,3,4), ideal_idx + 1)
+      y_plot <- ifelse(other_dims[y_dims[1]] %in% c("period", "region"),
+                       other_dims[y_dims[1]],
+                       other_dims[y_dims[2]])
+      y_facet <- ifelse(other_dims[y_dims[1]] %in% c("period", "region"),
+                        other_dims[y_dims[2]],
+                        other_dims[y_dims[1]])
     }
-
-    # create small gap to "World" data by creating white outline
-    if("World" %in% d$region) {
-      p <- p + geom_vline(xintercept = 1.5, linewidth = 0.8, color = "white")
-    }
-    fig <- ggplotly(p, tooltip = "text")
   }
 
+  # plot ####
+  p <- ggplot(df, aes(x = .data[[x_plot, ]],
+                      y = .data[[y_plot, ]],
+                      fill = check,
+                      text = text)) +
+    geom_tile(color = "white", linewidth = 0.0) +
+    scale_fill_manual(values = colors, breaks = colors) +
+    facet_grid(.data[[y_facet, ]] ~ .data[[x_facet, ]]) +
+    labs(x = NULL, y = NULL, title = plot_title) +
+    theme_tufte(base_family = "Arial") +
+    theme(axis.ticks = element_blank()) +     # remove ticks
+    theme(axis.text  = element_text(size = 8)) +  # font size plot labels
+    theme(strip.text = element_text(size = 8)) +  # font size facet labels
+    # default labels for axis and facets, might need to be adjusted depending
+    # on plot layout
+    theme(axis.text.x  = element_text(angle = 90, vjust = 0.5, hjust = 1)) +
+    theme(axis.text.y  = element_text(angle =  0, vjust = 0.5, hjust = 1)) +
+    theme(strip.text.x = element_text(angle = 90, vjust = 0.5, hjust = 0)) +
+    theme(strip.text.y = element_text(angle =  0, vjust = 0.5, hjust = 0)) +
+    coord_equal() +
+    theme(legend.position = "none")
+
+  # create small gap to "World" data by creating white outline
+  # -> in some cases this creates an area where tooltips do not work, disabled
+  #if("World" %in% d$region) {
+    #p <- p + geom_vline(xintercept = 1.5, linewidth = 0.6, color = "white")
+  #}
+
   if (interactive) {
+    # create interactive element
+    fig <- plotly::ggplotly(p, tooltip = "text") %>%
+    # avoid overlap of title and facet labels (plotly issue)
+    plotly::layout(title = list(y = .95, xref = "plot"),
+                   margin = list(l = 0, t = 150, r = 150))
     return(fig)
   } else {
     return(p)