#' @export
get_interpolation_rule <- (x) {
((x))
if (!(".defInt")) ("R/sysdata.rda")
(x, (i) .defInt[i]])
}
## constraint-class ####
#' An S4 class to represent a custom constraint.
#'
#' @name class-constraint
#'
#' @description
#' Class `constraint` is used to define custom constraints in the optimization problem.
#' `r lifecycle::badge("experimental")`
#' @inherit newConstraint details
#'
#' @md
#' @slot name `r get_slot_info("constraint", "name")`
#' @slot desc `r get_slot_info("constraint", "desc")`
#' @slot eq `r get_slot_info("constraint", "eq")`
#' @slot for.each `r get_slot_info("constraint", "for.each")`
#' @slot rhs `r get_slot_info("constraint", "rhs")`
#' @slot defVal `r get_slot_info("constraint", "defVal")`
#' @slot interpolation `r get_slot_info("constraint", "interpolation")`
#' @slot lhs `r get_slot_info("constraint", "lhs")`
#' @slot misc `r get_slot_info("constraint", "misc")`
#'
#'
#' @include class-subsidy.R
#' @family class constraint policy
#' @rdname class-constraint
#' @order 1
#' @export
#'
("constraint",
(
= "character",
desc = "character", # desc
eq = "factor",
for.each = "data.frame",
rhs = "data.frame",
defVal = "numeric",
interpolation = "character",
lhs = "list",
misc = "list"
# parameter= list() # For the future
),
(
= ,
desc = "", # desc
eq = ("==", = (">=", "<=", "==")),
for.each = (),
rhs = (),
defVal = (),
interpolation = get_interpolation_rule("rhs"),
lhs = (),
# ! Misc
misc = ()
),
S3methods =
)
("initialize", "constraint", (.Object, ) {
.Object
})
## summand-class #####
#' An S4 class to represent a summand in a constraint.
#'
#' @name class-summand
#'
#' @description
#' Class `summand` stores information about linear
#' terms (a multiplier and a variable)
#' in the `lhs` of the constraint class.
#' It is auto-created by `newConstraint` function
#' and is not intended to be used directly by the user.
#'
#' @md
#' @slot desc `r get_slot_info("summand", "desc")`
#' @slot variable `r get_slot_info("summand", "variable")`
#' @slot for.sum `r get_slot_info("summand", "for.sum")`
#' @slot mult `r get_slot_info("summand", "mult")`
#' @slot defVal `r get_slot_info("summand", "defVal")`
#' @slot misc `r get_slot_info("summand", "misc")`
#'
#' @family class constraint
#' @order 2
#' @rdname class-constraint
#' @export
("summand",
(
desc = "character",
variable = "character",
for.sum = "list",
mult = "data.frame",
defVal = "numeric",
misc = "list"
# parameter= list() # !!! consider adding custom parameters
),
(
desc = ,
variable = ,
for.sum = (),
mult = (),
defVal = 1,
misc = ()
),
S3methods =
)
#' Create constraint object to add custom constraints to the model.
#'
#' @description
#' The function creates a new constraint object that can be used
#' to add custom constraints to the model.
#'
#' @details
#' Custom constraints extend the functionality of the model by adding
#' user-defined constraints to the optimization problem.
#' If the predefined constraints are not sufficient to describe the problem,
#' custom constraints can be used to add linear equlity or inequality
#' constraints to define additional relationships between the variables.
#' In many cases this can be done without writing constraints in the GAMS,
#' Julia/JuMP, Python/Pyomo, or GLPK-MathProg languages by using the
#' `constrant` class and the `newConstraint` function.
#' To define a custom constraint with the `newConstraint` function,
#' the user needs to specify the name of the constraint, the type of the
#' relation (equality, less than or equal, greater than or equal), the
#' left-hand side (LHS) terms of the statement, and the right-hand side (RHS) value.
#' The dimension of the constraint is set by the `for.each` parameter.
#' The 'lhs' terms are defined as a list of linear terms (summands).
#' Each summand consists of a variable, a multiplier, and a set of sets
#' for which the summand is defined.
#'
#'
#' @param name `r get_slot_info("constraint", "name")`
#' @param desc `r get_slot_info("constraint", "desc")`
#' @param ... named or unnamed list(s) of left-hand side (LHS)
#' linear terms (summands) to define the constraint.
#' Every summand is defined as a list with the following elements:
#' - `variable` - name of the variable in the summand.
#' - `mult` - multiplier for the variable in the summand.
#' - `for.sum` - list of sets for which the summand is defined.
#' The summands can be passed as named or unnamed lists.
#' They will be added to the `lhs` slot of the constraint object
#' as linear terms of mulipliers and variables.
#' @param eq Type of the relation ('==' default, '<=', '>=')
#' @param for.each list or data.frame with sets that define the dimension of the constraint.
#' @param rhs a numeric value, list or data frame with sets and numeric values for each constraint.
#' Note: zero values will be replaced with `replace_zerros` to avoid dropping them by the interpolation algorithms.
#' @param defVal `r get_slot_info("constraint", "defVal")`
#' @param interpolation `r get_slot_info("constraint", "interpolation")`
#' @param replace_zerros numeric value to replace zero values in `rhs` and `defVal`. Default is `1e-20`.
#'
#' @return Object of class `constraint`.
#' @family class constraint policy
#' @rdname newConstraint
#'
#' @export
<- (
,
desc = "",
,
eq = "==",
for.each = ,
rhs = (),
defVal = ,
interpolation = "inter",
replace_zerros = 1e-20
# arg = NULL
) {
obj <- ("constraint")
# stopifnot(length(eq) == 1 && eq %in% levels(obj@eq))
if ((eq) != 1 || !(eq %in% (obj@eq))) {
(
"Unrecognized 'eq' parameter. Use one of: ",
((obj@eq), collapse = ", ")
)
}
obj@eq] <- eq
# browser()
if ((defVal)) {
("It is advisable to define 'defVal' parameter.")
if (eq == "==") {
defVal <- 0
} if (eq == "<=") {
defVal <-
} if (eq >= ">=") {
defVal <- 0
}
}
if ((rhs)) {
if ((rhs) != 1) {
("rhs must be a single numeric value or a data.frame with sets and numeric values for each constraint.")
}
if ((defVal)) defVal <- rhs
rhs <- ()
}
if (!(rhs) && (rhs)) {
tmp <- (rhs, )
if ((tmp[1] != tmp) || ((rhs))) {
("Length of the list elements in 'rhs' must be identical.")
}
rhs <- (rhs, stringsAsFactors = )
}
if (!(rhs) && (rhs) && (rhs) == 1 && (rhs[1]]) == 1) {
if ((defVal)) defVal <- rhs[1]]
rhs <- ()
}
if ((rhs) && (rhs) == 1 && (rhs) == 1) {
if ((defVal)) defVal <- rhs[1, 1]
rhs <- ()
}
# if (is.numeric(rhs)) {
# if (length(rhs) != 1) {
# stop("rhs must be a single numeric value or a data.frame with sets and numeric values for each constraint.")
# }
# if (is.na(defVal)) defVal <- rhs
# rhs <- data.frame()
# }
# if (!is.data.frame(rhs) && is.list(rhs)) {
# xx <- sapply(rhs, length)
# if (any(xx[1] != xx)) {
# stop("Length of the list elements in 'rhs' must be identical.")
# }
# if (xx[1] >= 1) {
# xx <- data.frame(stringsAsFactors = FALSE)
# xx[seq_len(length(rhs[[1]])), ] <- NA
# for (i in names(rhs)) xx[[i]] <- rhs[[i]]
# rhs <- xx
# }
# }
# Replace zero values with 1e-20 in rhs and defVal
if (!(replace_zerros) && (rhs$rhs == 0)) {
# warning("Zero values in 'rhs' will be replaced with '", replace_zerros, "' to avoid ignoring them by the current interpolation algorithms. Use non-zero value to avoid auto-replacement and the warning. Use 'replace_zerros = NULL' to avoid replacement.")
rhs[rhs == 0] <- replace_zerros
}
if (!(replace_zerros) && !(defVal) && defVal == 0) {
# warning("Zero value in 'defVal' will be replaced with '", replace_zerros, "' to avoid ignoring it by the current interpolation algorithms. Use non-zero value to avoid auto-replacement and the warning. Use 'replace_zerros = NULL' to avoid replacement.")
defVal <- replace_zerros
}
# TYPE vs SET
obj@rhs <- rhs
obj@defVal <- defVal
obj@ <-
obj@desc <- desc
obj@interpolation <- interpolation
if (!(for.each)) {
if (!(for.each) && (for.each)) {
tmp <- (stringsAsFactors = )
fl_null <- (for.each, )
for (i (for.each)[fl_null]) {
for.each[i]] <-
}
for (i (for.each)) {
t2 <- (for.each[i]], stringsAsFactors = )
(t2) <- i
if ((tmp) == 0) {
tmp <- t2
} {
tmp <- (tmp, t2)
}
}
obj@for.each <- tmp
} if ((for.each)) {
obj@for.each <- for.each
} {
("Unrecognized 'for.each' parameter. Failed to build the costraint.")
}
}
# for (i in seq_along(arg)) {
# obj <- addSummand(obj, arg = arg[[i]])
# }
arg <- ()
for (i (arg)) {
obj <- addSummand(obj, arg = arg[i]])
}
obj
}
#' A function to check if an object is of class `constraint`.
#'
#' @param object any R object
#'
#' @return TRUE if the object inherits class `constraint`, FALSE otherwise.
#' @export
#'
#' @family class constraint
#' @describeIn newConstraint Check if an object is a constraint.
#'
#' @examples
#' isConstraint(1)
#' isConstraint(newConstraint(""))
<- (object) {
(object, "constraint")
}
# @describeIn newConstraint
# @family constraint
# @export
addSummand <- (
eqt,
variable = ,
mult = (),
for.sum = (),
arg) {
if (!((arg))) {
if (((arg) == "variable")) variable <- arg$variable
if (((arg) == "mult")) mult <- arg$mult
if (((arg) == "for.sum")) for.sum <- arg$for.sum
if (((arg) == "defVal")) defVal <- arg$defVal
}
# eqt, variable, mult, for.sum, arg
st <- ("summand")
st@variable <- variable
if (!(mult) && (mult)) {
xx <- (mult, )
if ((xx[1] != xx)) {
(("Wrong mult parameters "))
}
if (xx[1] >= 1) {
xx <- (stringsAsFactors = )
xx[seq_len((mult[1]])), ] <-
for (i (mult)) xx[i]] <- mult[i]]
mult <- xx
}
}
if ((mult)) {
st@mult <- mult
} {
st@defVal <- mult
}
st@for.sum <- for.sum
# browser()
if (((.variable_set) != variable)) {
(('Unknown variables "', variable, '"in summands "', eqt@, '"'))
}
need.set <- .variable_set[variable]]
need.set <- need.set!(need.set %in% ((eqt@for.each), (st@for.sum)))]
for (i need.set) {
st@for.sum[i] <- ()
}
if ((st@for.sum) != 0) {
st@for.sum[sapply(st@for.sum, )] <-
}
if (!((st@mult) %in% ((eqt@for.each), (st@for.sum), "value"))) {
(('Wrong mult parameter, excessive set: "', ((st@mult)!((st@mult) %in% (st@for.sum))], collapse = '", "'), '"'))
}
(st@defVal) <-
(st@variable) <-
eqt@lhs[length(eqt@lhs) + 1]] <- st
eqt
}
# prec <- add0_message$add0_arg$obj
# stm <- add0_message$add0_arg$app
# approxim <- add0_message$add0_arg$approxim
# Calculate do equation need additional set, and add it
.getSetEquation <- (prec, stm, approxim) {
# browser()
# if (stm@name == "CO2_CAP") browser()
# if (grepl("CESR_", stm@name)) browser()
# if (grepl("CESR_5_2030", stm@name)) browser()
# !!! add interpolation patch here? or in the calling function? !!!
# if (nrow(stm@for.each) > 0) {
# .interpolation0(stm@rhs, parameter = "rhs", defVal = stm@defVal,
# arg = list(approxim = approxim)
# )
# temporary fix for constraints interpolation: expanding year set
# works only for year set and if no NA values in the set
if (!(stm@rhs$year) && !((stm@rhs$year))) {
stm@rhs <- interpolate_slot(stm@rhs, val = "rhs")
}
if (!(stm@for.each$year) && !((stm@for.each$year))) {
stm@for.each <- interpolate_slot(stm@for.each, val = )
}
# !!! end
stop.constr <- (x) {
(('Constraint "', stm@, '" error: ', x))
}
get.all.child <- (x) {
# !!! Rewrite
(
(
x,
(
# approxim$calendar@slice_ancestry[
# approxim$calendar@slice_ancestry$parent %in% x,
# "child"]
(
approxim$calendar@slice_ancestry,
approxim$calendar@slice_ancestry$parent %in% x
)"child"]]
)
)
)
}
# all.set contain all set for for.each & lhs
# Estimate is need sum for for.each
# set.map need special mapping or consist all set
all.set <- (
= (), # name in equation
set = (), # original set
for.each = (), # for.each, lhs
lhs.num = (), # number for lhs
lead.year = (), # use only for year & lhs (next year)
lag.year = (), # use only for year & lhs (old year)
def.lhs = (), # not in for.each
new.map = (), # need new sub set
stringsAsFactors =
)
set.map <- ()
set.map.name <- # Temp vector with name for list set.map
# all.set & set.map
# for.each
old_for_each <- (stm@for.each, (x) {
if (((x))) {
()
}
((x))
})
(old_for_each) <- (stm@for.each)
nn <- ((old_for_each) + ((stm@lhs, (x) (.variable_set[x@variable]]))))
all.set[seq_along(nn), ] <-
for (i in (1:(all.set))[sapply(all.set, ) == "logical"]) {
all.set[i]] <-
}
nn <- 0
if ((old_for_each) > 0) {
nn <- (old_for_each)
all.set[nn, "set"] <- (old_for_each)
all.set[nn, "alias"] <- (old_for_each)
all.set[nn, "for.each"] <-
for.each.set <- (old_for_each)
# Fill add.map for for.each
for (j for.each.set) {
if (!(old_for_each[j]]) && !(prec@set[j]] %in% old_for_each[j]])) {
if ((old_for_each[j]] %in% prec@set[j]])) {
# warning(paste0('Set "'))
old_for_each[j]] <-
old_for_each[j]][old_for_each[j]] %in% prec@set[j]]]
}
set.map.name <- (set.map.name, j)
set.map[length(set.map.name)]] <- old_for_each[j]]
all.set[nn[names(old_for_each) == j], "new.map"] <- (set.map.name)
}
}
} {
for.each.set <-
}
# lhs
for (i (stm@lhs)) {
# browser()
need.set <- .variable_set[stm@lhs[i]]@variable]]
nn <- (nn[length(nn)] + (need.set))
all.set[nn, "set"] <- need.set
all.set[nn, "alias"] <- need.set
all.set[nn, "lhs.num"] <- i
if (((stm@lhs[i]]@for.sum) == "lag.year")) {
if ((need.set != "year")) {
stop.constr("For lag.year have to define use variable with year")
}
all.set[nn[need.set == "year"], ("lag.year", "def.lhs")] <-
}
if (((stm@lhs[i]]@for.sum) == "lead.year")) {
if ((need.set != "year")) {
stop.constr("For lead.year have to define use variable with year")
}
all.set[nn[need.set == "year"], ("lead.year", "def.lhs")] <-
}
all.set[nn[need.set %in% (stm@lhs[i]]@for.sum)], "def.lhs"] <-
all.set[nn!(need.set %in% for.each.set)], "def.lhs"] <-
# Add to set map
st <- (stm@lhs[i]]@for.sum)[names(stm@lhs[i]]@for.sum) %in% need.set &
!((stm@lhs[i]]@for.sum), )]
# Fill add.map for for.lhs
for (j st) {
if (!(stm@lhs[i]]@for.sum[j]]) &&
!(prec@set[j]] %in% stm@lhs[i]]@for.sum[j]]) && (j != "slice" ||
!(prec@set[j]] %in% get.all.child(stm@lhs[i]]@for.sum[j]])))) {
# check if the same set in lhs exist
fl <-
if ((!(all.set[nn[need.set == j], ("lead.year", "lag.year")],
recursive =
))) {
fl <- nn(!all.set$for.each[nn] & all.set$set[nn] == j &
!(all.set$new.map[nn]))]
}
add.new <-
if ((fl)) {
for (k all.set[fl, "new.map"]) {
if ((stm@lhs[i]]@for.sum[j]]) == (set.map[k]]) &&
(stm@lhs[i]]@for.sum[j]] %in% set.map[k]]) && (set.map[k]] %in% stm@lhs[i]]@for.sum[j]])) {
all.set[nn[need.set == j], "new.map"] <- k
add.new <-
}
}
}
if (add.new) {
set.map.name <- (set.map.name, j)
set.map[length(set.map.name)]] <- stm@lhs[i]]@for.sum[j]]
all.set[nn[need.set == j], "new.map"] <- (set.map.name)
}
}
}
}
# Add alias
fl <- (!all.set$for.each & all.set$def.lhs & all.set$set %in% for.each.set)
if ((fl)) {
all.set[fl, "alias"] <- (all.set[fl, "set"], "p")
}
# Need add code to reduce additional mapping
# Maaping
if ((set.map) > 0) {
mpp <- all.set!(all.set$new.map), ("new.map", "alias")]
mpp <- mpp!(mpp$new.map), ]
mpp <- mpp[sort(mpp$new.map, index.return = )$ix, , = ]
new.map.name <- ("mCns", stm@, "_", mpp$new.map)
new.map.name.full <- (new.map.name, "(", mpp$, ")")
for (i (set.map)) {
prec@parameters[new.map.name[i]]] <-
addMultipleSet(
newParameter(new.map.name[i], set.map.name[i], "map"),
(set.map[i]])
)
}
# copy new.map for lhs set that define in for each
fl <- ((all.set))[all.set$for.each & !(all.set$new.map)]
for (i fl) {
all.set!all.set$for.each & !all.set$def.lhs & all.set$set == all.set$set[i], "new.map"] <- all.set$new.map[i]
}
}
if ((all.set) > 0) {
st <- (all.set$set)
st <- st!(st %in% (approxim))]
for (ss st) approxim[ss]] <- prec@set[ss]]
}
# Generate GAMS code with mult & rhs parameters
res <- ()
# Declaration equation in model
res$equationDeclaration2Model <- ("eqCns", stm@)
# Declaration equation
if ((old_for_each) == 0) {
res$equationDeclaration <- res$equationDeclaration2Model
} {
res$equationDeclaration <- (res$equationDeclaration2Model, "(", ((old_for_each), collapse = ", "), ")")
}
# Equation before ..
res$equation <- res$equationDeclaration
if (((stm@for.each))) {
tmp_fe <- stm@for.each
fl_na <- (stm@for.each)[apply((stm@for.each), 2, )]
for (i fl_na) {
tmg <- prec@parameters[i]]@
if (i == "year") {
tmg <- prec@parameters"mMidMilestone"]]@
if ((all.set$lag.year)) {
tmg <- tmg
!(tmg$year %in% prec@parameters"mMilestoneFirst"]]@$year), ,
=
]
}
if ((all.set$lead.year)) {
tmg <- tmg
tmg$year %in% prec@parameters"mMilestoneHasNext"]]@$year, ,
=
]
}
}
tmp_fe <- (
(
select(tmp_fe, -any_of(i)),
# tmp_fe[, colnames(tmp_fe) != i, drop = FALSE],
tmg
),
tmp_fe!(tmp_fe[i]]), , = ]
)
tmp_fe <- tmp_fe!(tmp_fe), , = ]
}
stm@for.each <- tmp_fe
}
if (!(stm@for.each$year)) {
stm@for.each <- stm@for.each[stm@for.each$year %in% prec@parameters"mMidMilestone"]]@$year, , = ]
if ((all.set$lag.year)) {
stm@for.each <- stm@for.each!(stm@for.each$year %in% prec@parameters"mMilestoneFirst"]]@$year), , = ]
}
if ((all.set$lead.year)) {
stm@for.each <- stm@for.each[stm@for.each$year %in% prec@parameters"mMilestoneHasNext"]]@$year, , = ]
}
}
if ((stm@for.each) > 0) {
# browser()
nmn <- ("mCnsForEach", stm@)
prec@parameters[nmn]] <- .dat2par(
newParameter(nmn, (stm@for.each), "map",
interpolation = stm@interpolation
),
stm@for.each
)
res$equation <- (res$equation, "$", nmn, "(", ((stm@for.each), collapse = ", "), ")")
}
res$equation <- (res$equation, ".. ")
# Add eq
res$equation <- (
res$equation,
" ### ",
("==" = "=e=", ">=" = "=g=", "<=" = "=l=")[as.character(stm@eq)],
" "
)
# Add rhs
if ((stm@rhs) != 0 &&
((stm@rhs$rhs != 0) ||
(stm@defVal != 0 && (stm@for.each) > (stm@rhs)))) {
# Complicated rhs
# Generate approxim
# browser()
approxim2 <-
approxim[unique(
(
(stm@rhs)[colnames(stm@rhs) %in% (approxim)],
"solver", "year", "calendar"
)
)]
if (((approxim2) == "slice")) {
approxim2$slice <- approxim2$calendar@slice_share$slice
}
fl <- (all.set$for.each & !(all.set$new.map) &
all.set$set %in% (stm@rhs))
need.set <- all.set[fl, , = ]
for (j ((need.set))) {
approxim2[need.set[j, "set"]]] <- set.map[need.set[j, "new.map"]]]
}
approxim2$fullsets <- approxim$fullsets
need.set0 <- for.each.set[for.each.set %in% (stm@rhs)]
# browser()
xx <- newParameter(("pCnsRhs", stm@), need.set0, "numpar",
defVal = stm@defVal,
# interpolation = "back.inter.forth",
# interpolation = .defInt[["rhs"]], #!!! ToDO: add @defInt slot
interpolation = stm@interpolation,
colName = "rhs"
)
# !!! Similar interpolation for LHS is needed
# browser()
yy <- .interp_numpar(stm@rhs, "rhs", xx, approxim2)
n1 <- (yy)[colnames(yy) != "value"]
# yy <- yy[
# (apply(yy[, n1, drop = FALSE], 1,
# paste0, collapse = "##") %in%
# apply(stm@for.each[, n1, drop = FALSE], 1,
# paste0, collapse = "##")
# ), , drop = FALSE]
# check:
# yy[apply(select(yy, all_of(n1)), 1, paste0, collapse = "##") %in%
# apply(select(stm@for.each, all_of(n1)), 1, paste0, collapse = "##"),]
# same using dplyr
({
yy <- yy |> right_join(select(stm@for.each, all_of(n1)))
})
prec@parameters[xx@]] <- .dat2par(xx, yy)
# Add mult
res$equation <- (
res$equation, xx@, "(",
(need.set0, collapse = ", "), ")"
)
} {
res$equation <- (res$equation, stm@defVal)
}
# Add lhs
lhs_equation <- ""
# Add lhs to equation
lhs.set <- all.set!all.set$for.each, , = ]
for (i (stm@lhs)) {
vrb <- stm@lhs[i]]@variable
lhs.set2 <- lhs.set[lhs.set$lhs.num == i, ]
vrb.lhs <- .variable_mapping[vrb]]
# Add multiple to vrb
# Add to year multiplier if lag.year | lead.year
if (((lhs.set2$lead.year) ||
(lhs.set2$lag.year)) &&
((stm@lhs[i]]@mult) == 0 ||
((stm@lhs[i]]@mult) != "year"))) {
if ((stm@lhs[i]]@mult) == 0) {
stm@lhs[i]]@mult <- (
year = , value = stm@lhs[i]]@defVal,
stringsAsFactors =
)
} {
stm@lhs[i]]@mult$year <-
}
}
# Add multiplier
if ((stm@lhs[i]]@mult) != 0) {
# Complicated parameter
# Generate approxim
approxim2 <- approxim[unique(((stm@lhs[i]]@mult)
(stm@lhs[i]]@mult) %in% (approxim)
], "solver", "year"))]
if (((approxim2) == "slice")) {
approxim2$slice <- approxim2$calendar@slice_share$slice
}
need.set <- lhs.set2[lhs.set2$set %in% (stm@lhs[i]]@mult), "set"]
need.set2 <- lhs.set2!(lhs.set2$new.map) &
lhs.set2$set %in% (stm@lhs[i]]@mult), ]
for (j ((need.set2))) {
approxim2[need.set2[j, "set"]]] <- set.map[need.set2[j, "new.map"]]]
if (((stm@lhs[i]]@mult) %in% (need.set, "value"))) {
if (!((stm@lhs[i]]@mult) %in%
(for.each.set, need.set, "value"))) {
((
"There are unknown set in constraint ",
stm@, ", mult ", i, ': "',
(
(stm@lhs[i]]@mult)
!((stm@lhs[i]]@mult) %in% (for.each.set, "value"))
],
collapse = '", "'
), '"'
))
}
# Add set that from for.each
nslc <- (stm@lhs[i]]@mult)
!((stm@lhs[i]]@mult) %in% (need.set, "value"))
]
need.set <- (need.set, nslc)
if ((stm@for.each) > 0) {
for (j nslc) {
approxim2[j]] <- (stm@for.each[j]])
}
} {
for (j nslc) {
approxim2[j]] <- approxim[j]]
}
if ((nslc == "slice")) {
approxim2$slice <- approxim$calendar@slice_share$slice
}
}
}
}
approxim2$fullsets <- approxim$fullsets
# browser()
xx <- newParameter(("pCnsMult", stm@, "_", i),
need.set,
"numpar",
defVal = stm@lhs[i]]@defVal, # !!! Check
# interpolation = "back.inter.forth"
# interpolation = .defInt[["rhs"]] # !!! Temporary fix
interpolation = stm@interpolation
)
prec@parameters[xx@]] <-
.dat2par(xx, .interp_numpar(stm@lhs[i]]@mult, "value", xx, approxim2))
if ((lhs.set2$lead.year) || (lhs.set2$lag.year)) {
yy <- .add_dropped_zeros(prec, xx@)
nn <- approxim$mileStoneForGrowth[as.character(yy$year)]
if ((lhs.set2$lag.year)) nn <- (-nn)
yy$value <- ((yy$value) * (yy$value)^nn)
prec@parameters[xx@]] <- .dat2par(xx, yy)
}
# Add mult
vrb.lhs <- (
xx@, "(", (need.set, collapse = ", "),
") * ", vrb.lhs
)
} if (stm@lhs[i]]@defVal != 1) {
vrb.lhs <- (stm@lhs[i]]@defVal, " * ", vrb.lhs)
}
# Replace setsname
for (j ((lhs.set2))[lhs.set2$ != lhs.set2$set]) {
vrb.lhs <- ((" ", lhs.set2$set[j], " "), lhs.set2$[j], vrb.lhs)
}
vrb.lhs <- (
"[ ]*[$][ ]*", "$",
(
"[ ]*[)]", ")",
(
"[ ]*[(][ ]*", "(",
(
"[ ]*[,][ ]*", ", ",
vrb.lhs
)
)
)
)
# Generate data to equation
if (i != 1) lhs_equation <- (lhs_equation, "+")
if ((!lhs.set2$def.lhs)) {
lhs_equation <- (lhs_equation, vrb.lhs)
} {
lhs.set3 <- lhs.set2[lhs.set2$def.lhs, , = ]
cnd <-
if ((!(lhs.set3$new.map))) {
cnd <- (cnd, new.map.name.full[lhs.set3$new.map!(lhs.set3$new.map)]])
}
if ((lhs.set3$lag.year == "year")) {
cnd <- (cnd, "mMilestoneNext(yearp, year)")
} if ((lhs.set3$lead.year)) {
cnd <- (cnd, "mMilestoneNext(year, yearp)")
} if ((lhs.set3$set == "year")) {
cnd <- (cnd, "mMidMilestone(year)")
}
if ((("[$]", vrb.lhs))) {
tmp <- (".*[$]", "", vrb.lhs)
if ((tmp, 1, 1) == "(") {
tmp <- (tmp, 2, (tmp) - 1)
}
cnd <- (cnd, tmp)
vrb.lhs <- ("[$].*", "", vrb.lhs)
}
# Finish for sum
if ((lhs.set2$def.lhs) == 1) {
lhs_equation <- (lhs_equation, " sum(", lhs.set3$)
} {
lhs_equation <- (
lhs_equation, " sum((",
(lhs.set3$, collapse = ", "), ")"
)
}
if ((cnd) > 1 || (("[ )]and[ (]", cnd))) {
lhs_equation <- (
lhs_equation, "$(",
(cnd, collapse = " and "), "), ", vrb.lhs, ")"
)
} if ((cnd) == 1) {
lhs_equation <- (lhs_equation, "$", cnd, ", ", vrb.lhs, ")")
} {
("error!")
}
}
}
res$equation <- ("###", lhs_equation, res$equation)
res$equation <- ("[+][[:blank:]]*[-]", "-", res$equation)
res$equation <- (res$equation, ";")
prec@gams.equation[stm@]] <- res
prec
}
# .getSetEquation(prec, stm, approxim)@gams.equation
#' @export
#' @family constraint policy
#' @rdname newConstraint
<- (
,
,
eq = "==",
rhs = 0,
for.sum = (),
for.each = (),
defVal = 0,
rule = ,
comm = ,
cout = ,
cinp = ,
aout = ,
ainp =
) { # , emis = TRUE
stop.newconstr <- (x) {
(('Constraint "', , '" error: ', x))
}
if ( == "tax") {
((, tax = rhs, comm = comm, region = for.each$region, year = for.each$year, slice = for.each$slice))
}
if ( == "subs") {
((, = rhs, comm = comm, region = for.each$region, year = for.each$year, slice = for.each$slice))
}
# if (any(grep('(share|growth)', type))) stop.newconstr(paste(type, 'have to do'))
# For wich kind of variables (capacity, newcapacity, input or output)
if ((("inp", ))) {
inpout <- "Inp"
} if ((("out", ))) {
inpout <- "Out"
} if ( == "capacity") {
inpout <- "Cap"
} if ( == "newcapacity") {
inpout <- "NewCap"
} if ("balance" == ) {
inpout <- "Balance"
} {
stop.newconstr(("Unknown type: ", ))
}
#
set.vec <- ((for.each), (for.sum))
psb.vec <- ("sup", "stg", "tech", "imp", "expp")
psb.vec.tp <- (
= "Sup", stg = "Storage", tech = "Tech",
imp = "Import", expp = "Export"
)
(psb.vec) <- psb.vec
is.set <- psb.vec[psb.vec %in% set.vec]
if ((is.set) > 1) {
stop.newconstr(("There are more than one subsets"))
}
vec.tp <- psb.vec.tp[is.set]
if ((is.set) == 0) {
if ((inpout != ("Inp", "Out", "Balance"))) {
stop.newconstr(("For ", , " have to define some subsets"))
}
vrb <- ("v", inpout, "Tot"[inpout != "Balance"])
} {
if (is.set == "tech" && inpout == "Inp") {
vrb <- ("vTech", ("", "A")[c(cinp, ainp)], "Inp")
} if (is.set == "tech" && inpout == "Out") {
vrb <- ("vTech", ("Out", "AOut")[c(cout, aout)]) # , 'EmsFuel' , emis
} if (( == ("newcapacity", "capacity"))) {
if ((is.set != ("stg", "tech"))) {
stop.newconstr(("For ", , " could be define only for tech and storage"))
}
vrb <- ("v", vec.tp, (capacity = "Cap", newcapacity = "NewCap")[type])
} {
vrb <- ("v", vec.tp, inpout)
}
}
term <- (for.sum = for.sum, variable = vrb[1])
arg <- (term)
for (i vrb-1]) {
term$variable <- i
arg[length(arg) + 1]] <- term
}
# To share
if ((("share", ))) {
if (((rhs, recursive = )) == 0) {
rhs <- (-defVal)
} if ((rhs)) {
rhs$value <- (-rhs$rhs)
rhs$rhs <-
} {
rhs <- (-rhs)
}
# for (i in seq_along(arg)) {
# arg[[i]]$mult <- rhs
# }
term <- (
for.sum = for.sum!((for.sum) %in% psb.vec)],
variable = ("v", inpout, "Tot"), mult = rhs
)
rhs <- 0
defVal <- 0
arg[length(arg) + 1]] <- term
}
# To growth
if ((("growth", ))) {
if (((rhs, recursive = )) == 0) {
rhs <- (1 / defVal)
} {
if ((rhs)) {
rhs <- (1 / rhs)
} {
rhs$value <- (1 / rhs$rhs)
rhs$rhs <-
}
}
nn <- (arg)
nk <- (arg)
for (i nn) {
arg[i + nk]] <- arg[i]]
arg[i + nk]]$mult <- rhs
arg[i + nk]]$for.sum"lead.year"] <- ()
arg[i + nk]]$for.sum$year <-
arg[i]]$mult <- (-1)
}
rhs <- 0
defVal <- 0
}
(,
eq = eq, for.each = for.each, defVal = defVal,
rhs = rhs, arg = arg
)
}
