#' gdxtools
#'
#' @name gdxtools
#' @docType package
#' @description
#' Get info on GDX files (GAMS database exchange files) and convert parameters and variables data into data.frame.
#'
NULL
.onAttach <- function(libname, pkgname) {
if (!interactive()) return()
packageStartupMessage(paste("gdxtools", utils::packageVersion("gdxtools")))
if (Sys.info()[["sysname"]] == 'Windows'){
gamsname = 'gams.exe'
} else {
gamsname = 'gams'
}
.res <- ''
# try to specify the gams installation from PATH
.res = igdx('',TRUE,TRUE)
if(.res=='' | !file.exists(file.path(.res,gamsname))){
.res = igdx(dirname(Sys.which(gamsname)),TRUE,TRUE)
}
if(.res=='' | !file.exists(file.path(.res,gamsname))){
if(Sys.info()[['sysname']]=='Windows'){
#try to load the latest version of GAMS
guess_gams_path = rev(sort(Sys.glob("C:\\GAMS\\win**\\**")))
if(length(guess_gams_path)>0){
.res=igdx(guess_gams_path[1],TRUE,TRUE)
}
}
}
if(.res=='' | !file.exists(file.path(.res,gamsname))){
packageStartupMessage('Please specify the GAMS directory with the function "igdx"')
} else {
packageStartupMessage(paste('GDX library load path:',.res))
}
}
#' Extract a list of items from many GDX
#'
#' @param items vector or list of items to extract
#' @param files list of files, if not defined gdxs should be defined
#' @param gdxs list of gdxs, if not defined files should be defined
#' @author Laurent Drouet
#' @examples
#'
#' \dontrun{
#' myfiles = c("test1.gdx","test2.gdx")
#' allparam <- batch_extract("myparam",files=myfiles)
#' }
#' @export
batch_extract <- function(items,files=NULL,gdxs=NULL,...){
if(is.null(gdxs)){
gdxs <- lapply(files, gdx)
}
lall = list()
for(item in items){
tt <- lapply(gdxs,extract,item,addgdx=T,...)
tt <- do.call("rbind",tt)
tt <- list(tt)
names(tt) <- item
lall <- c(lall,tt)
}
return(lall)
}
#' Write a list of parameters or sets in a gdx, using gdxrrw (faster than write.gdx, but less options)
#'
#' @export
#' @param file the filename of the gdx to save
#' @param params named list of parameters
#' @param sets named list of sets
#' @author Laurent Drouet
#' @examples
#' \dontrun{
#' param1 = data.frame(x=c('1','2'),value=1:10)
#' param2 = data.frame(a=c('london','paris','tahiti'),value=c(50,0.2,1e-2))
#' write.gdx("test.gdx",list(param1=param1,param2=param2))
#' }
#'
write2.gdx <- function(file, params=list(),
sets=list()){
value = NULL
coll = list()
# sets
for(i in seq_along(sets)){
s = sets[[i]]
text = ifelse("gams" %in% names(attributes(sets[i])),attributes(sets[i])$gams,"")
name = ifelse(names(sets)[i]=="",paste0("set",i),names(sets)[i])
dim = ncol(s)
uels = list()
val = matrix(0,ncol=ncol(s),nrow=nrow(s))
domains = rep('*',dim)
for(j in 1:dim){
f = factor(s[[j]])
uels = c(uels, list(levels(f)))
val[,j] = as.numeric(f)
}
coll = c(coll,list(list(name=name, type='set', dim=dim, val=val,
uels=uels, domains=domains, ts=text)))
}
# parameters
for(i in seq_along(params)){
p = subset(params[[i]], value!=0)
text = ifelse("gams" %in% names(attributes(params[[i]])),attributes(params[[i]])$gams,"")
name = ifelse(names(params)[[i]]=="",paste0("param",i),names(params)[[i]])
dim = ncol(p)-1
if(dim>0){
uels = list()
val = matrix(0,ncol=ncol(p),nrow=nrow(p))
domains = names(p)[names(p)!="value"]
for(j in 1:dim){
f = factor(p[[j]])
uels = c(uels, list(levels(f)))
val[,j] = as.numeric(f)
}
val[,dim+1] = p$value
coll = c(coll,list(list(name=name, type='parameter', form='sparse',
dim=dim, val=val, uels=uels, domains=domains, ts=text)))
} else {
coll = c(coll,list(list(name=name, type='parameter', form='full',
dim=0, val=p$value, ts=text)))
}
}
# write into a gdx
return(wgdx(file,coll))
}
#' Write a list of parameters in a gdx (old version which uses a temporary gams file)
#'
#' @export
#' @param file the filename of the gdx to save
#' @param params named list of parameters
#' @param sets named list of sets
#' @param vars_l named list of variable levels
#' @param vars_lo named list of variable lower bounds
#' @param vars_up named list of variable upper bounds
#' @param usetempdir uses system temp dir for the temporary files, otherwise use local file "tmp.gms"
#' @param removeLST remove temporary lst file
#' @param digit number of digits to use
#' @param compress compress GDX
#' @author Laurent Drouet
#' @examples
#' \dontrun{
#' param1 = data.frame(x=c('1','2'),value=1:10)
#' param2 = data.frame(a=c('london','paris','tahiti'),value=c(50,0.2,1e-2))
#' write.gdx("test.gdx",list(param1=param1,param2=param2))
#' }
#'
write.gdx <- function(file, params=list(),
vars_l=list(),
vars_lo=list(),
vars_up=list(),
sets=list(),
removeLST=T, usetempdir=T, digits=16, compress=F){
value = NULL
# switch to faster write function when possible
if(!compress & length(vars_l)==0 & length(vars_lo)==0 & length(vars_up)==0){
return(write2.gdx(file, params = params, sets = sets))
}
# Create a temporary gams file
if(usetempdir){
gms = tempfile(pattern = "wgdx", fileext = ".gms")
lst = tempfile(pattern = "wgdx", fileext = ".lst")
} else {
gms = "tmp.gms"
lst = "tmp.lst"
}
fgms = file(gms, "w")
writeLines("$offdigit", fgms)
writeLines("$onempty", fgms)
# collect and write sets
alllists = c(params,vars_l,vars_lo,vars_up,sets)
allsets = unique(unlist(lapply(alllists, names)))
allsets = subset(allsets, !allsets %in% c('*','value'))
for(i in seq_along(allsets)){
s = allsets[i]
writeLines(paste("set", s, "/"), fgms)
lvalues = lapply(alllists, function(x) unique((as.character(x[[s]]))))
values = unique(unlist(lvalues))
writeLines(paste0("'",values,"'"), fgms)
writeLines("/;", fgms)
}
# Write sets
for(i in seq_along(sets)){
s = sets[[i]]
writeLines(paste0("set ", names(sets)[i],
" (",paste(rep('*',length(names(s))),collapse=","),")/"), fgms)
if(ncol(s)==1){
writeLines(paste0("'",trimws(s[,1]),"'"), fgms)
}
if(ncol(s)>1){
writeLines(paste0("'",paste(apply(as.data.frame(s)[,names(s)],1,paste,collapse="'.'")),"'"), fgms)
}
writeLines("/;", fgms)
}
# Write parameters
for(i in seq_along(params)){
p = params[[i]]
text = ifelse("gams" %in% names(attributes(p)),attributes(p)$gams,"")
name = ifelse(names(params)[i]=="",paste0("param",i),names(params)[i])
if(length(colnames(p))==1){
writeLines(paste("scalar", name, " '", text, "' /", format(as.numeric(p[1]),digits=digits), "/;"), fgms)
} else {
indices = subset(colnames(p), colnames(p) != "value")
p[[length(indices)+1]] = format(p[[length(indices)+1]],digits=digits)
writeLines(paste0("parameter ", name,
"(", paste(indices, collapse=","), ") ", " '", text, "' /"), fgms)
concatenate1 <- function(row, len) paste(paste(paste0("'",trimws(row[1:len]),"'"),collapse="."), row[len+1])
writeLines(apply(subset(p,value!=0),1,concatenate1, len=length(indices)), fgms)
writeLines("/;", fgms)
}
}
# Write variables
allvars = c(vars_l,vars_lo,vars_up)
varnames = c()
for(i in seq_along(allvars)){
if(!names(allvars)[i] %in% varnames){
v = allvars[[i]]
text = ifelse("gams" %in% names(attributes(v)),attributes(v)$gams,"")
if(length(colnames(v))==1){
writeLines(paste0("variable ", names(allvars)[i], " '", text, "' ;"), fgms)
}else{
indices = subset(colnames(v), colnames(v) != "value")
writeLines(paste0("variable ", names(allvars)[i],
"(", paste(indices, collapse=","), ") ", " '", text, "' ;"), fgms)
}
varnames = c(varnames,names(allvars)[i])
}
}
concatenate2 <- function(row, len, vname, vext) {
if (len == 1) {
sprintf(paste0(vname,vext,"(%s)=%s;"),
paste0("'",row[,1],"'"),
row[,len+1])
} else {
sprintf(paste0(vname,vext,"(%s)=%s;"),
paste0("'",apply(row[,1:len], 1, function(x) paste(x, collapse = "','")),"'"),
row[,len+1])
}
}
for(i in seq_along(vars_l)){
v = vars_l[[i]]
v = subset(v,value!=0)
if(nrow(v)>0){
if(length(colnames(v))==1){
writeLines(paste0(names(vars_l)[i],".l = ",format(as.numeric(v[1]),digits=digits),";"), fgms)
} else {
indices = subset(colnames(v), colnames(v) != "value")
v[[length(indices)+1]] = format(v[[length(indices)+1]],digits=digits)
writeLines(concatenate2(v, len=length(indices), vname=names(vars_l)[i], vext=".l"), fgms)
}
}
}
for(i in seq_along(vars_lo)){
v = vars_lo[[i]]
v = subset(v,!is.infinite(value))
if(nrow(v)>0){
if(length(colnames(v))==1){
writeLines(paste0(names(vars_lo)[i],".lo = ",format(as.numeric(v[1]),digits=digits),";"), fgms)
} else {
indices = subset(colnames(v), colnames(v) != "value")
v[[length(indices)+1]] = format(v[[length(indices)+1]],digits=digits)
writeLines(concatenate2(v, len=length(indices), vname=names(vars_lo)[i], vext=".lo"), fgms)
}
}
}
for(i in seq_along(vars_up)){
v = vars_up[[i]]
v = subset(v,!is.infinite(value))
if(nrow(v)>0){
if(length(colnames(v))==1){
writeLines(paste0(names(vars_up)[i],".up = ",format(as.numeric(v[1]),digits=digits),";"), fgms)
} else {
indices = subset(colnames(v), colnames(v) != "value")
v[[length(indices)+1]] = format(v[[length(indices)+1]],digits=digits)
writeLines(concatenate2(v, len=length(indices), vname=names(vars_up)[i], vext=".up"), fgms)
}
}
}
# save into a gdx
writeLines(paste0('execute_unload "',file,'"\n',
paste(names(alllists),collapse="\n"),
"\n;"), fgms)
writeLines("$offempty", fgms)
close(fgms)
res = gams(paste0(gms,ifelse(compress," gdxcompress=1","")," output=",lst))
if(res!=0) stop(paste("write gdx failed -",gms))
if(removeLST) file.remove(lst)
return(res)
}
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.