Merge branch 'add_more_user_requests' into 'main'

add litvalue table, use geom_raster, add error for nonexisting metric options

Closes #49 and #39

See merge request lpjml/lpjmlstats!17

.buildlibrary

@@ -1,4 +1,4 @@
-ValidationKey: '817007'
+ValidationKey: '837060'
 AutocreateReadme: yes
 AcceptedWarnings:
 - 'Warning: package ''.*'' was built under R version'

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: 'lpjmlstats: Statistical tools for LPJmL data analysis'
-version: 0.4.1
-date-released: '2024-07-23'
+version: 0.4.2
+date-released: '2024-07-26'
 abstract: This package provides statistical tools for LPJmL data analysis to be used
   for benchmarking LPJmL outputs.
 authors:

DESCRIPTION

@@ -1,6 +1,6 @@
 Package: lpjmlstats
 Title: Statistical tools for LPJmL data analysis
-Version: 0.4.1
+Version: 0.4.2
 Authors@R: c(
     person("David","Hötten", , "[email protected]", role = c("aut", "cre")),
     person("Jannes","Breier", , "[email protected]", role = c("aut"), comment = c(ORCID = "0000-0002-9055-6904"))
@@ -44,4 +44,4 @@ Config/testthat/edition: 3
 VignetteBuilder: knitr
 Depends:
     R (>= 3.5.0)
-Date: 2024-07-23
+Date: 2024-07-26

NAMESPACE

@@ -24,6 +24,7 @@ export(TimeAvgMap)
 export(TimeAvgMapWithAbs)
 export(aggregate)
 export(benchmark)
+export(create_literature_pdf)
 export(create_pdf_report)
 export(default_settings)
 export(get_benchmark_meta_data)

R/benchmark.R

@@ -212,8 +212,14 @@ benchmark <-
 
     if (pdf_report) {
       cat(cli::col_blue("Start report generation ...\n"))
-      create_pdf_report(benchmark_result, ...)
-      cat(cli::col_green("Report generation completed.\n"))
+      tryCatch({
+        create_pdf_report(benchmark_result, ...)
+        cat(cli::col_green("Pdf report generation completed.\n"))
+      }, error = function(e) {
+        cat(cli::col_red("Error during pdf report generation: "), e$message, "\n")
+      }, warning = function(w) {
+        cat(cli::col_yellow("Warning during pdf report generation: "), w$message, "\n")
+      })
     }
 
     return(benchmark_result)
@@ -254,7 +260,9 @@ create_pdf_report <- function(benchmark_result,
   # copy input Rmd to output and processing dirctory
   path_to_rmd <- system.file("Benchmark_markdown.Rmd", package = "lpjmlstats")
   process_and_out_dir <- dirname(output_file)
-  path_to_rmd_copy <- file.path(process_and_out_dir, "Benchmark_markdown.Rmd")
+  if (!dir.exists(process_and_out_dir))
+    stop("Given directory does not exist")
+  path_to_rmd_copy <- tempfile(fileext = ".Rmd")
   file.copy(path_to_rmd, path_to_rmd_copy)
 
   # render markdown
@@ -264,8 +272,6 @@ create_pdf_report <- function(benchmark_result,
     # pass over current environment
     envir = environment(),
     output_dir = process_and_out_dir,
-    knit_root_dir = process_and_out_dir,
-    intermediates_dir = process_and_out_dir,
     ...
   )
 
@@ -385,8 +391,12 @@ set_options <- function(metrics, m_options) {
   if (!is.null(m_options)) {
     for (metric_names in names(m_options)) {
       metric <- metrics[[metric_names]]
+      if (is.null(metric))
+        stop(paste0("An option is specified for ", metric_names, " but this metric is not used."))
       metric_opt <- m_options[[metric_names]]
       for (opt in names(metric_opt)) {
+        if (!opt %in% names(metric$m_options))
+          stop(paste0("The option ", opt, " does not exist for the metric ", metric_names))
         metric$m_options[[opt]] <- metric_opt[[opt]]
       }
     }
@@ -604,3 +614,27 @@ compare_summaries <- function(metric_list) {
     metric$add_comparisons()
   }
 }
+
+#' Function to create a pdf with a table with literature values
+#' @export
+#' @param output_file filename of the output pdf, can iclude directory
+#' @param ... additional parameters passed to rmarkdown::render
+create_literature_pdf <- function(output_file = "literature_values.pdf", ...) {
+  path_to_rmd <- system.file("Literature_table.Rmd", package = "lpjmlstats")
+  dir <- dirname(output_file)
+  filename <- basename(output_file)
+  path_to_rmd_copy <- tempfile(fileext = ".Rmd")
+  file.copy(path_to_rmd, path_to_rmd_copy)
+  if (!dir.exists(dir))
+    stop("Given directory does not exist")
+
+  # render markdown
+  rmarkdown::render(
+    path_to_rmd_copy,
+    output_file = filename,
+    output_dir = dir,
+    ...
+  )
+
+  unlink(path_to_rmd_copy)
+}

R/plot_functions.R

@@ -154,6 +154,13 @@ map_tibble_to_ggplot <-
            n_breaks = 3,
            limits = NULL) {
 
+    # Crop values to limits and drop NA pixels
+    if (!is.null(limits)) {
+      tibble <- tibble %>%
+        dplyr::mutate(value = pmax(pmin(.data$value, limits[2]), limits[1])) %>%
+        dplyr::filter(!is.na(.data$value))
+    }
+
     # get range
     x_range <- range(tibble$x, na.rm = TRUE)
     y_range <- range(tibble$y, na.rm = TRUE)
@@ -177,7 +184,7 @@ map_tibble_to_ggplot <-
 
     # create basic plot
     p <- ggplot2::ggplot() +
-      ggplot2::geom_tile(data = tibble, ggplot2::aes(
+      ggplot2::geom_raster(data = tibble, ggplot2::aes(
         x = .data$x,
         y = .data$y,
         fill = .data$value

README.md

@@ -1,6 +1,6 @@
 # Statistical tools for LPJmL data analysis
 
-R package **lpjmlstats**, version **0.4.1**
+R package **lpjmlstats**, version **0.4.2**
 
 [![CRAN status](https://www.r-pkg.org/badges/version/lpjmlstats)](https://cran.r-project.org/package=lpjmlstats)  [![R build status](https://github.com/PIK-LPJmL/lpjmlstats/workflows/check/badge.svg)](https://github.com/PIK-LPJmL/lpjmlstats/actions) [![codecov](https://codecov.io/gh/PIK-LPJmL/lpjmlstats/branch/master/graph/badge.svg)](https://app.codecov.io/gh/PIK-LPJmL/lpjmlstats) [![r-universe](https://pik-piam.r-universe.dev/badges/lpjmlstats)](https://pik-piam.r-universe.dev/builds)
 
@@ -48,7 +48,7 @@ In case of questions / problems please contact David Hötten <davidho@pik-potsda
 
 To cite package **lpjmlstats** in publications use:
 
-Hötten D, Breier J (2024). _lpjmlstats: Statistical tools for LPJmL data analysis_. R package version 0.4.1, <https://github.com/PIK-LPJmL/lpjmlstats>.
+Hötten D, Breier J (2024). _lpjmlstats: Statistical tools for LPJmL data analysis_. R package version 0.4.2, <https://github.com/PIK-LPJmL/lpjmlstats>.
 
 A BibTeX entry for LaTeX users is
 
@@ -57,7 +57,7 @@ A BibTeX entry for LaTeX users is
   title = {lpjmlstats: Statistical tools for LPJmL data analysis},
   author = {David Hötten and Jannes Breier},
   year = {2024},
-  note = {R package version 0.4.1},
+  note = {R package version 0.4.2},
   url = {https://github.com/PIK-LPJmL/lpjmlstats},
 }
 ```

inst/Literature_table.Rmd

@@ -0,0 +1,84 @@
+---
+header-includes:
+- \usepackage{booktabs}
+- \usepackage{makecell}
+- \usepackage{float}
+- \usepackage{longtable}
+- \floatplacement{figure}{H} 
+output:
+  pdf_document:
+    toc: false
+    template: default.latex
+title: Literature Values extracted from PIKTools Benchmarking
+---
+
+```{r setup-settings-and-metadata, echo = FALSE}
+knitr::opts_chunk$set(
+  warning = FALSE,
+  message = FALSE,
+  echo = FALSE,
+  fig.pos = "H"
+)
+```
+
+```{r print-simulation-table, results='asis'}
+literature_values <- tibble::tibble(
+  Parameter = c(
+    "vegc", "soilc", "firec",
+    "npp", "harvestc$rainfed tece", "harvestc$rainfed rice",
+    "harvestc$rainfed maize", "harvestc$irrigated tece",
+    "harvestc$irrigated rice", "harvestc$irrigated maize",
+    "nbp"
+  ),
+  Estimate = c(
+    "460 - 660", "2376 - 2456, 1567, 1395", "2.14 (1.6 Nat.Fire)",
+    "66.05, 62.6, 49.52 - 59.74", "524.08", "492.66", "498.33",
+    "524.08", "492.66", "498.33", "1.8 - 3.6"
+  ),
+  Unit = c(
+    "GtC", "GtC", "GtC/year",
+    "GtC/year", "Mt DM/year", "Mt DM/year",
+    "Mt DM/year", "Mt DM/year", "Mt DM/year",
+    "Mt DM/year", "GtC/year"
+  ),
+  Source = c(
+    "1, 2, 3", "4, 5, 6", "7, 8, 9, 10",
+    "11, 2, 12", "13", "13",
+    "13", "13", "13",
+    "13", "14"
+  )
+)
+
+legend <- tibble::tibble(
+  Source = c(1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14),
+  Reference = c(
+    "Olson et al. 1985", "Saugier et al. 2001", "WBGU 1998",
+    "Batjes et al. 1996", "Eswaran et al. 1993", "Post et al. 1982",
+    "Seiler & Crutzen 1980", "Andreae & Merlet 2001", "Ito & Penner 2004",
+    "van der Werf et al. 2004", "Vitousek et al. 1986",
+    "Ramakrishna et al. 2003", "FAOSTAT 1990-2000",
+    "Le Quere et al. 2018"
+  )
+)
+
+# print main table
+kable <- knitr::kable(
+  literature_values,
+  format = "latex",
+  booktabs = TRUE
+)
+kableExtra::kable_styling(kable,
+                          font_size = 8,
+                          latex_options = c("HOLD_position"))
+
+# print source legend table
+kable <- knitr::kable(
+  legend,
+  format = "latex",
+  booktabs = TRUE
+)
+kableExtra::kable_styling(kable,
+                          font_size = 8,
+                          latex_options = c("HOLD_position"))
+```
+

tests/testthat/helper.R

@@ -199,6 +199,8 @@ get_test_m_options <- function() {
   return(m_options)
 }
 
+m_option <- list(year_subset = as.character(c(2009:2018)))
+
 # metric for testing purposes
 .DoNothing <- R6::R6Class( # nolint: object_name_linter.
   ".DoNothing", # nolint: object_name_linter.
@@ -209,12 +211,12 @@ get_test_m_options <- function() {
     },
     compare = function(var_grp) {
       var_grp$compare <- list("nodiff" = list(sim1 = var_grp$baseline))
-    }
+    },
+    m_options = m_option
   )
 )
 
 # test metric options
-m_option <- list(year_subset = as.character(c(2009:2018)))
 test_m_options <- list(GlobSumTimeAvgTable = m_option,
                        GlobSumTimeseries = m_option,
                        TimeAvgMap = m_option,

tests/testthat/testBenchmark.R

@@ -3,7 +3,7 @@ test_that("benchmark produces correct results for global data", {
   under_test_dir <- testthat::test_path("../testdata/path2")
   settings <-
     list(soiln = list(GlobSumTimeAvgTable, GlobSumTimeseries, TimeAvgMap))
-  out <- benchmark(baseline_dir, under_test_dir, settings, pdf_report = FALSE, metric_options = test_m_options)
+  out <- benchmark(baseline_dir, under_test_dir, settings, pdf_report = FALSE, metric_options = test_m_options[-4])
 
   # check that global sum of soiln is still the same
   expect_equal(
@@ -35,7 +35,7 @@ test_that("benchmark runs through for single cell data", {
                             under_test_dir,
                             settings,
                             pdf_report = FALSE,
-                            metric_options = test_m_options))
+                            metric_options = test_m_options[-4]))
 })
 
 test_that("correct meta information ends up in lpjml_calc", {
@@ -44,7 +44,11 @@ test_that("correct meta information ends up in lpjml_calc", {
   settings <-
     list(soiln_layer = list(.DoNothing))
 
-  out <- benchmark(baseline_dir, under_test_dir, settings, pdf_report = FALSE, metric_options = test_m_options)
+  out <- benchmark(baseline_dir,
+                   under_test_dir,
+                   settings,
+                   pdf_report = FALSE,
+                   metric_options = test_m_options[".DoNothing"])
 
   compare_lpjml_calc <-
     out$.DoNothing$var_grp_list$soiln_layer$compare$nodiff$sim1

tests/testthat/testMetric_subclasses.R

@@ -8,7 +8,7 @@ test_that("subset cell produces correct output", {
   metric_opt <- test_m_options
   metric_opt$CellSubsetAnnAvgTimeseries <- c(list(cell = c("10000", "10002")), m_option)
   out <- benchmark(baseline_dir, under_test_dir, settings, pdf_report = FALSE,
-                   metric_options = metric_opt)
+                   metric_options = metric_opt["CellSubsetAnnAvgTimeseries"])
 
   soiln <- read_io(testthat::test_path("../testdata/path1/soiln.bin.json"))
   expected <- subset(soiln, cell = c("10000", "10002"))$.data_with_unit

tests/testthat/testpackage_settings.R

@@ -15,7 +15,7 @@ test_that("metric reordering works", {
       under_test_dir,
       settings,
       pdf_report = FALSE,
-      metric_options = test_m_options
+      metric_options = test_m_options[-4]
     )
 
   expect_true(stringr::str_detect(names(out[1]), "Map"))

tests/testthat/testplot_functions.R

@@ -8,7 +8,7 @@ test_that("plot functions of metric run through", {
     )
 
   out <-
-    benchmark(baseline_dir, under_test_dir, settings, pdf_report = FALSE, metric_options = test_m_options)
+    benchmark(baseline_dir, under_test_dir, settings, pdf_report = FALSE, metric_options = test_m_options[-4])
 
   # NTODO: deal with warnings
   suppressWarnings({