├── NAMESPACE ├── R ├── processReadStatement.R ├── readProcessing.R ├── coefficientProcessing.R ├── variableGenerator.R ├── updateGenerator.R ├── equationLevelGenerator.R ├── main.R ├── skeletonGenerator.R ├── helpers.R ├── processCoefficientStatement.R ├── processEquationSetupStatement.R ├── processFormulaStatement.R ├── setProcessing.R ├── processEquationStatement.R ├── processUpdateStatement.R ├── formulaProcessing.R ├── processTablo.R ├── processSetStatement.R ├── equationMatrixProcessing.R ├── equationProcessing.R ├── tabloToStatements.R └── GEModel.R ├── DESCRIPTION ├── .gitignore └── README.md /NAMESPACE: -------------------------------------------------------------------------------- 1 | exportPattern("^[[:alpha:]]+") 2 | -------------------------------------------------------------------------------- /R/processReadStatement.R: -------------------------------------------------------------------------------- 1 | processReadStatement = function(s) { 2 | if (grepl(".* from file .* header \"*\"", 3 | s$command)) { 4 | words = strsplit(s$command, " ")[[1]] 5 | 6 | return(sprintf('%s[] = %s$`%s`', words[1], words[4], gsub("\"", "", words[6]))) 7 | } 8 | 9 | } 10 | -------------------------------------------------------------------------------- /R/readProcessing.R: -------------------------------------------------------------------------------- 1 | generateReads = function(readStatements) { 2 | toRet = list() 3 | for (s in readStatements) { 4 | toRet[[length(toRet) + 1]] = processReadStatement(s) 5 | } 6 | 7 | f = str2lang('function(data)return(data)') 8 | w = str2lang('within(data,{})') 9 | for (tr in toRet) { 10 | w[[3]][[length(w[[3]]) + 1]] = str2lang(tr) 11 | } 12 | 13 | f[[3]][[2]] = w 14 | 15 | return(eval(f)) 16 | } 17 | -------------------------------------------------------------------------------- /R/coefficientProcessing.R: -------------------------------------------------------------------------------- 1 | generateCoefficients = function(coefficientStatements){ 2 | toRet = list() 3 | for(s in coefficientStatements){ 4 | toRet[[length(toRet)+1]]=processCoefficientStatement(s) 5 | } 6 | 7 | f=str2lang('function(data)return(data)') 8 | w=str2lang('within(data,{})') 9 | for(tr in toRet){ 10 | w[[3]][[length(w[[3]])+1]]=str2lang(tr) 11 | } 12 | 13 | f[[3]][[2]]=w 14 | 15 | return(eval(f)) 16 | } 17 | -------------------------------------------------------------------------------- /DESCRIPTION: -------------------------------------------------------------------------------- 1 | Package: tabloToR 2 | Type: Package 3 | Title: What the Package Does (Title Case) 4 | Version: 0.1.0 5 | Author: Who wrote it 6 | Maintainer: The package maintainer 7 | Description: More about what it does (maybe more than one line) 8 | Use four spaces when indenting paragraphs within the Description. 9 | License: What license is it under? 10 | Encoding: UTF-8 11 | LazyData: true 12 | Import: Matrix, SparseM 13 | -------------------------------------------------------------------------------- /R/variableGenerator.R: -------------------------------------------------------------------------------- 1 | generateVariables = function(statements) { 2 | toRet = list('"/" <- function(x,y) ifelse(y==0,0,base:::"/"(x,y)) 3 | ') 4 | for (s in statements) { 5 | toRet[[length(toRet) + 1]] = processCoefficientStatement(s) 6 | } 7 | 8 | f = str2lang('function(data)return(data)') 9 | w = str2lang('within(data,{})') 10 | for (tr in toRet) { 11 | w[[3]][[length(w[[3]]) + 1]] = str2lang(paste(tr,collapse='')) 12 | } 13 | 14 | f[[3]][[2]] = w 15 | 16 | return(eval(f)) 17 | } 18 | -------------------------------------------------------------------------------- /R/updateGenerator.R: -------------------------------------------------------------------------------- 1 | generateUpdates = function(statements) { 2 | toRet = list('"/" <- function(x,y) ifelse(y==0,0,base:::"/"(x,y)) 3 | ') 4 | for (s in statements) { 5 | if (any(grepl('\\(initial\\)', s$parsed$elements, ignore.case = T)) == F) { 6 | toRet[[length(toRet) + 1]] = processUpdateStatement(s) 7 | } 8 | } 9 | 10 | f = str2lang('function(data)return(data)') 11 | w = str2lang('within(data,{})') 12 | for (tr in toRet) { 13 | w[[3]][[length(w[[3]]) + 1]] = str2lang(paste(tr, collapse = '')) 14 | } 15 | 16 | f[[3]][[2]] = w 17 | 18 | return(eval(f)) 19 | } 20 | -------------------------------------------------------------------------------- /R/equationLevelGenerator.R: -------------------------------------------------------------------------------- 1 | generateEquationLevels = function(statements) { 2 | toRet = list('"/" <- function(x,y) ifelse(y==0,0,base:::"/"(x,y)) 3 | ') 4 | for (s in statements) { 5 | if (s$class == 'equation') { 6 | toRet[[length(toRet) + 1]] = processEquationSetupStatement(s) 7 | toRet[[length(toRet) + 1]] = processEquationStatement(s) 8 | } 9 | } 10 | 11 | f = str2lang('function(data)return(data)') 12 | w = str2lang('within(data,{})') 13 | for (tr in toRet) { 14 | w[[3]][[length(w[[3]]) + 1]] = str2lang(paste(tr, collapse = '')) 15 | } 16 | 17 | f[[3]][[2]] = w 18 | 19 | return(eval(f)) 20 | } 21 | -------------------------------------------------------------------------------- /R/main.R: -------------------------------------------------------------------------------- 1 | #' #' @export 2 | #' #' @param tabloFileName Path to the tablo file 3 | #' #' @param filePaths A list of paths to all files mentioned in the tablo file 4 | #' tabloToR = function(tabloFileName, filePaths) { 5 | #' 6 | #' # Read all definitions from the tablo file and return a series of R objects 7 | #' # all coefficients 8 | #' tablo = tabloToObjects(tabloFileName, filePaths) 9 | #' 10 | #' # generate sets (we only supply set definitions and file data; we get back sets) 11 | #' sets = generateSets(Filter(function(f)f$class=='set',tablo$definitions), fileData) 12 | #' 13 | #' # generate variables 14 | #' variables = generateVariables(tablo$variableDefinitions, sets) 15 | #' 16 | #' return(list( 17 | #' variables = variables, 18 | #' equations = equations, 19 | #' modelMatrix = modelMatrix 20 | #' )) 21 | #' } 22 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | .Rproj.user 2 | .Rhistory 3 | .RData 4 | .Ruserdata 5 | tabloToR.Rproj 6 | .Rbuildignore 7 | *.rds 8 | # History files 9 | .Rhistory 10 | .Rapp.history 11 | 12 | # Session Data files 13 | .RData 14 | 15 | # User-specific files 16 | .Ruserdata 17 | 18 | # Example code in package build process 19 | *-Ex.R 20 | 21 | # Output files from R CMD build 22 | /*.tar.gz 23 | 24 | # Output files from R CMD check 25 | /*.Rcheck/ 26 | 27 | # RStudio files 28 | .Rproj.user/ 29 | 30 | # produced vignettes 31 | vignettes/*.html 32 | vignettes/*.pdf 33 | 34 | # OAuth2 token, see https://github.com/hadley/httr/releases/tag/v0.3 35 | .httr-oauth 36 | 37 | # knitr and R markdown default cache directories 38 | *_cache/ 39 | /cache/ 40 | 41 | # Temporary files created by R markdown 42 | *.utf8.md 43 | *.knit.md 44 | 45 | # R Environment Variables 46 | .Renviron 47 | -------------------------------------------------------------------------------- /R/skeletonGenerator.R: -------------------------------------------------------------------------------- 1 | generateSkeleton = function(statements) { 2 | toRet = list('"/" <- function(x,y) ifelse(y==0,0,base:::"/"(x,y)) 3 | ') 4 | for (s in statements) { 5 | if (s$class == 'set') 6 | toRet[[length(toRet) + 1]] = processSetStatement(s) 7 | else if (s$class == 'formula') { 8 | toRet[[length(toRet) + 1]] = processFormulaStatement(s) 9 | } 10 | else if (s$class == 'coefficient') { 11 | toRet[[length(toRet) + 1]] = processCoefficientStatement(s) 12 | } 13 | else if (s$class == 'read') { 14 | toRet[[length(toRet) + 1]] = processReadStatement(s) 15 | } 16 | } 17 | 18 | f = str2lang('function(data)return(data)') 19 | w = str2lang('within(data,{})') 20 | for (tr in toRet) { 21 | w[[3]][[length(w[[3]]) + 1]] = str2lang(paste(tr,collapse='')) 22 | } 23 | 24 | f[[3]][[2]] = w 25 | 26 | return(eval(f)) 27 | } 28 | -------------------------------------------------------------------------------- /R/helpers.R: -------------------------------------------------------------------------------- 1 | loge = log 2 | 3 | # `%loosein%` = function(a, b) { 4 | # return(as.logical(apply(do.call(`cbind`,as.list(Map(function(f)grepl(f,a),b))),MARGIN=1,max))) 5 | # #return(unlist(Map(function(f)as.logical(max(grepl(f,a))),b))) 6 | # } 7 | 8 | toVector = function(ar, n) { 9 | 10 | 11 | 12 | if (length(ar)==1){ 13 | elementNames = c() 14 | } else{ 15 | dimnames(ar) = Map(function(f)sprintf('"%s"',f), dimnames(ar)) 16 | if (is.null(dimnames(ar))) { 17 | elementNames = names(ar) 18 | } else if(length(dimnames(ar))==1) { 19 | elementNames = dimnames(ar)[[1]] 20 | } else { 21 | elementNames = Reduce(function(a, f) { 22 | outer(a,dimnames(ar)[[f]],paste,sep=",") 23 | }, 2:length(dimnames(ar)), dimnames(ar)[[1]]) 24 | } 25 | 26 | } 27 | 28 | toRet = as.vector(ar) 29 | 30 | if(length(elementNames)==0){ 31 | names(toRet) = sprintf('%s[]',n) 32 | } else { 33 | names(toRet) = sprintf('%s[%s]',n,as.vector(elementNames)) 34 | } 35 | 36 | 37 | return(toRet) 38 | } 39 | 40 | -------------------------------------------------------------------------------- /R/processCoefficientStatement.R: -------------------------------------------------------------------------------- 1 | processCoefficientStatement = function(s) { 2 | dimensions = s$parsed$elements[grep('\\(all,', s$parsed$elements)] 3 | if (length(dimensions) == 0) { 4 | #toRet[[s$parsed$equation]] = NA 5 | return(sprintf('%s=NA', s$parsed$equation)) 6 | } else { 7 | qualifiers = gsub('\\(all,', 'all(', dimensions) 8 | 9 | dn = list() 10 | for (q in qualifiers) { 11 | dn[[str2lang(q)[[2]]]] = str2lang(q)[[3]] 12 | } 13 | 14 | 15 | # toRet[[str2lang(s$parsed$equation)[[1]]]] = array(NA, dim = unlist(Map(function(f)length(f), dn)), dimnames = dn) 16 | pe = str2lang(s$parsed$equation) 17 | return( 18 | sprintf( 19 | '%s = array(NA, dim = c(%s), dimnames = list(%s))', 20 | as.character(pe[[1]]), 21 | paste( 22 | 'length(', 23 | Map(function(f) 24 | dn[[pe[[f]]]], 2:length(pe)), 25 | ')', 26 | sep = '', 27 | collapse = ',' 28 | ), 29 | paste( 30 | Map( 31 | function(f) 32 | sprintf('%s=%s', as.character(dn[[pe[[f]]]]), as.character(dn[[pe[[f]]]])), 33 | 2:length(pe) 34 | ), 35 | sep = '', 36 | collapse = ',' 37 | ) 38 | ) 39 | ) 40 | } 41 | } 42 | 43 | -------------------------------------------------------------------------------- /R/processEquationSetupStatement.R: -------------------------------------------------------------------------------- 1 | processEquationSetupStatement = function(s) { 2 | dimensions = s$parsed$elements[grep('\\(all,', s$parsed$elements)] 3 | equationName = s$parsed$equationName 4 | 5 | if (length(dimensions) == 0) { 6 | #toRet[[s$parsed$equation]] = NA 7 | return(sprintf('%s=NA', equationName)) 8 | } else { 9 | qualifiers = gsub('<>', '!=', gsub(':', ",", gsub( 10 | '=', '==', gsub('\\(all,', 'all(', dimensions) 11 | ))) 12 | 13 | dn = list() 14 | for (q in qualifiers) { 15 | dn[[str2lang(q)[[2]]]] = str2lang(q)[[3]] 16 | } 17 | 18 | equationIndices = paste(Map(function(f) 19 | str2lang(f)[[2]], qualifiers), collapse = ',') 20 | if (is.null(equationIndices)) { 21 | equationIndices = '' 22 | } 23 | 24 | 25 | 26 | return( 27 | sprintf( 28 | '%s = array(NA, dim = c(%s), dimnames = list(%s))', 29 | equationName, 30 | paste( 31 | 'length(', 32 | unlist(Map(function(f) 33 | deparse1(f), dn)), 34 | ')', 35 | sep = '', 36 | collapse = ',' 37 | ), 38 | paste( 39 | Map(function(f) 40 | sprintf('%s=%s', deparse1(f), deparse(f)), 41 | dn), 42 | sep = '', 43 | collapse = ',' 44 | ) 45 | ) 46 | ) 47 | } 48 | } 49 | -------------------------------------------------------------------------------- /R/processFormulaStatement.R: -------------------------------------------------------------------------------- 1 | processFormulaStatement = function(s){ 2 | frm = correctFormula(s$parsed$equation) 3 | #frm = correctFormula(gsub(":","%:%",gsub('>==','>=',gsub('<==','<=',gsub('=','=',s$parsed$equation))))) 4 | 5 | dimensions = s$parsed$elements[grep('\\(all,', s$parsed$elements)] 6 | qualifiers = gsub('<>', '!=', gsub(':', ",", gsub( 7 | '=', '==', gsub('\\(all,', 'all(', dimensions) 8 | ))) 9 | 10 | if (length(qualifiers) > 0) { 11 | condition = list() 12 | for (l in 1:length(qualifiers)) { 13 | q = str2lang(qualifiers[[l]]) 14 | if (length(q) == 4) { 15 | condition[[length(condition) + 1]] = paste0(deparse1(correctFormula(deparse1(q[[4]]))),collapse=' ') 16 | } 17 | } 18 | 19 | for (l in 1:length(qualifiers)) { 20 | q = str2lang(qualifiers[[l]]) 21 | if (l == 1) { 22 | expr = sprintf( 23 | 'for(%s in %s){%s}', 24 | paste0(deparse1(q[[2]]),collapse=' '), 25 | paste0(deparse1(q[[3]]),collapse=' '), 26 | ifelse( 27 | length(condition) == 0, 28 | paste0(deparse1(frm),collapse=' '), 29 | sprintf( 30 | 'if(%s){%s}', 31 | paste(condition, collapse = '&'), 32 | paste0(deparse1(frm), collapse=' ') 33 | ) 34 | ) 35 | ) 36 | } else { 37 | expr = sprintf( 38 | 'for(%s in %s){%s}', 39 | paste0(deparse1(q[[2]]),collapse=' '), 40 | paste0(deparse1(q[[3]]),collapse=' '), 41 | expr 42 | ) 43 | } 44 | } 45 | } else{ 46 | expr = paste0(deparse1(frm),collapse=' ') 47 | } 48 | return(paste0(deparse1(sumToMap(str2lang(expr))),collapse=' ')) 49 | } 50 | -------------------------------------------------------------------------------- /R/setProcessing.R: -------------------------------------------------------------------------------- 1 | removeFunctions = function(exp) { 2 | return(str2lang(gsub('\\)', ']', gsub( 3 | '\\(', '[', deparse1(exp) 4 | )))) 5 | } 6 | correctFormula = function(formulaText) { 7 | 8 | #formulaText = str2lang(gsub('\\]', ')', gsub('\\[', '(', deparse(gsub(":", "%:%", gsub("\\(all,", "all(", gsub('>==','>=',gsub('<==','<=',gsub('=','==',formulaText))))))))) 9 | formulaText = str2lang(gsub('\\]', ')', gsub('\\[', '(', deparse1(formulaText)))) 10 | exp = str2lang(formulaText) 11 | 12 | exp = functionToData(exp) 13 | return(exp) 14 | } 15 | 16 | functionToData = function(exp) { 17 | dataNames = c('sum', 18 | 'exp', 19 | 'loge', 20 | '=', 21 | '-', 22 | '+', 23 | '/', 24 | '*', 25 | '(', 26 | '==', 27 | '!=', 28 | '<', 29 | '>') 30 | if (length(exp) == 1) { 31 | return(exp) 32 | } else if (!(as.character(exp[[1]]) %in% dataNames)) { 33 | dataName = exp[[1]] 34 | exp[[1]] = as.name('[') 35 | 36 | for (c2 in length(exp):2) { 37 | exp[[c2 + 1]] = exp[[c2]] 38 | } 39 | 40 | exp[[2]] = dataName 41 | return(exp) 42 | } 43 | 44 | else{ 45 | for (c1 in 1:length(exp)) { 46 | exp[[c1]] = functionToData(exp[[c1]]) 47 | } 48 | return(exp) 49 | } 50 | } 51 | 52 | 53 | generateSets = function(statements) { 54 | toRet = list() 55 | for (s in statements) { 56 | toRet[[length(toRet) + 1]] = processSetStatement(s) 57 | 58 | } 59 | 60 | f = str2lang('function(data)return(data)') 61 | w = str2lang('within(data,{})') 62 | for (tr in toRet) { 63 | w[[3]][[length(w[[3]]) + 1]] = str2lang(tr) 64 | } 65 | 66 | f[[3]][[2]] = w 67 | 68 | return(eval(f)) 69 | } 70 | -------------------------------------------------------------------------------- /R/processEquationStatement.R: -------------------------------------------------------------------------------- 1 | processEquationStatement = function(s){ 2 | frm = correctFormula(s$parsed$equation) 3 | frm[[1]]=as.name('-') 4 | 5 | 6 | dimensions = s$parsed$elements[grep('\\(all,', s$parsed$elements)] 7 | qualifiers = gsub('<>', '!=', gsub(':', ",", gsub( 8 | '=', '==', gsub('\\(all,', 'all(', dimensions) 9 | ))) 10 | 11 | equationName = s$parsed$equationName 12 | equationIndices = paste(Map(function(f)str2lang(f)[[2]],qualifiers),collapse=',') 13 | if(is.null(equationIndices)){ 14 | equationIndices='' 15 | } 16 | 17 | frm = str2lang(sprintf('%s = %s', sprintf('%s[%s]',equationName, equationIndices), paste(deparse1(frm),collapse=''))) 18 | 19 | if (length(qualifiers) > 0) { 20 | condition = list() 21 | for (l in 1:length(qualifiers)) { 22 | q = str2lang(qualifiers[[l]]) 23 | if (length(q) == 4) { 24 | condition[[length(condition) + 1]] = deparse1(correctFormula(deparse(q[[4]]))) 25 | } 26 | } 27 | 28 | for (l in 1:length(qualifiers)) { 29 | q = str2lang(qualifiers[[l]]) 30 | if (l == 1) { 31 | expr = sprintf( 32 | 'for(%s in %s){%s}', 33 | deparse1(q[[2]]), 34 | deparse1(q[[3]]), 35 | ifelse( 36 | length(condition) == 0, 37 | paste(deparse1(frm),collapse=''), 38 | sprintf( 39 | 'if(%s){%s}', 40 | paste(condition, collapse = '&'), 41 | paste(deparse1(frm),collapse='') 42 | ) 43 | ) 44 | ) 45 | } else { 46 | expr = sprintf( 47 | 'for(%s in %s){%s}', 48 | deparse1(q[[2]]), 49 | deparse1(q[[3]]), 50 | expr 51 | ) 52 | } 53 | } 54 | } else{ 55 | expr = deparse1(frm) 56 | } 57 | return(deparse1(sumToMap(str2lang(expr)))) 58 | } 59 | -------------------------------------------------------------------------------- /R/processUpdateStatement.R: -------------------------------------------------------------------------------- 1 | processUpdateStatement = function(s) { 2 | dimensions = s$parsed$elements[grep('\\(all,', s$parsed$elements)] 3 | qualifiers = gsub('<>', '!=', gsub(':', ",", gsub( 4 | '=', '==', gsub('\\(all,', 'all(', dimensions) 5 | ))) 6 | 7 | 8 | 9 | frm = correctFormula(s$parsed$equation) 10 | 11 | if(s$class=='update'){ 12 | if (any(grepl('\\(change\\)', s$parsed$elements, ignore.case = T)) == T) { 13 | frm[[3]] = call('+', frm[[2]], frm[[3]]) 14 | } else if (length(frm[[3]]) == 1) { 15 | frm[[3]] = call('*', frm[[2]], call('+', 1, call('/', frm[[3]], 100))) 16 | } else { 17 | if (frm[[3]][[1]] == '*') { 18 | # frm[[3]] = call('*', frm[[2]] , call('+', 1, call('+', call( 19 | # '/', frm[[3]][[2]], 100 20 | # ), call('/', frm[[3]][[3]], 100)))) 21 | frm[[3]] = call('*', frm[[2]] , call("*", call('+', 1, call( 22 | '/', frm[[3]][[2]], 100 23 | )), call('+',1, call('/', frm[[3]][[3]], 100)))) 24 | } else{ 25 | frm[[3]] = call('*', frm[[2]], call('+', 1, call('/', frm[[3]], 100))) 26 | } 27 | } 28 | } 29 | 30 | 31 | 32 | if (length(qualifiers) > 0) { 33 | condition = list() 34 | for (l in 1:length(qualifiers)) { 35 | q = str2lang(qualifiers[[l]]) 36 | if (length(q) == 4) { 37 | condition[[length(condition) + 1]] = deparse1(correctFormula(deparse(q[[4]]))) 38 | } 39 | } 40 | 41 | for (l in 1:length(qualifiers)) { 42 | q = str2lang(qualifiers[[l]]) 43 | if (l == 1) { 44 | expr = sprintf( 45 | 'for(%s in %s){%s}', 46 | deparse1(q[[2]]), 47 | deparse1(q[[3]]), 48 | ifelse( 49 | length(condition) == 0, 50 | deparse1(frm), 51 | sprintf( 52 | 'if(%s){%s}', 53 | paste(condition, collapse = '&'), 54 | deparse1(frm) 55 | ) 56 | ) 57 | ) 58 | } else { 59 | expr = sprintf( 60 | 'for(%s in %s){%s}', 61 | deparse1(q[[2]]), 62 | deparse1(q[[3]]), 63 | expr 64 | ) 65 | } 66 | } 67 | } else{ 68 | expr = deparse1(frm) 69 | } 70 | return(deparse1(sumToMap(str2lang(expr)))) 71 | } 72 | -------------------------------------------------------------------------------- /R/formulaProcessing.R: -------------------------------------------------------------------------------- 1 | sumToMap = function(expr) { 2 | if (class(expr) == 'name') { 3 | return(expr) 4 | } 5 | 6 | if (expr[[1]] == 'sum') { 7 | index = expr[[2]] 8 | set = expr[[3]] 9 | expression = expr[[4]] 10 | 11 | expr[[2]] = str2lang('unlist()') 12 | expr[[4]] = NULL 13 | expr[[3]] = NULL 14 | expr[[2]][[2]] = str2lang(sprintf( 15 | 'Map(function(%s)%s,%s)', 16 | deparse1(index), 17 | paste0(deparse1(sumToMap(expression)),collapse=' '), 18 | deparse1(set) 19 | )) 20 | 21 | }else if (length(expr) > 1) { 22 | for (i in 2:length(expr)) { 23 | expr[[i]] = sumToMap(expr[[i]]) 24 | } 25 | 26 | } 27 | return(expr) 28 | } 29 | 30 | 31 | 32 | generateFormulas = function(formulaStatements) { 33 | toRet = list() 34 | for (s in formulaStatements) { 35 | toRet[[length(toRet) + 1]] = processFormulaStatement(s) 36 | } 37 | 38 | f = str2lang('function(data)return(data)') 39 | w = str2lang('within(data,{})') 40 | for (tr in toRet) { 41 | w[[3]][[length(w[[3]]) + 1]] = sumToMap(str2lang(tr)) 42 | } 43 | 44 | f[[3]][[2]] = w 45 | 46 | return(eval(f)) 47 | } 48 | 49 | # 50 | # toRet[[55]] 51 | # 52 | # sum(r, REG, VST[l, r]) 53 | # 54 | # 55 | # x = str2lang('sum(r,REG,POP[r])') 56 | # y = str2lang( 57 | # sprintf( 58 | # '%s(unlist(Map(function(%s)%s,%s)))', 59 | # deparse(x[[1]]), 60 | # deparse(x[[2]]), 61 | # deparse(x[[4]]), 62 | # deparse(x[[3]]) 63 | # ) 64 | # ) 65 | # 66 | # REG = c('A', 'B') 67 | # PROD = c('P','R','S') 68 | # 69 | # VPA = array(c(1, 2, 3, 4), dim = c(3,2), dimnames = list(PROD,REG)) 70 | # VGA = array(c(1, 2, 3, 4), dim = c(2), dimnames = list(REG)) 71 | # 72 | # eval(sumToMap(str2lang('sum(r,REG,VGA[r]+sum(j,PROD,VPA[j,r]))'))) 73 | # 74 | # 75 | # POP = array(c(1, 2, 3, 4), dim = c(4), dimnames = list(REG)) 76 | # eval(y) 77 | # 78 | # sumToMap(str2lang('sum(r,REG,VGA[r]+sum(j,PROD,VPA[j,r]))')) 79 | # 80 | # 81 | # sum(VST[l, REG]) 82 | # 83 | # sum(Map(function(r) 84 | # , VXWD[i, r, s])) 85 | # 86 | # sum(r, REG, sum(s, REG, VXWD[i, r, s])) / (sum(k, 87 | # TRAD_COMM, sum(r, REG, sum(s, REG, VXWD[k, r, s]))) + 88 | # sum(l, MARG_COMM, sum(r, REG, VST[l, r]))) 89 | -------------------------------------------------------------------------------- /R/processTablo.R: -------------------------------------------------------------------------------- 1 | # This function is to take a TABLO file (text) and return: 2 | # a function to set initial coefficient values 3 | # a function to update coefficients 4 | # a function to formulas to update coefficients, a model matrix to allow for solution 5 | 6 | processTablo = function(tablo) { 7 | require(Matrix) 8 | statements = tabloToStatements(tablo) 9 | 10 | generator = generateSkeleton(Filter( 11 | function(f) 12 | f$class %in% c('set', 'coefficient', 'read', 'formula'), 13 | statements 14 | )) 15 | 16 | gem = generateEquationCoefficientMatrix( 17 | Filter(function(f) 18 | f$class == 'variable', statements), 19 | Filter(function(f) 20 | f$class == 'equation', statements) 21 | ) 22 | gec = generateEquationCoefficients(Filter(function(f) 23 | f$class == 'equation', statements)) 24 | 25 | gev = generateVariables(Filter(function(f) 26 | f$class == 'variable', statements)) 27 | geq = generateEquationLevels(Filter(function(f) 28 | f$class == 'equation', statements)) 29 | gup = generateUpdates(Filter(function(f) 30 | f$class %in% c('update','formula'), statements)) 31 | 32 | return( 33 | list( 34 | skeletonGenerator = generator, 35 | equationCoefficientMatrixGenerator = gem, 36 | equationCoefficientGenerator = gec, 37 | changeVariables = unlist(Map( 38 | function(f){ 39 | paren = regexpr('\\(', f$parsed$equation) 40 | if(paren==-1) { 41 | return(f$parsed$equation) 42 | } else { 43 | return(substr(f$parsed$equation,1,paren-1)) 44 | } 45 | }, 46 | Filter( 47 | function(f) 48 | #!'(change)' %in% f$parsed$element, 49 | any(grepl('change',f$parsed$element)), 50 | Filter(function(f) 51 | f$class == 'variable', statements) 52 | ) 53 | )), 54 | variables = unlist(Map( 55 | function(f){ 56 | paren = regexpr('\\(', f$parsed$equation) 57 | if(paren==-1) { 58 | return(f$parsed$equation) 59 | } else { 60 | return(substr(f$parsed$equation,1,paren-1)) 61 | } 62 | }, 63 | Filter(function(f) 64 | f$class == 'variable', statements) 65 | )), 66 | generateEquationLevelValues = geq, 67 | generateVariables = gev, 68 | generateUpdates = gup 69 | ) 70 | ) 71 | } 72 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # Package `tabloToR` 2 | 3 | A package that can interpret GEMPACK-style TABLO models in R and solve them 4 | 5 | # To install, you can try the following: 6 | 7 | ```R 8 | install.packages('devtools') 9 | devtools::install_git('https://github.com/mivanic/tabloToR.git') 10 | ``` 11 | 12 | # To perform a simulation, you can try the following: 13 | 14 | ```R 15 | model = tabloToR::GEModel$new() 16 | 17 | # You need to have the model, such as gtap.tab 18 | model$loadTablo('gtap.tab') 19 | 20 | # You need to get the data files .har 21 | data = list( 22 | # The file with GTAP sets may alternatively be called sets.har by some data aggregation programs 23 | gtapsets = HARr::read_har('gsdgset.har'), 24 | # The file with GTAP parameters may alternatively be called default.prm by some data aggregation programs 25 | gtapparm = HARr::read_har('gsdgpar.har'), 26 | # The file with GTAPdata may alternatively be called basedata.har by some data aggregation programs 27 | gtapdata = HARr::read_har('gsdgdat.har') 28 | ) 29 | 30 | # Initialize the model object 31 | 32 | model$loadData(data) 33 | 34 | # Set up the closure 35 | 36 | for(var in c("afall", 37 | "afcom", 38 | "afeall", 39 | "afecom", 40 | "afereg", 41 | "afesec", 42 | "afreg", 43 | "afsec", 44 | "ams", 45 | "aoall", 46 | "aoreg", 47 | "aosec", 48 | "atall", 49 | "atd", 50 | "atf", 51 | "atm", 52 | "ats", 53 | "au", 54 | "avaall", 55 | "avareg", 56 | "avasec", 57 | "cgdslack", 58 | "dpgov", 59 | "dppriv", 60 | "dpsave", 61 | "endwslack", 62 | "incomeslack", 63 | "pfactwld", 64 | "pop", 65 | "profitslack", 66 | "psaveslack", 67 | "tf", 68 | "tfd", 69 | "tfm", 70 | "tgd", 71 | "tgm", 72 | "tm", 73 | "tms", 74 | "to", 75 | "tpd", 76 | "tpm", 77 | "tp", 78 | "tradslack", 79 | "tx", 80 | "txs")){ 81 | model$variableValues[[var]][]=0 82 | } 83 | 84 | model$variableValues$qo[model$data$endw_comm,] = 0 85 | 86 | # Specify sets for shocks 87 | 88 | ag= c("grains", "v_f", "osd", "c_b", "pfb", "ocr", "ctl", "oap", "rmk", "wol") 89 | model$variableValues$aoall[ag,c("northam")] = 1 90 | 91 | agFood = c("grains", "v_f", "osd", "c_b", "pfb", "ocr", "ctl", "oap", "rmk", "wol", "food") 92 | 93 | model$variableValues$tms[agFood,,c("northam")] = (model$data$viws[agFood,,c("northam")] / model$data$vims[agFood,,c("northam")] -1)*100 94 | 95 | # Run the model 96 | model$solveModel(iter = 3,steps = c(1,3)) 97 | 98 | # View the results (variable ev--welfare) 99 | model$data$ev 100 | 101 | ``` 102 | -------------------------------------------------------------------------------- /R/processSetStatement.R: -------------------------------------------------------------------------------- 1 | processSetStatement = function(s) { 2 | # SET READ 3 | if (grepl(".* maximum size .* read elements from file .* header \"*\"", 4 | s$command)) { 5 | words = strsplit(s$command, " ")[[1]] 6 | #toRet[[words[1]]] = files[[words[9]]][[gsub("\"", "", words[11])]] 7 | toRet = sprintf('%s=%s$%s', words[[1]], words[[9]], gsub("\"", "", words[11])) 8 | } 9 | else if (grepl(".* read elements from file .* header \"*\"", 10 | s$command)) { 11 | words = strsplit(s$command, " ")[[1]] 12 | #toRet[[words[1]]] = files[[words[9]]][[gsub("\"", "", words[11])]] 13 | toRet = sprintf('%s=%s$%s', words[[1]], words[[6]], gsub("\"", "", words[8])) 14 | } 15 | # SET DIFFERENCE 16 | else if (grepl(".* = .* - .*", s$command)) { 17 | command = str2lang(s$command) 18 | command[[3]][[1]] = as.name('setdiff') 19 | #toRet[[deparse(command[[2]])]] = eval(command[[3]], toRet) 20 | toRet = sprintf('%s=%s', deparse1(command[[2]]), deparse1(command[[3]])) 21 | } 22 | # SET UNION 23 | else if (grepl(".* = .* union .*", s$command)) { 24 | command = str2lang(gsub('union', '+', s$command)) 25 | command[[3]][[1]] = as.name('union') 26 | #toRet[[deparse(command[[2]])]] = eval(command[[3]], toRet) 27 | toRet = sprintf('%s=%s', deparse1(command[[2]]), deparse1(command[[3]])) 28 | } 29 | # SET INTERSECTION 30 | else if (grepl(".* = .* intersect .*", s$command)) { 31 | command = str2lang(gsub('intersect', '+', s$command)) 32 | command[[3]][[1]] = as.name('intersect') 33 | #toRet[[deparse(command[[2]])]] = eval(command[[3]], toRet) 34 | toRet = sprintf('%s=%s', deparse1(command[[2]]), deparse1(command[[3]])) 35 | } 36 | # SET FORMULA 37 | else if (grepl(".* = \\(all,.*,.*\\)", s$command)) { 38 | preCommand = str2lang(gsub(":", ",", gsub("\\(all,", "all(", gsub('>==','>=',gsub('<==','<=',gsub('=','==',s$command)))))) 39 | 40 | setName = deparse1(preCommand[[3]][[3]]) 41 | standIn = deparse1(preCommand[[3]][[2]]) 42 | preCommand[[3]][[4]] = str2lang(gsub( 43 | paste0('\\b', standIn, '\\b'), 44 | setName , 45 | deparse1(preCommand[[3]][[4]]) 46 | )) 47 | 48 | preCommand[[3]][[1]] = as.name('[') 49 | preCommand[[3]][[2]] = NULL 50 | 51 | preCommand[[3]][[3]] = removeFunctions(preCommand[[3]][[3]]) 52 | 53 | #toRet[[deparse(preCommand[[2]])]] = eval(preCommand[[3]], toRet) 54 | toRet = sprintf('%s=%s', deparse1(preCommand[[2]]), deparse1(preCommand[[3]])) 55 | #eval(str2lang('SLUG[ENDW_COMM]'), toRet) 56 | #eval(quote(SLUG[ENDW_COMM]),toRet) 57 | } 58 | # SET SPECIFIED 59 | else if (grepl(".* \\(.*\\)", s$command)) { 60 | from = regexpr('\\(', s$command) 61 | to = regexpr('\\)', s$command) 62 | elements = strsplit(substr(s$command, from + 1, to - 1), ',')[[1]] 63 | 64 | #toRet[[trimws(substr(s$command, 1, from - 1))]] = elements 65 | toRet = sprintf('%s=c(%s)', 66 | trimws(substr(s$command, 1, from - 1)), 67 | paste('"', elements, '"', sep = '', collapse = ',')) 68 | } 69 | 70 | return(toRet) 71 | } 72 | -------------------------------------------------------------------------------- /R/equationMatrixProcessing.R: -------------------------------------------------------------------------------- 1 | generateEquationCoefficientMatrix = function(variableStatements, equationStatements) { 2 | toRet = list('equations=c()', 'variables=c()') 3 | for (s in equationStatements) { 4 | # Get the formula for each variable 5 | 6 | dimensions = s$parsed$elements[grep('\\(all,', s$parsed$elements)] 7 | qualifiers = gsub('<>', '!=', gsub(':', ",", gsub( 8 | '=', '==', gsub('\\(all,', 'all(', dimensions) 9 | ))) 10 | 11 | 12 | equationName = s$parsed$equationName 13 | equationIndices = Map(function(f) 14 | str2lang(f)[[2]], qualifiers) 15 | 16 | 17 | if (length(equationIndices) > 0) { 18 | expr = sprintf( 19 | "sprintf('%s[%s]',%s)", 20 | equationName, 21 | paste(rep('\"%s\"', length( 22 | equationIndices 23 | )), collapse = ','), 24 | paste(unlist(equationIndices), collapse = ',') 25 | ) 26 | 27 | } else { 28 | expr = sprintf("'%s[%s]'", equationName, 29 | paste(rep('\"%s\"', length( 30 | equationIndices 31 | )), collapse = ',')) 32 | } 33 | 34 | 35 | 36 | for (qualifier in c(qualifiers)) { 37 | q = str2lang(qualifier) 38 | expr = sprintf(#'for(%s in %s){%s}', 39 | 'Map(function(%s)%s,%s)', 40 | deparse1(q[[2]]), 41 | expr, 42 | deparse1(q[[3]])) 43 | } 44 | if (length(qualifiers) == 0) { 45 | toRet[[length(toRet) + 1]] = sprintf('equations = c(equations,%s)' , expr) 46 | 47 | } else{ 48 | toRet[[length(toRet) + 1]] = sprintf('equations = c(equations,unlist(do.call(c,%s)))' , expr) 49 | 50 | } 51 | } 52 | 53 | 54 | for (s in variableStatements) { 55 | dimensions = s$parsed$elements[grep('\\(all,', s$parsed$elements)] 56 | qualifiers = gsub('<>', '!=', gsub(':', ",", gsub( 57 | '=', '==', gsub('\\(all,', 'all(', dimensions) 58 | ))) 59 | 60 | 61 | variableDefinition = correctFormula(s$parsed$equation) 62 | 63 | if (length(variableDefinition) == 1) { 64 | variableName = deparse1(variableDefinition) 65 | } else { 66 | variableName = deparse1(variableDefinition[[2]]) 67 | } 68 | variableIndices = Map(function(f) 69 | str2lang(f)[[2]], qualifiers) 70 | 71 | 72 | if (length(variableIndices) > 0) { 73 | expr = sprintf( 74 | "sprintf('%s[%s]',%s)", 75 | variableName, 76 | paste(rep('\"%s\"', length( 77 | variableIndices 78 | )), collapse = ','), 79 | paste(unlist(variableIndices), collapse = ',') 80 | ) 81 | } else { 82 | expr = sprintf("'%s[%s]'", 83 | variableName, 84 | paste(rep('\"%s\"', length( 85 | variableIndices 86 | )), collapse = ',')) 87 | } 88 | 89 | for (qualifier in c(qualifiers)) { 90 | q = str2lang(qualifier) 91 | expr = sprintf(# 'for(%s in %s){%s}', 92 | 'Map(function(%s)%s,%s)', 93 | deparse1(q[[2]]), 94 | expr, 95 | deparse1(q[[3]])) 96 | } 97 | # toRet[[length(toRet) + 1]] = expr 98 | if (length(qualifiers) == 0) { 99 | toRet[[length(toRet) + 1]] = sprintf('variables = c(variables,%s)' , expr) 100 | 101 | } else{ 102 | toRet[[length(toRet) + 1]] = sprintf('variables = c(variables,unlist(do.call(c,%s)))' , expr) 103 | 104 | } 105 | } 106 | 107 | toRet[[length(toRet) + 1]] = 'equations = unname(equations)' 108 | toRet[[length(toRet) + 1]] = 'variables = unname(variables)' 109 | 110 | toRet[[length(toRet) + 1]] = 'equationNumbers = 1:length(equations)' 111 | toRet[[length(toRet) + 1]] = 'names(equationNumbers)=equations' 112 | 113 | toRet[[length(toRet) + 1]] = 'variableNumbers = 1:length(variables)' 114 | toRet[[length(toRet) + 1]] = 'names(variableNumbers)=variables' 115 | 116 | 117 | f = str2lang('function(data)return(data)') 118 | w = str2lang('within(data,{})') 119 | 120 | for (tr in toRet) { 121 | w[[3]][[length(w[[3]]) + 1]] = str2lang(tr) 122 | } 123 | 124 | f[[3]][[2]] = w 125 | 126 | return(eval(f)) 127 | 128 | 129 | } 130 | -------------------------------------------------------------------------------- /R/equationProcessing.R: -------------------------------------------------------------------------------- 1 | getVarCoef = function(expr, 2 | sets = list(), 3 | coefficient = 1) { 4 | toRet = list() 5 | if (length(expr) == 1) { 6 | toRet[[length(toRet) + 1]] = list(variable = expr, 7 | sets = sets, 8 | coefficient = coefficient) 9 | } 10 | # If the top operator is sum: add to set/index 11 | else if (expr[[1]] == 'sum') { 12 | sets[[length(sets) + 1]] = list(index = expr[[2]], set = expr[[3]]) 13 | 14 | toRet[[length(toRet) + 1]] = getVarCoef(expr[[4]], sets, coefficient = coefficient) 15 | 16 | } else if (expr[[1]] == '[') { 17 | toRet[[length(toRet) + 1]] = list(variable = expr, 18 | sets = sets, 19 | coefficient = coefficient) 20 | } else if (expr[[1]] == '(') { 21 | toRet[[length(toRet) + 1]] = getVarCoef(expr[[2]], sets, coefficient = coefficient) 22 | } else if (expr[[1]] == '+') { 23 | toRet[[length(toRet) + 1]] = getVarCoef(expr[[2]], sets, coefficient = coefficient) 24 | toRet[[length(toRet) + 1]] = getVarCoef(expr[[3]], sets, coefficient = coefficient) 25 | } else if (expr[[1]] == '-' & length(expr)==3) { 26 | toRet[[length(toRet) + 1]] = getVarCoef(expr[[2]], sets, coefficient = coefficient) 27 | toRet[[length(toRet) + 1]] = getVarCoef(expr[[3]], sets, coefficient = call('-',coefficient)) 28 | } else if (expr[[1]] == '-' & length(expr)==2) { 29 | toRet[[length(toRet) + 1]] = getVarCoef(expr[[2]], sets, coefficient = call('-',coefficient)) 30 | } else if (expr[[1]] == '*') { 31 | toRet[[length(toRet) + 1]] = getVarCoef(expr[[3]], sets, coefficient = call('*', coefficient, expr[[2]])) 32 | } else if (expr[[1]] == '=') { 33 | toRet[[length(toRet) + 1]] = getVarCoef(expr[[2]], sets, coefficient = coefficient) 34 | toRet[[length(toRet) + 1]] = getVarCoef(expr[[3]], sets, coefficient = call('*', coefficient,-1)) 35 | 36 | } 37 | return(toRet) 38 | } 39 | 40 | 41 | unlistVarCoef = function(obj) { 42 | toRet = list() 43 | for (e in obj) { 44 | if (!is.null(e$variable)) { 45 | toRet[[length(toRet) + 1]] = e 46 | } else{ 47 | getResults = unlistVarCoef(e) 48 | for (ge in getResults) { 49 | toRet[[length(toRet) + 1]] = ge 50 | } 51 | } 52 | } 53 | return(toRet) 54 | } 55 | 56 | generateEquationCoefficients = function(equationStatements) { 57 | #toRet = list('equationMatrixList=list()') 58 | toRet = list() 59 | for (s in equationStatements) { 60 | # Get the formula for each variable 61 | frm = correctFormula(s$parsed$equation) 62 | 63 | variables = unlistVarCoef(getVarCoef(frm)) 64 | 65 | for (v in 1:length(variables)) { 66 | if (length(variables[[v]]$variable) == 1) { 67 | variables[[v]]$indices = list() 68 | variables[[v]]$varname = variables[[v]]$variable 69 | } else{ 70 | variables[[v]]$indices = as.list(variables[[v]]$variable[3:length(variables[[v]]$variable)]) 71 | variables[[v]]$varname = variables[[v]]$variable[[2]] 72 | } 73 | variables[[v]]$qualifiers = Map(function(f) 74 | sprintf('all(%s,%s)', deparse(f$index), deparse1(f$set)), 75 | variables[[v]]$sets) 76 | } 77 | 78 | dimensions = s$parsed$elements[grep('\\(all,', s$parsed$elements)] 79 | qualifiers = gsub('<>', '!=', gsub(':', ",", gsub( 80 | '=', '==', gsub('\\(all,', 'all(', dimensions) 81 | ))) 82 | 83 | 84 | equationName = s$parsed$equationName 85 | equationIndices=Map(function(f)str2lang(f)[[2]],qualifiers) 86 | 87 | #Loop throuch each variable mentioned in this equation 88 | for (v in variables) { 89 | #Loop through the qualifiers (zeroth is the initial equation) 90 | expr = sprintf( 91 | "list(list(equation=%s,variable = %s, expression= %s))", 92 | 93 | ifelse(length(equationIndices)>0,sprintf( 94 | "sprintf('%s[%s]',%s)", 95 | equationName, 96 | paste(rep('\"%s\"', length(equationIndices)), collapse = ','), 97 | paste(unlist(equationIndices), collapse = ',') 98 | ),sprintf( 99 | '"%s[%s]"', 100 | equationName, 101 | paste(rep('\"%s\"', length(equationIndices)), collapse = ',') 102 | )), 103 | 104 | ifelse( 105 | length(v$indices) > 0, 106 | sprintf( 107 | "sprintf('%s[%s]',%s)", 108 | deparse1(v$varname), 109 | paste(rep('\"%s\"', length(v$indices)), collapse = ','), 110 | paste(unlist(v$indices), collapse = ',') 111 | ), 112 | sprintf( 113 | '"%s[%s]"', 114 | deparse1(v$varname), 115 | paste(rep('\"%s\"', length(v$indices)), collapse = ',') 116 | ) 117 | ), 118 | deparse1(sumToMap(v$coefficient)) 119 | ) 120 | for (qualifier in c(qualifiers, v$qualifiers)) { 121 | q = str2lang(qualifier) 122 | expr = sprintf( 123 | 'unlist(Map(function(%s)%s,%s),recursive=F,use.names=F)', 124 | deparse1(q[[2]]), 125 | expr, 126 | deparse1(q[[3]]) 127 | ) 128 | } 129 | toRet[[length(toRet) + 1]] = sprintf('%s',expr) 130 | } 131 | 132 | 133 | } 134 | 135 | combinedExpression = sprintf("equationMatrixList=unlist(list(%s),recursive=FALSE)", paste(toRet,collapse=",")) 136 | 137 | 138 | f = str2lang('function(data)return(data)') 139 | w = str2lang('within(data,{})') 140 | # for (tr in toRet) { 141 | # w[[3]][[length(w[[3]]) + 1]] = str2lang(tr) 142 | # } 143 | 144 | w[[3]][[length(w[[3]]) + 1]] = parse(text=combinedExpression)[[1]] 145 | 146 | f[[3]][[2]] = w 147 | 148 | return(eval(f)) 149 | } 150 | -------------------------------------------------------------------------------- /R/tabloToStatements.R: -------------------------------------------------------------------------------- 1 | 2 | removeComments <- function(linn) { 3 | # Remove line comments 4 | 5 | #linn = linn[substr(linn, 1, 1) != "!"] 6 | linn = linn[nchar(linn) > 0] 7 | 8 | # Remove block comments 9 | 10 | inComment = F 11 | include = c() 12 | for (i in 1:length(linn)) { 13 | if (substr(linn[i], 1, 2) == "/*" & inComment == F) { 14 | inComment = T 15 | } else if (substr(linn[i], 1, 2) == "*/" & inComment == T) { 16 | inComment = F 17 | } else if (!inComment) { 18 | include = c(include, i) 19 | } 20 | } 21 | 22 | linn = linn[include] 23 | return(linn) 24 | } 25 | 26 | 27 | breakLine <- function(line, definitions) { 28 | return(Map(function(d) 29 | trimws(substr( 30 | line, 31 | ifelse(is.null(d$from), 1, d$from), 32 | ifelse(is.null(d$to), nchar(line), d$to) 33 | )), definitions)) 34 | 35 | } 36 | readFirstWord = function(statement){ 37 | 38 | statement = trimws(statement) 39 | 40 | if(grepl("^equation",statement, ignore.case = TRUE)){ 41 | firstWord = "equation" 42 | } else if(grepl("^variable",statement, ignore.case = TRUE)){ 43 | firstWord = "variable" 44 | } else if(grepl("^read",statement, ignore.case = TRUE)){ 45 | firstWord = "read" 46 | } else if(grepl("^write",statement, ignore.case = TRUE)){ 47 | firstWord = "write" 48 | } else if(grepl("^file",statement, ignore.case = TRUE)){ 49 | firstWord = "file" 50 | } else if(grepl("^assertion",statement, ignore.case = TRUE)){ 51 | firstWord = "assertion" 52 | } else if(grepl("^set",statement, ignore.case = TRUE)){ 53 | firstWord = "set" 54 | } else if(grepl("^subset",statement, ignore.case = TRUE)){ 55 | firstWord = "subset" 56 | } else if(grepl("^coefficient",statement, ignore.case = TRUE)){ 57 | firstWord = "coefficient" 58 | } else if(grepl("^update",statement, ignore.case = TRUE)){ 59 | firstWord = "update" 60 | } else if(grepl("^formula",statement, ignore.case = TRUE)){ 61 | firstWord = "formula" 62 | } else if(grepl("^zerodivide",statement, ignore.case = TRUE)){ 63 | firstWord = "zerodivide" 64 | } else { 65 | firstWord = "" 66 | } 67 | 68 | return(list(firstWord = firstWord, rest = trimws(substr(statement,nchar(firstWord)+1,nchar(statement))))) 69 | } 70 | 71 | readEquationName = function(statement){ 72 | 73 | statement = trimws(statement) 74 | 75 | findName = gregexpr('^[a-z]{1,}[a-z0-9_]{1,}', statement, ignore.case = TRUE)[[1]] 76 | 77 | firstWord = substr(statement, findName, attributes(findName)$match.length) 78 | 79 | return(list(firstWord = firstWord, rest = trimws(substr(statement,attributes(findName)$match.length+1,nchar(statement))))) 80 | } 81 | cleanLine = function(line) { 82 | inComment = F 83 | lineClean = '' 84 | comment = '' 85 | for (i in 1:nchar(line)) { 86 | if (substr(line, i, i) == '#') { 87 | inComment = !inComment 88 | # comment = paste(comment, substr(line, i, i), sep = '') 89 | } else if (!inComment) { 90 | if (!(substr(line, i, i) == ' ' & 91 | substr(lineClean, nchar(lineClean), nchar(lineClean)) == ' ')) { 92 | lineClean = paste(lineClean, substr(line, i, i), sep = '') 93 | } 94 | } else { 95 | comment = paste(comment, substr(line, i, i), sep = '') 96 | } 97 | } 98 | 99 | comment = trimws(comment) 100 | lineClean = trimws(lineClean) 101 | lineClean=gsub('\\[','(',lineClean) 102 | lineClean=gsub('\\]',')',lineClean) 103 | lineClean=gsub('\\{','(',lineClean) 104 | lineClean=gsub('\\}',')',lineClean) 105 | lineClean=gsub('\\bif\\b','IF',lineClean) 106 | return(list( 107 | comment = comment, 108 | statement = lineClean 109 | )) 110 | } 111 | 112 | 113 | # Take a file name, read the file, remove comments and return a vector of tablo lines 114 | fileToLines = function(fileName) { 115 | #browser() 116 | file = tolower(readChar(fileName, file.info(fileName)$size)) 117 | 118 | 119 | beginStrongComment = gregexpr("!\\[\\[!", file, )[[1]] 120 | endStrongComment = gregexpr("!\\]\\]!", file, )[[1]] 121 | if (beginStrongComment[1] > 0) { 122 | strongCommentDepth = unlist(Map( 123 | function(f) 124 | sum(beginStrongComment < f) - sum(endStrongComment <= f) , 125 | endStrongComment 126 | )) 127 | 128 | beginStrongComment = beginStrongComment[strongCommentDepth == 0] 129 | endStrongComment = endStrongComment[strongCommentDepth == 0] 130 | 131 | fileClean = substr(file, 1, beginStrongComment[1] - 1) 132 | 133 | for (nn in 1:length(endStrongComment)) { 134 | if (nn < length(endStrongComment)) { 135 | fileClean = paste0(fileClean, 136 | substr(file, endStrongComment[nn] + 5, beginStrongComment[nn + 1] - 1)) 137 | } else { 138 | fileClean = paste0(fileClean, substr(file, endStrongComment[nn] + 5, nchar(file))) 139 | } 140 | } 141 | } else{ 142 | fileClean = file 143 | } 144 | 145 | 146 | comments = gregexpr("!", fileClean, )[[1]] 147 | 148 | 149 | if (comments[1] > 0) { 150 | beginComment = comments[c(TRUE, FALSE)] 151 | endComment = comments[c(FALSE, TRUE)] 152 | 153 | 154 | fileClean2 = substr(fileClean, 1, beginComment[1] - 1) 155 | 156 | for (nn in 1:length(beginComment)) { 157 | if (nn < length(beginComment)) { 158 | fileClean2 = paste0(fileClean2, 159 | substr(fileClean, endComment[nn] + 1, beginComment[nn + 1] - 1)) 160 | } else { 161 | fileClean2 = paste0(fileClean2, substr(fileClean, endComment[nn] + 1, nchar(fileClean))) 162 | } 163 | 164 | } 165 | } else{ 166 | fileClean2 = fileClean 167 | } 168 | 169 | smallComment = gregexpr("#", fileClean2, )[[1]] 170 | 171 | 172 | beginSmallComment = smallComment[c(TRUE,FALSE)] 173 | endSmallComment = smallComment[c(FALSE, TRUE)] 174 | 175 | 176 | exclamations = gregexpr(";", fileClean2, )[[1]] 177 | 178 | if(beginSmallComment[1]==-1){ 179 | breakLine = exclamations 180 | } else{ 181 | breakLine = Filter(function(f){ 182 | !any(f>beginSmallComment & f0]) 196 | 197 | # fileClean2 198 | # 199 | # inComment = F 200 | # strongComment = 0 201 | # fileClean = '' 202 | # 203 | # i=1 204 | # while(i<=nchar(file)){ 205 | # #for (i in 1:nchar(file)) { 206 | # 207 | # if(substr(file,i,i+3)=='![[!' & !inComment){ 208 | # strongComment = strongComment + 1 209 | # i = i + 4 210 | # } else if (substr(file,i,i+3)=='!]]!' & !inComment){ 211 | # strongComment = strongComment - 1 212 | # i = i + 4 213 | # } else if (substr(file, i, i) == '!' & strongComment==0) { 214 | # inComment = !inComment 215 | # } else if (!inComment & strongComment==0) { 216 | # if (!is.element(substr(file, i, i) , c('\r', '\n'))) { 217 | # fileClean = paste(fileClean, substr(file, i, i), sep = '') 218 | # } 219 | # } 220 | # i=i+1 221 | # } 222 | 223 | #return(strsplit(fileClean, ';', fixed = T)[[1]]) 224 | 225 | } 226 | 227 | generateParsedInput = function(statement){ 228 | # Pattern ()()expression 229 | 230 | inParenthesis=0 231 | element = '' 232 | elements=list() 233 | 234 | for(i in 1:nchar(statement)){ 235 | if(substr(statement,i,i)=='(' & inParenthesis==0){ 236 | element = paste(element,substr(statement,i,i),sep='') 237 | inParenthesis = inParenthesis+1 238 | } 239 | else if(inParenthesis==0 & ! substr(statement,i,i) %in% c(' ')){ 240 | break 241 | } else if (inParenthesis>0 & substr(statement,i,i)==')'){ 242 | element = paste(element,substr(statement,i,i),sep='') 243 | if(inParenthesis==1){ 244 | elements[[length(elements)+1]]=element 245 | element='' 246 | } 247 | inParenthesis=inParenthesis-1 248 | } 249 | else{ 250 | element = paste(element,substr(statement,i,i),sep='') 251 | if(substr(statement,i,i)=='('){ 252 | inParenthesis = inParenthesis+1 253 | } 254 | } 255 | } 256 | 257 | equation = substr(statement, i,nchar(statement)) 258 | 259 | return(list(elements=elements, equation = equation)) 260 | } 261 | 262 | generateParsedInputEquation = function(statement) { 263 | #statement = "(all,i,IND)(all,o,OCC)x1lab[i,o] = x1lab_o[i] - SIGMA1LAB[i]*(p1lab[i,o] - p1lab_o[i])" 264 | #statement="Equation E_SalesDecompA(all,c,COM)(all,d,DEST) INITSALES(c)*SalesDecomp(c,d) = 100*delSale(c,\"dom\",d)" 265 | 266 | # Find all valid elements 267 | # In equation, you can only specify (all,X,Y) 268 | foundElements = gregexpr( 269 | "\\(\\s*all\\s*,\\s*[a-z]{1,}[a-z0-9_]{0,}\\s*,\\s*[a-z]{1,}[a-z0-9_]{0,}\\s*\\)", 270 | statement, 271 | ignore.case = TRUE 272 | ) 273 | 274 | 275 | elements = Map(function(f) { 276 | substr( 277 | statement, 278 | foundElements[[1]][f], 279 | foundElements[[1]][f] + attributes(foundElements[[1]])$match.length[f] - 1 280 | ) 281 | }, 1:length(foundElements[[1]])) 282 | 283 | equation = substr( 284 | statement, 285 | foundElements[[1]][length(foundElements[[1]])] + attributes(foundElements[[1]])$match.length[length(foundElements[[1]])], 286 | nchar(statement) 287 | ) 288 | 289 | return(list(elements = elements, equation = equation)) 290 | } 291 | 292 | 293 | # This takes as input a filename for a tablo file and returns a list of statements 294 | tabloToStatements = function(tablo){ 295 | 296 | #browser() 297 | 298 | #filename <- 'd:/temp/gtap.tab' 299 | lines = fileToLines(tablo) 300 | 301 | # Get a set of lines wiht comments out 302 | cleanLines = Map(cleanLine, lines) 303 | names(cleanLines)=NULL 304 | 305 | cleanLines = Map(function(f){ 306 | temp = readFirstWord(f$statement) 307 | f$class = tolower(temp$firstWord) 308 | f$command = temp$rest 309 | #class(f$command)=f$class 310 | return(f) 311 | } 312 | , cleanLines) 313 | 314 | 315 | # If there is no statement, then use the statment before 316 | for(n in 2:length(cleanLines)){ 317 | if(cleanLines[[n]]$class==""){ 318 | cleanLines[[n]]$class = cleanLines[[n-1]]$class 319 | } 320 | } 321 | 322 | cleanLinesParsed = Map(function(f){ 323 | if(f$class=='equation'){ 324 | # Equations are recorded very differently from the rest of the objects in TABLO 325 | getEquationName=readEquationName(f$command) 326 | temp =generateParsedInputEquation(getEquationName$rest) 327 | temp$equationName=getEquationName$firstWord 328 | }else { 329 | temp = generateParsedInput(f$command) 330 | } 331 | f$parsed = temp 332 | return(f) 333 | },cleanLines) 334 | 335 | return(cleanLinesParsed) 336 | 337 | } 338 | -------------------------------------------------------------------------------- /R/GEModel.R: -------------------------------------------------------------------------------- 1 | # properties: 2 | # TABLO as a recipe 3 | # data files as data 4 | # exogenous variables as a definition 5 | # methods: 6 | # solve the model (for the given coefficients) 7 | # update data (execute all updates/formulas always) 8 | 9 | GEModel = setRefClass( 10 | "GEModel", 11 | fields = list( 12 | shocks = "numeric", 13 | skeletonGenerator = 'function', 14 | equationCoefficientMatrixGenerator = 'function', 15 | equationCoefficientGenerator = 'function', 16 | generateVariables = 'function', 17 | generateUpdates = 'function', 18 | data = 'list', 19 | solution = 'numeric', 20 | changeVariables = 'character', 21 | variables = 'character', 22 | basicChangeVariables = 'character', 23 | variableValues = 'list' 24 | ), 25 | methods = list( 26 | # Loads a tablo without any data (only produces generic functions to genrate coefficients/equation coefficients etc.) 27 | loadTablo = function(tabloPath) { 28 | results = processTablo(tabloPath) 29 | skeletonGenerator <<- results$skeletonGenerator 30 | equationCoefficientMatrixGenerator <<- 31 | results$equationCoefficientMatrixGenerator 32 | equationCoefficientGenerator <<- results$equationCoefficientGenerator 33 | generateVariables <<- results$generateVariables 34 | generateUpdates <<- results$generateUpdates 35 | if(!is.null(results$changeVariables)){ 36 | basicChangeVariables <<- results$changeVariables 37 | } 38 | variables <<- results$variables 39 | }, 40 | loadData = function(inputData) { 41 | #browser() 42 | data <<- skeletonGenerator(inputData) 43 | data <<- equationCoefficientMatrixGenerator(data) 44 | data <<- generateVariables(data) 45 | variableValues <<- data[variables] 46 | changeVariables <<- data$variables[substr(data$variables,1,regexpr('\\[',data$variables)-1) %in% basicChangeVariables] 47 | }, 48 | setShocks = function(shocks) { 49 | shocks <<- shocks 50 | }, 51 | generateSolution = function(subShocks){ 52 | #browser() 53 | iNames = unlist(Map(function(i) 54 | i$equation, data$equationMatrixList)) 55 | iNumbers = data$equationNumbers[iNames] 56 | jNames = unlist(Map(function(i) 57 | i$variable, data$equationMatrixList)) 58 | jNumbers = data$variableNumbers[jNames] 59 | 60 | tictoc::tic() 61 | xValues = unlist(Map( 62 | function(i) 63 | i$expression, 64 | data$equationMatrixList 65 | )) 66 | 67 | names(xValues) = unlist(Map( 68 | function(i) 69 | i$variable, 70 | data$equationMatrixList 71 | )) 72 | 73 | #pctChanges = setdiff(names(xValues),changeVariables) 74 | #toChange = which(names(xValues) %in% relChangeVariables) 75 | 76 | #browser() 77 | 78 | #xValues[pctChanges] = xValues[pctChanges] * 0.01 79 | #xValues2[relChangeVariables] = xValues2[relChangeVariables] * 0.01 80 | 81 | tictoc::toc() 82 | 83 | #browser() 84 | 85 | data$eqcoeff = sparseMatrix( 86 | i = iNumbers, 87 | j = jNumbers, 88 | x = xValues, 89 | dims = c(length(data$equations), length(data$variables)), 90 | dimnames = list( 91 | equations = data$equations, 92 | variables = data$variables 93 | ) 94 | ) 95 | 96 | 97 | bigMatrix = data$eqcoeff[, setdiff(colnames(data$eqcoeff), names(shocks)), drop = FALSE] 98 | 99 | #browser() 100 | 101 | smallMatrix = data$eqcoeff[, names(shocks), drop = FALSE] 102 | 103 | # ### Do backsolving first 104 | # bigMatrix2 = as(bigMatrix, 'TsparseMatrix') 105 | # tt=table(bigMatrix2@j) 106 | # removeJ=bigMatrix2@j[which(bigMatrix2@j %in% as.numeric(names(tt)[tt==1]))] 107 | # removeI=bigMatrix2@i[which(bigMatrix2@j %in% as.numeric(names(tt)[tt==1]))] 108 | # 109 | # keepI=setdiff(1:dim(bigMatrix)[1] ,removeI+1) 110 | # keepJ=setdiff(1:dim(bigMatrix)[1] ,removeJ+1) 111 | # 112 | # backSolveMatrixLeft = bigMatrix[removeI+1,keepJ, drop = FALSE] 113 | # backSolveMatrixRight = bigMatrix[removeI+1,removeJ+1, drop = FALSE] 114 | # bigMatrixReduced=bigMatrix[keepI,keepJ, drop = FALSE] 115 | 116 | exoVector=-smallMatrix %*% subShocks 117 | 118 | # exoVectorReduced = exoVector[keepI,,drop=FALSE] 119 | # 120 | # tictoc::tic() 121 | # solutionReduced = SparseM::solve(bigMatrixReduced,exoVectorReduced,sparse=T,tol=1e-40) 122 | # tictoc::toc() 123 | # 124 | # #browser() 125 | # 126 | # solutionExtra = SparseM::solve(backSolveMatrixRight,-backSolveMatrixLeft%*%solutionReduced,sparse=T,tol=1e-40) 127 | # 128 | # iterationSolution =c(solutionExtra,solutionReduced) [colnames(bigMatrix)] 129 | 130 | iterationSolution=SparseM::solve(bigMatrix,exoVector,sparse=T,tol=1e-40) 131 | 132 | return(iterationSolution) 133 | }, 134 | solveModel = function(iter = 3, steps = c(1,3)) { 135 | 136 | # Create a shock variable 137 | 138 | #browser() 139 | 140 | shocks <<- do.call(c,unname(Map(function(f){ 141 | toVector(variableValues[[f]],f) 142 | }, names(variableValues)))) 143 | 144 | shocks<<-shocks[!is.na(shocks)] 145 | 146 | #browser() 147 | 148 | # shocks for change variables are not compounded 149 | #subShocks = shocks/iter 150 | 151 | # # list of relevant change variables in shocks 152 | # pctChangeShocks = setdiff(names(subShocks), changeVariables) 153 | # 154 | # # shocks need to be split for each subinterval 155 | # subShocks[pctChangeShocks] = (exp(log(1+shocks[pctChangeShocks]/100)/iter)-1)*100 156 | 157 | 158 | #names(subShocks)=names(shocks) 159 | 160 | solution <<- as.numeric(c()) 161 | 162 | iterationSolution = list() 163 | 164 | appliedShocks = shocks 165 | appliedShocks[] = 0 166 | 167 | # Go through each iteration (subinterval) 168 | for (it in 1:iter) { 169 | message(sprintf('Iteration %s/%s', it, iter)) 170 | 171 | remainingShocks = ((1+shocks/100)/(1+appliedShocks/100)-1)*100 172 | subShocks = remainingShocks/(iter-it+1) 173 | 174 | appliedShocks = ((1+ appliedShocks/100) * (1+subShocks/100)-1)*100 175 | 176 | # Within each iteration (subinterval) do steps 177 | 178 | # Save the state of the model 179 | originalData = data 180 | 181 | stepSolution = list() 182 | 183 | for(step in 1:length(steps)){ 184 | 185 | message(sprintf('Step set %s/%s', step,length(steps))) 186 | 187 | # In each step set start from the original state of data 188 | data <<- originalData 189 | 190 | # Except for change variables... 191 | # stepShocks = subShocks/steps[step] 192 | 193 | # .... step shocks are compunded 194 | #stepShocks[pctChangeShocks] = (exp(log(1+subShocks[pctChangeShocks]/100)/steps[step])-1)*100 195 | 196 | subStepSolution=list() 197 | 198 | appliedSubShocks = subShocks 199 | appliedSubShocks[] = 0 200 | 201 | 202 | for(currentStep in 1:steps[step]){ 203 | 204 | remainingSubShocks = ((1+subShocks/100)/(1+appliedSubShocks/100)-1)*100 205 | 206 | stepShocks = remainingSubShocks/(steps[step]-currentStep+1) 207 | 208 | appliedSubShocks = ((1+ appliedSubShocks/100) * (1+stepShocks/100)-1)*100 209 | 210 | 211 | data <<- equationCoefficientGenerator(data) 212 | message(sprintf('Step %s/%s', currentStep,steps[step])) 213 | #browser() 214 | # Solve the model for this shock 215 | subStepSolution[[currentStep]] = generateSolution(stepShocks) 216 | 217 | # Update the variables 218 | data <<- within(data,{ 219 | eval(parse(text=sprintf("%s=%s;", names(subStepSolution[[currentStep]]), subStepSolution[[currentStep]][names(subStepSolution[[currentStep]])]))) 220 | }) 221 | 222 | # Update the shocked variables 223 | data <<- within(data,{ 224 | eval(parse(text=sprintf("%s=%s;", names(stepShocks), stepShocks[names(stepShocks)]))) 225 | }) 226 | 227 | # Update the data 228 | data <<- generateUpdates(data) 229 | 230 | } 231 | #browser() 232 | 233 | 234 | stepSolution[[step]] = rowSums(do.call(cbind,subStepSolution)) 235 | 236 | solutionPctChangeVariables = setdiff(names(stepSolution[[step]]), changeVariables) 237 | 238 | stepSolution[[step]][solutionPctChangeVariables] = ((apply(do.call(cbind,subStepSolution)/100+1, MARGIN=1, FUN = prod)-1)*100)[solutionPctChangeVariables] 239 | #browser() 240 | # If any step <-100 we have to treat it as a change variable (like GEMPACK) 241 | # sols = apply(do.call(cbind,subStepSolution)<=-100,MARGIN = 1, any) 242 | # 243 | # solutionPctChangeVariables=setdiff(solutionPctChangeVariables, names(sols[sols])) 244 | 245 | #stepSolution[[step]][solutionPctChangeVariables] = (exp(rowSums(log(1+do.call(cbind,subStepSolution)[solutionPctChangeVariables,, drop = FALSE]/100)))-1)*100 246 | } 247 | 248 | #browser() 249 | 250 | if(length(steps)==1){ 251 | 252 | # We only have one set of steps--this is the solution 253 | iterationSolution[[it]] = stepSolution[[1]] 254 | 255 | } else if(length(steps)==2) { 256 | 257 | # We have two sets of steps and so we can extrapolate 258 | #browser() 259 | iterationSolution[[it]] = colSums(t(do.call(cbind,stepSolution)) * (steps[c(1,2)] * c(1,-1))) / (steps[1]-steps[2]) 260 | 261 | 262 | 263 | } else if(length(steps)==3) { 264 | 265 | # We have three sets of steps and so we can extrapolate and provide accuracy 266 | iterationSolution[[it]] = colSums(t(do.call(cbind,stepSolution)) * (steps[c(2,3)] * c(1,-1))) / (steps[2]-steps[3]) 267 | 268 | } 269 | 270 | # tictoc::tic() 271 | # data <<- equationCoefficientGenerator(data) 272 | # tictoc::toc() 273 | # 274 | # iterationSolution = generateSolution(subShocks) 275 | # 276 | # if (length(solution)==0) { 277 | # solution <<- c(iterationSolution, shocks) 278 | # } else{ 279 | # 280 | # namesToUse = names(solution) 281 | # intermediateSolution = ifelse(names(c(iterationSolution, shocks)) %in% changeVariables, solution + c(iterationSolution, shocks), ((1 + solution / 100) * (1 + c(iterationSolution, shocks) / 100) - 1) * 100) 282 | # names(intermediateSolution)=namesToUse 283 | # solution<<-intermediateSolution 284 | # } 285 | 286 | #browser() 287 | 288 | data <<-originalData 289 | 290 | tictoc::tic() 291 | data <<- within(data,{ 292 | eval(parse(text=sprintf("%s=%s;", names(iterationSolution[[it]]), iterationSolution[[it]][names(iterationSolution[[it]])]))) 293 | }) 294 | tictoc::toc() 295 | 296 | 297 | tictoc::tic() 298 | data <<- within(data,{ 299 | eval(parse(text=sprintf("%s=%s;", names(shocks), subShocks[names(shocks)]))) 300 | }) 301 | tictoc::toc() 302 | 303 | #browser() 304 | data <<- generateUpdates(data) 305 | } 306 | 307 | #browser() 308 | 309 | if(length(iterationSolution)==1){ 310 | solution <<- iterationSolution[[1]] 311 | } else { 312 | solution <<- rowSums(do.call(cbind,iterationSolution)) 313 | solutionPctChangeVariables = setdiff(names(solution), changeVariables) 314 | solution[solutionPctChangeVariables] <<- ((apply(1+do.call(cbind,iterationSolution)/100, MARGIN = 1, FUN = prod)-1)*100)[solutionPctChangeVariables] 315 | } 316 | 317 | #solution[solutionPctChangeVariables]<<- (exp(rowSums(log(1+do.call(cbind,iterationSolution)[solutionPctChangeVariables,, drop = FALSE]/100)))-1)*100 318 | 319 | tictoc::tic() 320 | data <<- within(data,{ 321 | eval(parse(text=sprintf("%s=%s;", names(solution), solution[names(solution)]))) 322 | }) 323 | tictoc::toc() 324 | 325 | tictoc::tic() 326 | data <<- within(data,{ 327 | eval(parse(text=sprintf("%s=%s;", names(shocks), shocks[names(shocks)]))) 328 | }) 329 | 330 | tictoc::toc() 331 | 332 | } 333 | ) 334 | ) 335 | --------------------------------------------------------------------------------