- convert columns with integer strings to numeric

- read parameters with no defined values
pik-piam · Aug 26, 2024 · c839270 · c839270
1 parent 8e01068
commit c839270
Show file tree

Hide file tree

Showing 5 changed files with 50 additions and 5 deletions.
diff --git 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
@@ -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
@@ -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
diff --git 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',