Merge branch 'more_unit_options_and_metrics' into 'main'

refactor of plot functions, more metrics, default units changed, use scientific notation See merge request lpjml/lpjmlstats!15
PIK-LPJmL · Jul 4, 2024 · 625c1f2 · 625c1f2
2 parents 4739da9 + a7fe35f
commit 625c1f2
Show file tree

Hide file tree

Showing 49 changed files with 1,599 additions and 781 deletions.
diff --git a/.buildlibrary b/.buildlibrary
@@ -1,4 +1,4 @@
-ValidationKey: '457378'
+ValidationKey: '597240'
 AutocreateReadme: yes
 AcceptedWarnings:
 - 'Warning: package ''.*'' was built under R version'

diff --git a/.github/workflows/check.yaml b/.github/workflows/check.yaml
@@ -11,7 +11,7 @@ jobs:
     runs-on: ubuntu-latest
 
     steps:
-      - uses: actions/checkout@v4
+      - uses: actions/checkout@v3
 
       - uses: r-lib/actions/setup-pandoc@v2
 
@@ -35,7 +35,7 @@ jobs:
           # gms, goxygen, GDPuc) will usually have an outdated binary version
           # available; by using extra-packages we get the newest version
 
-      - uses: actions/setup-python@v5
+      - uses: actions/setup-python@v4
         with:
           python-version: 3.9
 
@@ -48,11 +48,6 @@ jobs:
         shell: Rscript {0}
         run: lucode2:::validkey(stopIfInvalid = TRUE)
 
-      - name: Verify that lucode2::buildLibrary was successful
-        if: github.event_name == 'pull_request'
-        shell: Rscript {0}
-        run: lucode2:::isVersionUpdated()
-
       - name: Checks
         shell: Rscript {0}
         run: |
@@ -61,8 +56,6 @@ jobs:
 
       - name: Test coverage
         shell: Rscript {0}
-        run: |
-          nonDummyTests <- setdiff(list.files("./tests/testthat/"), c("test-dummy.R", "_snaps"))
-          if(length(nonDummyTests) > 0) covr::codecov(quiet = FALSE)
+        run: covr::codecov(quiet = FALSE)
         env:
           NOT_CRAN: "true"
diff --git a/.pre-commit-config.yaml b/.pre-commit-config.yaml
@@ -3,7 +3,7 @@
 exclude: '^tests/testthat/_snaps/.*$'
 repos:
 -   repo: https://github.com/pre-commit/pre-commit-hooks
-    rev: 2c9f875913ee60ca25ce70243dc24d5b6415598c  # frozen: v4.6.0
+    rev: v4.4.0
     hooks:
     -   id: check-case-conflict
     -   id: check-json
@@ -15,7 +15,7 @@ repos:
     -   id: mixed-line-ending
 
 -   repo: https://github.com/lorenzwalthert/precommit
-    rev: 7910e0323d7213f34275a7a562b9ef0fde8ce1b9  # frozen: v0.4.2
+    rev: v0.3.2.9019
     hooks:
     -   id: parsable-R
     -   id: deps-in-desc

diff --git a/CITATION.cff b/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.2.3
-date-released: '2024-06-12'
+version: 0.3.0
+date-released: '2024-07-04'
 abstract: This package provides statistical tools for LPJmL data analysis to be used
   for benchmarking LPJmL outputs.
 authors:

diff --git a/DESCRIPTION b/DESCRIPTION
@@ -1,6 +1,6 @@
 Package: lpjmlstats
 Title: Statistical tools for LPJmL data analysis
-Version: 0.2.3
+Version: 0.3.0
 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"))
@@ -32,7 +32,9 @@ Imports:
     patchwork,
     tibble,
     cli,
-    raster
+    raster,
+    tidyselect,
+    R6
 Suggests: 
     testthat (>= 3.0.0),
     maps,
@@ -42,4 +44,5 @@ Config/testthat/edition: 3
 VignetteBuilder: knitr
 Depends:
     R (>= 3.5.0)
-Date: 2024-06-12
+Date: 2024-07-04
+
diff --git a/NAMESPACE b/NAMESPACE
@@ -6,6 +6,8 @@ S3method("-",LPJmLDataCalc)
 S3method("/",LPJmLDataCalc)
 S3method(subset,LPJmLDataCalc)
 export(.as_LPJmLDataCalc)
+export(CellSubsetAnnAvgTimeseries)
+export(CellSubsetTimeseries)
 export(GlobAvgAnnAvgTimeseries)
 export(GlobAvgTimeAvgTable)
 export(GlobAvgTimeseries)
@@ -19,6 +21,7 @@ export(GlobSumTimeseries)
 export(LPJmLDataCalc)
 export(Metric)
 export(TimeAvgMap)
