Merge pull request #99 from 0UmfHxcvx5J7JoaOhFSs5mncnisTJJ6q/fix/read…

….gdx

correctly return multi-dimensional sets with identical defining set names in .read.gdx_gamstransfer()

.buildlibrary

@@ -1,4 +1,4 @@
-ValidationKey: '625976934'
+ValidationKey: '626216492'
 AcceptedWarnings:
 - 'Warning: package ''.*'' was built under R version'
 - 'Warning: namespace ''.*'' is not available and has been replaced'

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: 'quitte: Bits and pieces of code to use with quitte-style data frames'
-version: 0.3137.1
-date-released: '2024-08-19'
+version: 0.3137.2
+date-released: '2024-08-26'
 abstract: A collection of functions for easily dealing with quitte-style data frames,
   doing multi-model comparisons and plots.
 authors:

DESCRIPTION

@@ -1,8 +1,8 @@
 Type: Package
 Package: quitte
 Title: Bits and pieces of code to use with quitte-style data frames
-Version: 0.3137.1
-Date: 2024-08-19
+Version: 0.3137.2
+Date: 2024-08-26
 Authors@R: c(
     person("Michaja", "Pehl", , "[email protected]", role = c("aut", "cre")),
     person("Nico", "Bauer", , "[email protected]", role = "aut"),

R/read.gdx.R

@@ -182,6 +182,25 @@ init_gdxrrw <- function() {
         0 == d[['dimension']]
     }
 
+    is.integer.string <- function(x) {
+        all(grepl('^[0-9]+$', x))
+    }
+
+    nothing.defined <- function(d) {
+        is.null(d[['records']])
+    }
+
+    make.gamstransfer.names <- function(s) {
+        for (i in seq_along(s)) {
+            matches <- s[i] == s
+            count <- sum(matches)
+            if (1 < count) {
+                s[matches] <- paste(s[i], seq_len(count), sep = '_')
+            }
+        }
+        return(s)
+    }
+
     convert_field_names <- function(fields) {
         # convert short (gdxrrw) to long (gamstransfer) field names, check for
         # unknown field names
@@ -220,16 +239,16 @@ init_gdxrrw <- function() {
 
     # select correct fields ----
     # only equations and variables have fields, parameters always report value
-    if (is.Set(d)) {
-        fields <- character(0)
+    fields <- if (is.Set(d)) {
+        character(0)
     } else if (is.Parameter(d)) {
-        fields <- 'value'
+        'value'
     } else {
-        fields <- convert_field_names(fields)
+        convert_field_names(fields)
     }
 
     # select correct columns ----
-    column_selector <- c(d[['domain']], fields)
+    column_selector <- c(make.gamstransfer.names(d[['domain']]), fields)
     if (!is.null(colNames)) {
         if (length(colNames) != length(column_selector)) {
             cli_abort(c(
@@ -241,17 +260,29 @@ init_gdxrrw <- function() {
         }
 
         column_selector <- setNames(column_selector, colNames)
-    } else if ('level' %in% column_selector) {
-        # level is always reported as value
-        column_selector <- setNames(column_selector,
-                                    sub('level', 'value', column_selector,
-                                        fixed = TRUE))
+    } else {
+        column_selector <- setNames(
+            column_selector,
+            c(  # unique names for identical defining sets
+                make.names(d[['domain']], unique = TRUE),
+                # always return `level` as `value`
+                sub('level', 'value', fields, fixed = TRUE)))
     }
 
     # filter data ----
-    result <- as_tibble(d[['records']]) %>%
-        select(all_of(column_selector)) %>%
-        mutate(across(where(is.factor), as.character))
+    result <- if (nothing.defined(d)) {
+        matrix(nrow = 0, ncol = length(column_selector),
+               dimnames = list(NULL, column_selector)) %>%
+            as_tibble() %>%
+            mutate(across(all_of(d[['domain']]), as.character),
+                   across(all_of(fields), as.numeric))
+    } else {
+        d[['records']] %>%
+            as_tibble() %>%
+            select(all_of(column_selector)) %>%
+            mutate(across(where(is.factor), as.character),
+                   across(where(is.integer.string), as.numeric))
+    }
 
     # extract scalars ----
     if (is.Scalar(d)) {

README.md

@@ -1,6 +1,6 @@
 # Bits and pieces of code to use with quitte-style data frames
 
-R package **quitte**, version **0.3137.1**
+R package **quitte**, version **0.3137.2**
 
 [![CRAN status](https://www.r-pkg.org/badges/version/quitte)](https://cran.r-project.org/package=quitte)  [![R build status](https://github.com/pik-piam/quitte/workflows/check/badge.svg)](https://github.com/pik-piam/quitte/actions) [![codecov](https://codecov.io/gh/pik-piam/quitte/branch/master/graph/badge.svg)](https://app.codecov.io/gh/pik-piam/quitte) [![r-universe](https://pik-piam.r-universe.dev/badges/quitte)](https://pik-piam.r-universe.dev/builds)
 
@@ -47,7 +47,7 @@ In case of questions / problems please contact Michaja Pehl <michaja.pehl@pik-po
 
 To cite package **quitte** in publications use:
 
-Pehl M, Bauer N, Hilaire J, Levesque A, Luderer G, Schultes A, Dietrich J, Richters O (2024). _quitte: Bits and pieces of code to use with quitte-style data frames_. R package version 0.3137.1, <https://github.com/pik-piam/quitte>.
+Pehl M, Bauer N, Hilaire J, Levesque A, Luderer G, Schultes A, Dietrich J, Richters O (2024). _quitte: Bits and pieces of code to use with quitte-style data frames_. R package version 0.3137.2, <https://github.com/pik-piam/quitte>.
 
 A BibTeX entry for LaTeX users is
 
@@ -56,7 +56,7 @@ A BibTeX entry for LaTeX users is
   title = {quitte: Bits and pieces of code to use with quitte-style data frames},
   author = {Michaja Pehl and Nico Bauer and Jérôme Hilaire and Antoine Levesque and Gunnar Luderer and Anselm Schultes and Jan Philipp Dietrich and Oliver Richters},
   year = {2024},
-  note = {R package version 0.3137.1},
+  note = {R package version 0.3137.2},
   url = {https://github.com/pik-piam/quitte},
 }
 ```

tests/testthat/test-read.gdx.R

@@ -8,22 +8,18 @@
     info <- paste('`quitte_force_gamstransfer` =',
                   options('quitte_force_gamstransfer'))
 
-    identical_tibble <- function(x, y)
-    {
+    identical_tibble <- function(x, y) {
         a <- all.equal(x, y)
         b <- all.equal(attributes(x)[sort(names(attributes(x)))],
                        attributes(y)[sort(names(attributes(y)))])
 
-        if (!isTRUE(a))
-        {
+        if (!isTRUE(a)) {
             return(a)
         }
-        else if (!isTRUE(b))
-        {
+        else if (!isTRUE(b)) {
             return(b)
         }
-        else
-        {
+        else {
             return(TRUE)
         }
     }
@@ -42,7 +38,7 @@
         })
 
     test_that(
-        'read.gdx() reas two-dimensional sets correctly',
+        'read.gdx() reads two-dimensional sets correctly',
         {
             x <- read.gdx(gdx, 'set_d2_alias')
 
@@ -70,6 +66,15 @@
             expect_identical(x, y, info = info)
         })
 
+    test_that(
+        'read.gdx() reads two-dimensional sets with identical defining sets',
+        {
+            x <- read.gdx(gdx, 'set_d2_identical')
+
+            expect_identical(x, set_d2_identical)
+        })
+
+
     ## parameters ----
     test_that(
         'read.gdx() reads scalars correctly',
@@ -97,9 +102,17 @@
             expect_true(identical_tibble(x, parameter_d2), info = info)
         })
 
+    test_that(
+        'read.gdx() reads parameters with no defined values correctly',
+        {
+            x <- read.gdx(gdx, 'parameter_d2_0', squeeze = FALSE)
+
+            expect_true(identical_tibble(x, parameter_d2_0), info = info)
+        })
+
     ## variables ----
     test_that(
-        'reaf.gdx() reads scalar variables correctly',
+        'read.gdx() reads scalar variables correctly',
         {
             x <- read.gdx(gdx, 'variable_d0')
 

tests/testthat/test_data/make_test_data.R

@@ -6,6 +6,10 @@ set_d1_lower <- letters[23:26]
 set_d1_UPPER <- LETTERS[1:3]
 set_d2 <- expand_grid(set_d1_UPPER, set_d1_lower)
 
+set_d2_identical <- tibble(set_d1_lower, set_d1_lower,
+                           .name_repair = function(names) {
+                               make.names(names, unique = TRUE) })
+
 # parameters ----
 parameter_d0 <- 13
 
@@ -17,6 +21,9 @@ parameter_d2 <- set_d2 %>%
         value = as.integer((Vectorize(charToRaw))(set_d1_UPPER)) * 10000
               + as.integer((Vectorize(charToRaw))(set_d1_lower)))
 
+parameter_d2_0 <- parameter_d2 %>%
+    filter(FALSE)
+
 # variables ----
 variable_d0 <- data.frame('level'    =  13,
                           'marginal' =  -1,

tests/testthat/test_data/write_test_data.R

@@ -28,6 +28,13 @@ invisible(m$addSet(name = 'set_d2',
 ## alias of two-dimensional set ----
 invisible(m$addAlias(name = 'set_d2_alias', aliasWith = m['set_d2']))
 
+## two-dimensional set with identical defining sets ----
+invisible(m$addSet(name = 'set_d2_identical',
+                   domain = list('set_d1_lower', 'set_d1_lower'),
+                   records = set_d2_identical,
+                   description = paste('a two-dimensional set with identical',
+                                       'defining sets')))
+
 # parameters ----
 ## scalar/parameter over no set ----
 invisible(m$addParameter(name = 'parameter_d0',
@@ -46,6 +53,12 @@ invisible(m$addParameter(name = 'parameter_d2',
                          records = parameter_d2,
                          description = 'a parameter over two sets'))
 
+## parameter with no defined values ----
+invisible(m$addParameter(name = 'parameter_d2_0',,
+                         domain = c(m['set_d1_UPPER'], m['set_d1_lower']),
+                         records = parameter_d2_0,
+                         description = 'a parameter with no defined values'))
+
 # variables ----
 ## variable over no set ----
 invisible(m$addVariable(name = 'variable_d0',