reimplement read.gdx() as gdxrrw and gamstransfer variants

.buildlibrary

@@ -1,4 +1,4 @@
-ValidationKey: '623865000'
+ValidationKey: '625632000'
 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.3135.0
-date-released: '2024-06-26'
+version: 0.3136.0
+date-released: '2024-08-15'
 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.3135.0
-Date: 2024-06-26
+Version: 0.3136.0
+Date: 2024-08-15
 Authors@R: c(
     person("Michaja", "Pehl", , "[email protected]", role = c("aut", "cre")),
     person("Nico", "Bauer", , "[email protected]", role = "aut"),
@@ -22,6 +22,7 @@ BugReports: https://github.com/pik-piam/quitte/issues
 Depends:
     R (>= 4.0)
 Imports:
+    cli,
     countrycode,
     dplyr (>= 1.1.1),
     forcats (>= 1.0.0),
@@ -49,15 +50,17 @@ Imports:
     zoo,
 Suggests:
     covr,
+    gamstransfer,
     gdxrrw,
     knitr,
     mip,
     rmarkdown,
     testthat (>= 3.2.0),
     tidyverse,
+    withr,
 VignetteBuilder:
     knitr
 Encoding: UTF-8
 LazyData: TRUE
-RoxygenNote: 7.3.1
+RoxygenNote: 7.3.2
 Roxygen: list(markdown = TRUE)

NAMESPACE

@@ -91,6 +91,7 @@ export(write.IAMCxlsx)
 export(write.mif)
 import(dplyr)
 import(utils)
+importFrom(cli,cli_abort)
 importFrom(countrycode,countrycode)
 importFrom(dplyr,"%>%")
 importFrom(dplyr,across)

R/read.gdx.R

@@ -1,41 +1,63 @@
-#'
 #' Read item from `.gdx` file as quitte data frame
 #'
-#' `read.gdx()` is a wrapper function for [gdxrrw::rgdx()] that
-#' returns a quitte data frame.
+#' `read.gdx()` is a wrapper function for either [`gdxrrw::rgdx()`] or
+#' [`gamstransfer::readGDX()`] that returns a quitte data frame.
+#'
+#' `read.gdx()` will use [`gdxrrw::rgdx()`] if [gdxrrw](gdxrrw-package) is
+#' installed and the option `quitte_force_gamstransfer` is not `TRUE`, otherwise
+#' it will use [`gamstransfer::readGDX()`].
 #'
-#' @param gdxName path to `.gdx` file
-#' @param requestList.name name of item to read
-#' @param fields fields to read from variables and equations (any of `lo`,
-#'        `l`, `m`, and `up`); ignored for parameters
-#' @param colNames string vector of column names to override dimension names
+#' @param gdxName Path to a `.gdx` file.
+#' @param requestList.name Name of the item to read.
+#' @param fields Fields to read from variables and equations.  When using
+#'     [gdxrrw](gdxrrw-package), any of `l`, `m`, `lo`, `up`, `s`.  When using
+#'     using [gamstransfer](gamstransfer-package), `level`, `marginal`, `lower`,
+#'     `upper`, and `scale` are understood as well.  `all` will return all
+#'     fields.  Ignored when reading sets or parameters.
+#' @param colNames String vector of column names to override dimension and field
+#'     names.
 #' @param factors Deprecated.  Do not use any more.
-#' @param squeeze if `TRUE`, squeeze out any zero or EPS stored in the GDX
-#'        container
-#' @return quitte data frame
+#' @param squeeze If `TRUE`, squeeze out any zero or EPS stored in the GDX
+#'        container.  Ignored when using [gamstransfer](gamstransfer-package).
+#'
+#' @return A quitte data frame.
 #' @author Michaja Pehl
 #'
+#' @importFrom cli cli_abort
 #' @importFrom lifecycle deprecated deprecate_warn is_present
 #' @importFrom tibble as_tibble
 #'
 #' @export
 read.gdx <- function(gdxName, requestList.name, fields = "l", colNames = NULL,
                      factors = deprecated(), squeeze = TRUE) {
-
-    if (is_present(factors))
-    {
+    if (is_present(factors)) {
         deprecate_warn('0.3135.0', 'quitte::read.gdx(factors = )',
                        details = 'Please do not use the argument anymore.')
     }
 
     # Check if gdxrrw package is installed
-    if (!any(.packages(all.available = TRUE) == "gdxrrw"))
-        stop("Package gdxrrw not installed.\n",
-             "See http://support.gams.com/gdxrrw:interfacing_gams_and_r")
+    no_gdx_package <- !any(c('gdxrrw', 'gamstransfer') %in%
+                               .packages(all.available = TRUE))
+    if (no_gdx_package) {
+        stop('Neither `gdxrrw` nor `gamstransfer` package is installed.\n',
+             'See https://www.gams.com/latest/docs/API_R_GAMSTRANSFER.html')
+    }
 
-    # Initialise external gdx libraries
-    if (!(done <- gdxrrw::igdx(silent = TRUE, returnStr = FALSE))) {
+    # use gdxrrw unless gamstransfer is forced or gdxrrw is not installed
+    use_gdxrrw <- !any(getOption('quitte_force_gamstransfer', default = FALSE),
+                       !'gdxrrw' %in% .packages(all.available = TRUE))
 
+    if (use_gdxrrw) {
+        .read.gdx_gdxrrw(gdxName, requestList.name, fields, colNames, squeeze)
+    }
+    else {
+        .read.gdx_gamstransfer(gdxName, requestList.name, fields, colNames,
+                               squeeze)
+    }
+}
+
+init_gdxrrw <- function() {
+    if (!(done <- gdxrrw::igdx(silent = TRUE, returnStr = FALSE))) {
         if ("Windows" == getElement(Sys.info(), "sysname")) {
             path <- strsplit(Sys.getenv("PATH"), ";")[[1]]
             path <- grep("gams", path, value = TRUE, ignore.case = TRUE)
@@ -44,14 +66,26 @@ read.gdx <- function(gdxName, requestList.name, fields = "l", colNames = NULL,
             for (p in path)
                 if (done <- gdxrrw::igdx(p, silent = TRUE))
                     break
-        } else {
-            done <- gdxrrw::igdx(system("which gams | xargs dirname",
-                                        intern = TRUE),
-                                 silent = TRUE)
         }
+        else {
+            suppressWarnings(
+                s <- system("which gams | xargs dirname", intern = TRUE,
+                            ignore.stderr = TRUE))
+            if (0 != length(s)) {
+                done <- gdxrrw::igdx(s, silent = TRUE)
+            }
+            else {
+                done <- FALSE
+            }
+        }
+    }
+    return(done)
+}
 
-        if (!done)
-            stop("Could not load gdx libraries")
+.read.gdx_gdxrrw <- function(gdxName, requestList.name, fields, colNames,
+                             squeeze) {
+    if (!init_gdxrrw()) {
+        stop("Could not load gdx libraries")
     }
 
     gdxName <- path.expand(gdxName)
@@ -65,7 +99,8 @@ read.gdx <- function(gdxName, requestList.name, fields = "l", colNames = NULL,
     if (read.fields) {
         requestList <- list(name = requestList.name, field = fields[[1]])
         item <- gdxrrw::rgdx(gdxName, requestList, squeeze = squeeze)
-    } else {
+    }
+    else {
         requestList <- list(name = requestList.name)
         item <- gdxrrw::rgdx(gdxName, requestList, squeeze = squeeze)
     }
@@ -107,7 +142,8 @@ read.gdx <- function(gdxName, requestList.name, fields = "l", colNames = NULL,
 
     if (read.fields) {
         field.names <- sub("^l$", "value", fields)
-    } else {
+    }
+    else {
         field.names <- "value"
     }
 
@@ -117,11 +153,110 @@ read.gdx <- function(gdxName, requestList.name, fields = "l", colNames = NULL,
         } else {
             names(data) <- c(item$domains)
         }
-    } else {
+    }
+    else {
         names(data) <- colNames
     }
 
     data <- as_tibble(data.frame(data))
 
     return(data)
 }
+
+.read.gdx_gamstransfer <- function(gdxName, requestList.name, fields, colNames,
+                                   squeeze) {
+    # functions ----
+    is.Alias <- function(d) {
+        'Alias' == d[['class']]
+    }
+
+    is.Set <- function(d) {
+        'Set' == d[['class']]
+    }
+
+    is.Parameter <- function(d) {
+        'Parameter' == d[['class']]
+    }
+
+    is.Scalar <- function(d) {
+        0 == d[['dimension']]
+    }
+
+    convert_field_names <- function(fields) {
+        # convert short (gdxrrw) to long (gamstransfer) field names, check for
+        # unknown field names
+        field_codes <- c('l'  = 'level',
+                         'm'  = 'marginal',
+                         'lo' = 'lower',
+                         'up' = 'upper',
+                         's'  = 'scale')
+
+        if ('all' %in% fields) {
+            return(unname(field_codes))
+        }
+
+        known_fields <- c(field_codes, names(field_codes), 'all')
+        unknown_fields <- !fields %in% known_fields
+        if (any(unknown_fields)) {
+            cli_abort(c(
+                paste('{sum(unknown_fields)} unknown field{?/s}:',
+                      '{paste0("`", fields[unknown_fields], "`")}'),
+                'i' = 'Use any of {paste0("`", known_fields, "`")} instead'))
+        }
+
+        return(unique(na.omit(c(setdiff(fields, names(field_codes)),
+                                field_codes[fields]))))
+    }
+
+    # load data ----
+    d <- gamstransfer::readGDX(loadFrom = gdxName,
+                               symbols = requestList.name)[[1]]
+
+    ## reload aliases ----
+    if (is.Alias(d)) {
+        d <- gamstransfer::readGDX(loadFrom = gdxName,
+                                   symbols = d[['aliasWith']])[[1]]
+    }
+
+    # select correct fields ----
+    # only equations and variables have fields, parameters always report value
+    if (is.Set(d)) {
+        fields <- character(0)
+    } else if (is.Parameter(d)) {
+        fields <- 'value'
+    } else {
+        fields <- convert_field_names(fields)
+    }
+
+    # select correct columns ----
+    column_selector <- c(d[['domain']], fields)
+    if (!is.null(colNames)) {
+        if (length(colNames) != length(column_selector)) {
+            cli_abort(c(
+                paste('Length of `colNames` ({length(colNames)}) does not',
+                      'match number of selected columns',
+                      '({length(column_selector)}).'),
+                'i' = 'colNames: {paste0("`", colNames, "`")}',
+                'i' = 'selected columns: {paste0("`", column_selector, "`")}'))
+        }
+
+        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))
+    }
+
+    # filter data ----
+    result <- as_tibble(d[['records']]) %>%
+        select(all_of(column_selector)) %>%
+        mutate(across(where(is.factor), as.character))
+
+    # extract scalars ----
+    if (is.Scalar(d)) {
+        result <- setNames(result[[1]], requestList.name)
+    }
+
+    return(result)
+}

README.md

@@ -1,6 +1,6 @@
 # Bits and pieces of code to use with quitte-style data frames
 
-R package **quitte**, version **0.3135.0**
+R package **quitte**, version **0.3136.0**
 
 [![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.3135.0, <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.3136.0, <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.3135.0},
+  note = {R package version 0.3136.0},
   url = {https://github.com/pik-piam/quitte},
 }
 ```