Merge branch 'solve_band_order_issue' into 'main'

use more invariant variable names, solve problem with different band orders

See merge request lpjml/lpjmlstats!20

.buildlibrary

@@ -1,4 +1,4 @@
-ValidationKey: '1202280'
+ValidationKey: '1224697'
 AutocreateReadme: yes
 AcceptedWarnings:
 - 'Warning: package ''.*'' was built under R version'
@@ -7,3 +7,4 @@ AcceptedNotes: checking installed package size
 allowLinterWarnings: no
 enforceVersionUpdate: no
 skipCoverage: no
+AutocreateCITATION: yes

.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: cef0300fd0fc4d2a87a85fa2093c6b283ea36f4b  # frozen: v5.0.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: bae853d82da476eee0e0a57960ee6b741a3b3fb7  # frozen: v0.4.3
+    rev: 3b70240796cdccbe1474b0176560281aaded97e6  # frozen: v0.4.3.9003
     hooks:
     -   id: parsable-R
     -   id: deps-in-desc

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.6.0
-date-released: '2024-11-11'
+version: 0.6.1
+date-released: '2024-12-20'
 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.6.0
+Version: 0.6.1
 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")),
@@ -45,4 +45,4 @@ Config/testthat/edition: 3
 VignetteBuilder: knitr
 Depends:
     R (>= 3.5.0)
-Date: 2024-11-11
+Date: 2024-12-20

R/LPJmLDataCalc.R

@@ -327,12 +327,31 @@ LPJmLDataCalc$set(
   "private",
   ".__apply_operator__",
   function(sec_operand, operator) {
-    # check for matching bandnames
+    # find all dimensions for which the dimnames of sec_operand
+    # should match the dimnames of self$data,
+    # which are all dimensions where sec_operand has more than one element
     dimnames_to_match <- which(dim(sec_operand) > 1)
+
+    # subset and reorder band dimension to make sec_operand compatible with self$data
+    if ("band" %in% names(dimnames_to_match) && !is.null(dimnames(self$data)[["band"]])) {
+      tryCatch(
+        sec_operand <- sec_operand[, , dimnames(self$data)[["band"]], drop = FALSE],
+        error = function(e) {
+          stop(paste("The band dimension of the second operand does not 
+                      match the band dimension of the first operand while calculating ",
+                     format(operator)))
+        }
+      )
+    }
+
+    # check if sec_operand now has the required structure
     if (length(dimnames_to_match) > 0)
       if (!identical(dimnames(sec_operand)[dimnames_to_match],
-                     dimnames(self$data)[dimnames_to_match]))
-        stop("Dimnames of second operand do not match first operator.")
+                     dimnames(self$data)[dimnames_to_match]) ||
+            any(dim(sec_operand)[dimnames_to_match] != dim(self$data)[dimnames_to_match]))
+        stop("A dimension of the second operand does not 
+              match the respective first operand dimension while calculating ",
+             format(operator))
 
     # the dimensions of "self" should stay
     tar_dim <- dim(private$.data)
