From c8392707a2958d1dbb0471e9c8e6806cd32da49c Mon Sep 17 00:00:00 2001
From: Michaja Pehl <pehl@pik-potsdam.de>
Date: Mon, 26 Aug 2024 12:21:35 +0200
Subject: [PATCH] - convert columns with integer strings to numeric - read
 parameters with no defined values

---
 R/read.gdx.R                               |  38 ++++++++++++++++++---
 tests/testthat/test-read.gdx.R             |   8 +++++
 tests/testthat/test_data/make_test_data.R  |   3 ++
 tests/testthat/test_data/test.gdx          | Bin 2917 -> 3036 bytes
 tests/testthat/test_data/write_test_data.R |   6 ++++
 5 files changed, 50 insertions(+), 5 deletions(-)

diff --git a/R/read.gdx.R b/R/read.gdx.R
index fbb9bdb..2264731 100644
--- a/R/read.gdx.R
+++ b/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
@@ -229,8 +248,7 @@ init_gdxrrw <- function() {
     }
 
     # select correct columns ----
-    column_selector <- c(colnames(d[['records']])[seq_len(d[['dimension']])],
-                         fields)
+    column_selector <- c(make.gamstransfer.names(d[['domain']]), fields)
     if (!is.null(colNames)) {
         if (length(colNames) != length(column_selector)) {
             cli_abort(c(
@@ -252,9 +270,19 @@ init_gdxrrw <- function() {
     }
 
     # 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)) {
diff --git a/tests/testthat/test-read.gdx.R b/tests/testthat/test-read.gdx.R
index 12f255b..ad396a2 100644
--- a/tests/testthat/test-read.gdx.R
+++ b/tests/testthat/test-read.gdx.R
@@ -102,6 +102,14 @@
             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(
         'read.gdx() reads scalar variables correctly',
diff --git a/tests/testthat/test_data/make_test_data.R b/tests/testthat/test_data/make_test_data.R
index e33d7a8..bda5eb8 100644
--- a/tests/testthat/test_data/make_test_data.R
+++ b/tests/testthat/test_data/make_test_data.R
@@ -21,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,
diff --git a/tests/testthat/test_data/test.gdx b/tests/testthat/test_data/test.gdx
index e87aec41330efc757547007ff745f489097a8176..4abae556240454746e56a7e7a74f863b8b1aa31e 100644
GIT binary patch
delta 230
zcmaDVc1L_dsn#+!1~7=_hR|M6x*AHu<a@a%E>zgKe<`CV6G-9z|NrZe>CG`rCM=8s
zn<uhOW=iKPNGwXsO)W_+icc|$H;4u6U|;}Ij37;Lpp>WpSE^8+S(2fUm#>hLnwFWD
znxasam{Xcs%)kiJ#thZMU6xpsnV6K58lPfNHQA8UmT~Und`@>JR_4h&IK3GsOlIM-
SW!ya3iOYjYnsssy*G&Mm9W~AX

delta 115
zcmca3{#0y2sa7W&0~kExg3y<tGz&L`50e+;p14q9<Nl?Lo2Rn~GHss3BF)6ezj+<o
yWTwfpIe8dkC$HeNWo(%IjMJUz1=D1GE^o%-$<<u8jMFCX<nmzp$1<6j`z8Q)^&DRS

diff --git a/tests/testthat/test_data/write_test_data.R b/tests/testthat/test_data/write_test_data.R
index e346d7d..0306f5a 100644
--- a/tests/testthat/test_data/write_test_data.R
+++ b/tests/testthat/test_data/write_test_data.R
@@ -53,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',