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 e87aec4..4abae55 100644 Binary files a/tests/testthat/test_data/test.gdx and b/tests/testthat/test_data/test.gdx differ 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',