+export(TimeAvgMapWithAbs)
 export(aggregate)
 export(benchmark)
 export(create_pdf_report)
@@ -33,14 +36,17 @@ import(patchwork)
 importFrom(Matrix,Matrix)
 importFrom(Matrix,colSums)
 importFrom(Matrix,sparseMatrix)
+importFrom(R6,R6Class)
 importFrom(abind,abind)
 importFrom(dplyr,"%>%")
 importFrom(jsonlite,fromJSON)
 importFrom(memoise,forget)
 importFrom(memoise,memoise)
 importFrom(methods,as)
+importFrom(rlang,":=")
 importFrom(rlang,.data)
 importFrom(rlang,hash)
+importFrom(tidyselect,matches)
 importFrom(units,as_units)
 importFrom(units,deparse_unit)
 importFrom(units,drop_units)

diff --git a/R/LPJmLDataCalc.R b/R/LPJmLDataCalc.R
@@ -4,7 +4,7 @@
 #' @import lpjmlkit
 #' @importFrom abind abind
 #' @importFrom Matrix sparseMatrix Matrix colSums
-#'
+#' @importFrom R6 R6Class
 #' @description
 #' An extended LPJmLData class that enables arithmetic and statistics.
 #'
@@ -71,7 +71,6 @@ LPJmLDataCalc <- R6::R6Class( # nolint:object_linter_name
     },
 
 
-
     #' @description
     #' Check consistency of data and meta data
     #' !Internal method only to be used for package development!
@@ -146,22 +145,6 @@ LPJmLDataCalc <- R6::R6Class( # nolint:object_linter_name
       private$.__apply_unit_conversion_table__(path_to_table)
     },
 
-    #' @description
-    #' !Internal method only to be used for package development!
-    #' Set the simulation identifier to the LPJmLDataCalc object.
-    #' @param identifier A string with the identifier to set.
-    set_sim_identifier = function(identifier) {
-      private$.meta$.__set_sim_identifier__(identifier)
-    },
-
-    #' @description
-    #' !Internal method only to be used for package development!
-    #' Get the simulation identifier of the LPJmLDataCalc object.
-    #' @return A string with the simulation identifier.
-    get_sim_identifier = function() {
-      private$.meta$.__get_sim_identifier__()
-    },
-
     #' @description
     #' Add a grid to the LPJmLDataCalc object
     #' Wrapper for the `add_grid` method of the `LPJmLData` class.
@@ -184,8 +167,14 @@ LPJmLDataCalc <- R6::R6Class( # nolint:object_linter_name
     #' Returns the internal enclosed unit object
     #' !Internal method only to be used for package development!
     .data_with_unit = function() {
-      # NTODO: is this the correct way to indicate function not for end user?
       return(private$.data)
+    },
+
+    #' @field .meta
+    #' Returns the actual LPJmLMetaDataCalc object
+    #' !Internal method only to be used for package development!
+    .meta = function() {
+      return(private$.meta)
     }
   )
 )
@@ -251,7 +240,15 @@ LPJmLDataCalc$set("private", "copy_unit_meta2array",
                       }
                       return(x)
                     }
-                    unit <- insert_caret(private$.meta$unit)
+                    unit <- private$.meta$unit
+                    # The units::set_units methods only accepts two formats
+                    # either using "g/m" and "m^2" or using "g m-1" and "m2".
+                    # Therefore, if the unit string contains the division
+                    # symbol "/", also the caret must be there.
+                    # Once the data is read in one time, both "/" and "^" are
+                    # eliminated, and only the standard second format is used.
+                    if (stringr::str_detect(private$.meta$unit, "/"))
+                      unit <- insert_caret(unit)
                     unit <- set_minussign_to_nounit(unit)
                     private$.data <- units::set_units(private$.data,
                                                       as_units(unit))
@@ -314,6 +311,7 @@ LPJmLDataCalc$set(
       # Convert the unit
       private$.__convert_unit__(converted_unit)
     }
+    return(invisible(self))
   }
 )
 
@@ -539,6 +537,8 @@ LPJmLDataCalc$set("private", ".initialize",  function(lpjml_data) {
   private$.meta <- meta_calc
   private$.grid <- lpjml_data$grid
   private$copy_unit_meta2array()
+  # the following is to consistently have the unit formatting from units package
+  private$copy_unit_array2meta()
 })
 
 

