diff --git a/.buildlibrary b/.buildlibrary index 8c121f7..a95cd36 100644 --- a/.buildlibrary +++ b/.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' diff --git a/CITATION.cff b/CITATION.cff index f96ceb6..3977706 100644 --- a/CITATION.cff +++ b/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: diff --git a/DESCRIPTION b/DESCRIPTION index 229e65d..093e7af 100644 --- a/DESCRIPTION +++ b/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", , "pehl@pik-potsdam.de", role = c("aut", "cre")), person("Nico", "Bauer", , "nicolasb@pik-potsdam.de", role = "aut"), diff --git a/R/read.gdx.R b/R/read.gdx.R index 97dd864..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 @@ -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)) { diff --git a/README.md b/README.md index ffaea67..68388d2 100644 --- a/README.md +++ b/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 . +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, . 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}, } ``` diff --git a/tests/testthat/test-read.gdx.R b/tests/testthat/test-read.gdx.R index d71bf0e..ad396a2 100644 --- a/tests/testthat/test-read.gdx.R +++ b/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') diff --git a/tests/testthat/test_data/make_test_data.R b/tests/testthat/test_data/make_test_data.R index 42a35c1..bda5eb8 100644 --- a/tests/testthat/test_data/make_test_data.R +++ b/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, diff --git a/tests/testthat/test_data/test.gdx b/tests/testthat/test_data/test.gdx index b1a9dcb..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 1d60c18..0306f5a 100644 --- a/tests/testthat/test_data/write_test_data.R +++ b/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',