@@ -343,14 +362,7 @@ LPJmLDataCalc$set(
     expand <- function(x) {
       cur_dim <- dim(x) # current dimension of second operand
       keep <- which(tar_dim == cur_dim) # which dimensions are the same
-      # check if dimensions are incompatible
-      # this is the case if there is a non matching dimension that
-      # has more than one element (i.e. it is not clear how to expand it).
-      # Also, an extra check is needed for the case that no dimensions are
-      # the same which is only allowed if the second operand is a scalar.
-      if (any(cur_dim[-keep] != 1) || (length(keep) == 0 && any(cur_dim != 1)))
-        stop("Dimensions of second operand do not
-              match dimensions of first operand")
+
       if (length(keep) > 0)
         # put the dimensions to keep in front and append the rest
         perm <- c(keep, seq_along(tar_dim)[-keep])
@@ -530,20 +542,27 @@ LPJmLDataCalc$set("private", ".initialize",  function(lpjml_data) {
     stop("Currently only cell format is supported")
   }
 
-  # Ensure the data has the correct format
-  # NTODO: modify tests such that they run through with this
-  # if (!names(dim(lpjml_data$data))[1] == "cell" || # nolint start
-  #     !names(dim(lpjml_data$data))[2] == "time" ||
-  #     !names(dim(lpjml_data$data))[3] == "band"){
-  #    stop("The data must have the following order of dimensions: 1. cell, 2. time, 3. band")
-  # } # nolint end
+  data <- lpjml_data$data
+
+  # Ensure the data has all three "cell", "time", "band" dimensions, in any order
+  if (!("cell" %in% names(dimnames(data)) || "region" %in% names(dimnames(data))) ||
+        !"time" %in% names(dimnames(data)) ||
+        !"band" %in% names(dimnames(data))) {
+    stop("The data must have the following dimensions: (cell/region), time, band")
+  }
 
+  # Reorder the data array to have the dimensions in the correct order, if required
+  # Note that "region" is only used by lpjmlstats, hence if that dimname is present,
+  # the order can be asumed to be correct
+  if (!"region" %in% names(dimnames(data)))
+    if (!identical(names(dimnames(data)), c("cell", "time", "band")))
+      data <- aperm(data, c("cell", "time", "band"))
 
   # Create a new meta enhanced LPJmLMetaDataCalc object
   meta_calc <- LPJmLMetaDataCalc$new(lpjml_data$meta)
 
   # Copy the data from the provided LPJmLData object
-  private$.data <- lpjml_data$data
+  private$.data <- data
   private$.meta <- meta_calc
   private$.grid <- lpjml_data$grid
   private$copy_unit_meta2array()
@@ -652,8 +671,9 @@ read_io <- function(..., output_type = "LPJmLDataCalc") {
 #' Function to coerce (convert) an [`LPJmLData`] object into an
 #' LPJmLDataCalc object with extended functionality.
 #'
-#' @param obj LPJmLData object or an array with the following order of
-#' dimensions: 1. space, 2. time, 3. band.
+#' @param obj LPJmLData object.
+#' For internal package development use the obj can also be an array with the dimension
+#' 1. cell/region, 2. years, 3. bands. The items of the time dimension are then assumed to be different years.
 #'
 #' @return An LPJmLDataCalc object.
 #'
@@ -665,11 +685,12 @@ read_io <- function(..., output_type = "LPJmLDataCalc") {
 
     # check if array has the correct dimensions
     if (length(dim(obj)) != 3) {
-      stop("Array must have 3 dimensions. 1. space, 2. time, 3. band.")
+      stop("Array must have 3 dimensions. 1. cell/region, 2. years, 3. bands.")
     }
 
     header <- lpjmlkit::create_header(ncell = dim(obj)[1],
-                                      nstep = dim(obj)[2],
+                                      nyear = dim(obj)[2],
+                                      nstep = 1,
                                       nbands = dim(obj)[3])
 
     meta <- lpjmlkit::LPJmLMetaData$new(header)

R/LPJmLDataCalc_aggregate.R

@@ -473,6 +473,8 @@ calc_cellarea_wrapper <- function(lpjml_grid) {
     cellsize_lat = lpjml_grid$meta$cellsize_lat,
     ncell = ncell,
     nbands = 1,
+    nstep = 1,
+    nyear = 1,
     verbose = FALSE
   )
   meta <- lpjmlkit::LPJmLMetaData$new(header, list(unit = "m2",

R/LPJmLMetaDataCalc.R

@@ -149,9 +149,8 @@ LPJmLMetaDataCalc <- R6::R6Class( # nolint
     #' @field band_names_disp
     #' named vector, versions of band names used for display, usually shorter
     band_names_disp = function() {
-      # NTODO: check if bandname abbreviation is still needed and posibly add it here
       if (!is.null(private$.band_names))
-        return(private$.band_names)
+        return(private$.band_names)  # abbreviation of band names could be added here if needed
       else
         return(NULL)
     },
@@ -168,10 +167,19 @@ LPJmLMetaDataCalc <- R6::R6Class( # nolint
       return(private$.sim_ident)
     },
 
+    #' @field name
+    #' string, hopefully model version invariant name of the variable
+    name = function() {
+      if (!is.null(private$.name))
+        return(tolower(private$.name))
+      else
+        return(tolower(private$.variable))
+    },
+
     #' @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,
+      paste0(self$name,
              ifelse(is.null(self$band_names_disp),
                     "", "$"),
              # below vanishes if band_names_disp is NULL

R/MetricVarGrp.R

@@ -250,7 +250,7 @@ VarGrp <- # nolint:object_linter_name
       },
 
       get_var_name = function() {
-        self$apply_to_any_lpjml_calc(function(x) x$meta$variable)
+        self$apply_to_any_lpjml_calc(function(x) x$meta$name)
       },
 
       # Function applies the function `fun`

R/memoise_functions.R

@@ -16,9 +16,10 @@ hash_custom <- function(arg_list) {
       # extract content of the LPJmLDataCalc object
       # to avoid hashing the environment
 
-      # NTODO include grid/regiondata to be hashed
       obj <- list(utils::head(obj$data), utils::tail(obj$data),
-                  utils::capture.output(obj$meta$print()))
+                  utils::capture.output(obj$meta$print()),
+                  utils::head(obj$grid$data), utils::tail(obj$grid$data),
+                  utils::head(obj$grid$region_matrix), utils::tail(obj$grid$region_matrix))
     }
     return(obj)
   }

R/plot_functions.R

@@ -146,7 +146,7 @@ lpjml_calc_to_map <- function(lpjml_calc,
   # select the limits that are defined for the type (e.g. "under_test")
   limits_plot <- limits[[pos_in_var_grp$type]]
   plot_title <- paste_custom(
-    ifelse(!m_options$var_subheading, lpjml_calc$meta$variable, ""),
+    ifelse(!m_options$var_subheading, lpjml_calc$meta$name, ""),
     ifelse(!m_options$band_subheading && !is.null(lpjml_calc$meta$band_names),
            lpjml_calc$meta$band_names[[1]], ""),
     lpjml_calc$meta$sim_ident,
@@ -295,7 +295,7 @@ create_time_series_plots <- function(var_grp_list, m_options) {
         var_grp_band$transform_lpjml_calcs(function(x) {
           do.call("subset", c(list(x = x), args))
         })
-        var_name <- var_grp_band$apply_to_any_lpjml_calc(function(x) x$meta$variable)
+        var_name <- var_grp_band$apply_to_any_lpjml_calc(function(x) x$meta$name)
         plot_title <- paste_custom(
           ifelse(!m_options$var_subheading, var_name, ""),
           ifelse(!m_options$band_subheading && length(band_names) > 1, band, ""),

README.md

@@ -1,8 +1,8 @@
 # Statistical tools for LPJmL data analysis
 
-R package **lpjmlstats**, version **0.6.0**
+R package **lpjmlstats**, version **0.6.1**
 
-[![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)
+[![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)
 
 ## Purpose and Functionality
 
@@ -48,16 +48,17 @@ 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, Müller C (2024). _lpjmlstats: Statistical tools for LPJmL data analysis_. R package version 0.6.0, <https://github.com/PIK-LPJmL/lpjmlstats>.
+Hötten D, Breier J, Müller C (2024). "lpjmlstats: Statistical tools for LPJmL data analysis." Version: 0.6.1, <https://github.com/PIK-LPJmL/lpjmlstats>.
 
 A BibTeX entry for LaTeX users is
 
  ```latex
-@Manual{,
+@Misc{,
   title = {lpjmlstats: Statistical tools for LPJmL data analysis},
   author = {David Hötten and Jannes Breier and Christoph Müller},
+  date = {2024-12-20},
   year = {2024},
-  note = {R package version 0.6.0},
   url = {https://github.com/PIK-LPJmL/lpjmlstats},
+  note = {Version: 0.6.1},
 }
 ```