diff --git a/R/LPJmLMetaDataCalc.R b/R/LPJmLMetaDataCalc.R
@@ -94,9 +94,20 @@ LPJmLMetaDataCalc <- R6::R6Class( # nolint
       cat(
         paste0(
           spaces,
-          cli::col_blue("$sim_identifier"),
+          cli::col_blue("$sim_ident"),
           " ",
-          self$.__get_sim_identifier__(),
+          self$sim_ident,
+          "\n"
+        )
+      )
+
+      # print sim path abbreviation
+      cat(
+        paste0(
+          spaces,
+          cli::col_blue("$pos_in_var_grp"),
+          " ",
+          self$pos_in_var_grp,
           "\n"
         )
       )
@@ -105,37 +116,132 @@ LPJmLMetaDataCalc <- R6::R6Class( # nolint
     #' @description
     #' Set the simulation identifier
     #' !Internal method only to be used for package development!
-    #' @param sim_identifier string, simulation identifier
-    .__set_sim_identifier__ = function(sim_identifier) {
-      private$.sim_identifier <- sim_identifier
+    #' @param sim_ident string, simulation identifier
+    .__set_sim_ident__ = function(sim_ident) {
+      private$.sim_ident <- sim_ident
     },
 
     #' @description
+    #' Set the position of the lpjml_calc inside of its var_grp.
     #' !Internal method only to be used for package development!
-    #' @return string, simulation identifier
-    .__get_sim_identifier__ = function() {
-      return(private$.sim_identifier)
+    #' @param pos_in_var_grp A list with the position of the lpjml_calc
+    #' inside of the var_grp. The first entry is the type; can be
+    #' "baseline", "under_test" or "compare".
+    #' The second entry is the compare item if
+    #' of type "compare", e.g. "diff".
+    #' E.g. list("under_test") or list("compare", "diff").
+    .__set_pos_in_var_grp__ = function(pos_in_var_grp) {
+      private$.pos_in_var_grp <- pos_in_var_grp
     }
+
   ),
 
   active = list(
-    #' @field space_aggregation Indication weather the data has been
+    #' @field space_aggregation boolean, Indication weather the data has been
     #' subject to space aggregation.
     space_aggregation = function() {
       return(private$.space_aggregation)
     },
 
-    #' @field time_aggregation Indication weather the data has been
+    #' @field time_aggregation boolean, Indication weather the data has been
     #' subject to time aggregation.
     time_aggregation = function() {
       return(private$.time_aggregation)
+    },
+
+    #' @field band_names_disp
+    #' named vector, versions of band names used for display, usually shorter
+    band_names_disp = function() {
+      if (!is.null(private$.band_names))
+        return(shorten_names(private$.band_names))
+      else
+        return(NULL)
+    },
+
+    #' @field pos_in_var_grp
+    #' list, position of the lpjml_calc inside of its var_grp.
+    pos_in_var_grp = function() {
+      return(private$.pos_in_var_grp)
+    },
+
+    #' @field sim_ident
+    #' string, simulation identifier
+    sim_ident = function() {
+      return(private$.sim_ident)
+    },
+
+    #' @field var_and_band_disp
+    #' string, variable name together with name of first band, e.g. `soiln$200`
+    var_and_band_disp = function() {
+      paste0(self$variable,
+             ifelse(is.null(self$band_names_disp),
+                    "", "$"),
+             # below vanishes if band_names_disp is NULL
+             self$band_names_disp[[1]])
     }
   ),
 
   private = list(
     .space_aggregation = NULL,
     .time_aggregation = NULL,
-    .sim_identifier = "notset"
-
+    .sim_ident = "undefined simulation",
+    .pos_in_var_grp = list("undefined position in var_grp")
   )
 )
+
+
+# NTODO: needs refactoring
+shorten_names <- function(names, trunc = 9) {
+
+  # find index until which all strings are equal
+  stop <- FALSE
+  i <- 0
+  while (stop == FALSE) {
+    i <- i + 1
+    if (length(unique(substr(
+      x = names,
+      start = 1,
+      stop = i
+    ))) > 1) {
+
+      stop <- TRUE
+    }
+
+    if (i > max(stringr::str_length(names))) {
+      stop <- TRUE
+    }
+  }
+  i <- i - 1
+
+  if (i > trunc + 9) {
+    front_parts <- names %>% stringr::str_sub(1, 4)
+    back_parts <- names %>% stringr::str_sub(max(i - 3, 6))
+    short_colnames <- paste0(front_parts, "[..]", back_parts)
+  } else {
+    short_colnames <- names
+  }
+
+  # find index from which all remaining truncated strings are unique
+  stop <- FALSE
+  i <- 0
+  while (stop == FALSE) {
+    i <- i + 1
+    if (length(unique(substr(
+      x = short_colnames,
+      start = 1,
+      stop = i
+    ))) == length(unique(short_colnames
+    ))) {
+
+      stop <- TRUE
+    }
+  }
+
+  trunc <- max(i + 6, trunc + 6)
+
+  short_colnames <- stringr::str_trunc(short_colnames, trunc, ellipsis = "[..]")
+
+  names(short_colnames) <- names
+
+  return(short_colnames)
+}