R/methods-Constraints.R

In pmoments: Partial Moments

#################################################################################
##
##   R package pmoments by Alexios Ghalanos Copyright (C) 2008
##   This file is part of the R package pmoments.
##
##   The R package pmoments is free software: you can redistribute it and/or modify
##   it under the terms of the GNU General Public License as published by
##   the Free Software Foundation, either version 3 of the License, or
##   (at your option) any later version.
##
##   The R package pmoments is distributed in the hope that it will be useful,
##   but WITHOUT ANY WARRANTY; without even the implied warranty of
##   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
##   GNU General Public License for more details.
##
#################################################################################

constraints = function(forecasts, portfolioReturn, riskAversion = 1, budget = 1, riskFree=0, group = NA, groupUB = NA, groupLB = NA, assetsUB = NA, assetsLB = NA)
{
	UseMethod("constraints")
}

.constraints = function(forecasts, portfolioReturn, riskAversion = 1, budget = 1, riskFree=0, group = NA, groupUB = NA, groupLB = NA, assetsUB = NA, assetsLB = NA)
{
	if(missing(forecasts)) forecasts = c(0,0)
	if(missing(portfolioReturn)) portfolioReturn = 0
	.checkConstaints(forecasts,portfolioReturn,budget,group,groupUB,groupLB,assetsUB,assetsLB)
	#forecasts = as.numeric(forecasts)
	budget = as.numeric(budget)
	portfolioReturn = as.numeric(portfolioReturn)
	N = length(forecasts)
	if(is.na(group[1]))
	{
		group = matrix(0, ncol=N, nrow=1)
		groupUB = 0
		groupLB = 0
	}
	else
	{
		group = as.matrix(group)
		groupUB = as.numeric(groupUB)
		groupLB = as.numeric(groupLB)
	}
	if(is.na(assetsUB[1])) assetsUB = as.numeric(rep(Inf,N)) else assetsUB = as.numeric(assetsUB)
	if(is.na(assetsLB[1])) assetsLB = as.numeric(rep(-Inf,N)) else  assetsLB = as.numeric(assetsLB)
	new("userConstraints",call = match.call(),
			forecasts = forecasts,
			portfolioReturn = portfolioReturn,
			riskAversion = riskAversion,
			riskFree = riskFree,
			budget = budget,
			group = group,
			groupUB = groupUB,
			groupLB = groupLB,
			assetsUB = assetsUB,
			assetsLB = assetsLB)
}

setMethod("constraints",signature(forecasts = "vector", portfolioReturn = "vector"), .constraints)
setMethod("constraints",signature(forecasts = "vector", portfolioReturn = "missing"), .constraints)
setMethod("constraints",signature(forecasts = "missing", portfolioReturn = "missing"), .constraints)

solverConstraints = function(constraints, type = c("L11","L10","L01","L00"), direction = c(1,-1,0))
{
	UseMethod("solverConstraints")
}

.solverConstraints = function(constraints, type = c("L11","L10","L01","L00"), direction = c(1,-1,0))
{
	type = match.arg(type)
	if(is.na(match(direction, c(1,-1,0)))) return("invalid direction input")
	if(direction!=0)
	{
		switch(type,
				L11 = .typeL11constraints(constraints,direction),
				L10 = .typeL10constraints(constraints,direction),
				L01 = .typeL01constraints(constraints,direction),
				L00 = .typeL00constraints(constraints,direction))
	}
	else
	{
		# Equality only based solvers - NOT YET IMPLEMENTED
		switch(type,
				L11 = .typeM11constraints(constraints),
				L10 = .typeM10constraints(constraints))
	}
}

setMethod("solverConstraints", signature(constraints="userConstraints",type="character",direction="numeric"), .solverConstraints)



.typeL11constraints = function(constraints, direction = 1)
{
	# Inequality A.x <= b
	# with : Equality Aeq = beq
	# with : x bounds bLo <= x <= bUp
	forecasts = constraints@forecasts
	portfolioReturn = constraints@portfolioReturn
	budget = constraints@budget
	group = constraints@group
	groupUB = constraints@groupUB
	groupLB = constraints@groupLB
	assetsUB = constraints@assetsUB
	assetsLB = constraints@assetsLB
	n = length(forecasts)
	Aineq = direction * rbind(group,-group)
	bineq = direction * c(groupUB,-groupLB)
	budgetI = matrix(1,ncol = n, nrow = 1)
	forecastsI = matrix(forecasts,ncol = n, nrow = 1)
	Aeq = rbind(budgetI, forecastsI)
	beq = c(budget, portfolioReturn)
	new("solverConstraints",call = match.call(),
			type = "L11",
			direction = direction,
			Aineq = Aineq,
			bineq = bineq,
			Aeq = Aeq,
			beq = beq,
			UB = assetsUB,
			LB = assetsLB)
}

.typeL10constraints = function(constraints, direction = 1)
{
	# Inequality A.x <= b
	# with : Equality Aeq = beq
	# without : x bounds bLo <= x <= bUp
	forecasts = constraints@forecasts
	portfolioReturn = constraints@portfolioReturn
	budget = constraints@budget
	group = constraints@group
	groupUB = constraints@groupUB
	groupLB = constraints@groupLB
	assetsUB = constraints@assetsUB
	assetsLB = constraints@assetsLB
	n = length(forecasts)
	assetsLI = diag(rep(-1,n),n,n)
	assetsUI = diag(rep(1,n),n,n)
	assetsLBI = vector("numeric",length=n)
	assetsUBI = vector("numeric",length=n)
	assetsUBI = assetsUB
	assetsLBI = -assetsLB
	Aineq = direction * rbind(group,-group,assetsLI,assetsUI)
	bineq = direction * c(groupUB,-groupLB,assetsLBI,assetsUBI)
	budgetI = matrix(1,ncol = n, nrow = 1)
	forecastsI = matrix(forecasts,ncol = n, nrow = 1)
	Aeq = rbind(budgetI, forecastsI)
	beq = c(budget, portfolioReturn)
	
	new("solverConstraints",call = match.call(),
			type = "LI0",
			direction = direction,
			Aineq = Aineq,
			bineq = bineq,
			Aeq = Aeq,
			beq = beq)
}

.typeL01constraints = function(constraints, direction = 1)
{
	# Inequality A.x <= b
	# without : Equality Aeq = beq
	# with : x bounds bLo <= x <= bUp
	forecasts = constraints@forecasts
	portfolioReturn = constraints@portfolioReturn
	budget = constraints@budget
	group = constraints@group
	groupUB = constraints@groupUB
	groupLB = constraints@groupLB
	assetsUB = constraints@assetsUB
	assetsLB = constraints@assetsLB
	n = length(forecasts)
	forecastsI = matrix(forecasts,ncol = n, nrow = 1)
	budgetI = matrix(1,ncol = n, nrow = 1)
	Aineq = direction * rbind(group,-group,budgetI,-budgetI,forecastsI,-forecastsI)
	bineq = direction * c(groupUB,-groupLB, budget+epsilon,-budget+epsilon,portfolioReturn+epsilon,-portfolioReturn+epsilon)
	
	new("solverConstraints",
			type = "L01",
			direction = direction,
			Aineq = Aineq,
			bineq = bineq,
			UB = assetsUB,
			LB = assetsLB)
}

.typeL00constraints = function(constraints, direction = 1)
{
	# Inequality A.x <= b
	# without : Equality Aeq = beq
	# without : x bounds bLo <= x <= bUp
	forecasts = constraints@forecasts
	portfolioReturn = constraints@portfolioReturn
	budget = constraints@budget
	group = constraints@group
	groupUB = constraints@groupUB
	groupLB = constraints@groupLB
	assetsUB = constraints@assetsUB
	assetsLB = constraints@assetsLB
	n = length(forecasts)
	assetsLI = diag(rep(-1,n),n,n)
	assetsUI = diag(rep(1,n),n,n)
	assetsLBI = vector("numeric",length=n)
	assetsUBI = vector("numeric",length=n)
	assetsUBI = assetsUB
	assetsLBI = -assetsLB
	Aineq = rbind(group, -group, assetsLI, assetsUI)
	bineq = c(groupUB, -groupLB,assetsLBI, assetsUBI)
	budgetI = matrix(c(1,-1),ncol = n, nrow = 2)
	forecastsI = matrix(c(forecasts,-forecasts),ncol = n, nrow = 2,byrow=TRUE)
	Aineq = direction * rbind(Aineq, budgetI, forecastsI)
	bineq = direction * c(bineq, budget+epsilon, -budget+epsilon, portfolioReturn+epsilon, -portfolioReturn+epsilon)
	
	new("solverConstraints",
			type = "L00",
			direction = direction,
			Aineq = Aineq,
			bineq = bineq)
}

.checkConstaints = function(forecasts,portfolioReturn,budget,group,groupUB,groupLB,assetsUB,assetsLB)
{
	N1 = length(forecasts)
	N2 = length(portfolioReturn)
	N3 = length(budget)
	if(length(N3)!=1) return("budget constraint must be a of length 1")
	if(!is.na(group[1]))
	{
		N4 = dim(group)[2]
		N5 = dim(group)[1]
		if(N4!=N1) return("group length must be same size as forecasts length")
		if(length(groupUB)!=N5) return("groupUB length must be the same as row dimension of group")
		if(length(groupLB)!=N5) return("groupLB length must be the same as row dimension of group")
		if(groupUB<groupLB) return("inconsistent group bound constraints (lower>upper?)")
	}
	if(length(assetsUB)!=0 & length(assetsUB)!=N1) return("assetsUB length must be same size as forecasts length")
	if(length(assetsLB)!=0 & length(assetsLB)!=N1) return("assetsLB length must be same size as forecasts length")
	#if(!is.na(assetsLB[1]) & !is.na(assetsUB[1]))
	#{
	#if(assetsUB<assetsLB) return("inconsistent asset bound constraints (lower>upper?)")
	#}
	return(invisible())
}
.typeM11constraints<-function(constraints)
{
# not yet implemented
return(0)
}

.typeM10constraints<-function(constraints)
{
# not yet implemented
return(0)
}
#--------------------------------------------
# UserConstraints Get and Set Methods:

#--------------------------------------------
# forecasts
setGeneric("getforecasts",
		function(object){
			standardGeneric("getforecasts")
		})

setGeneric("setforecasts<-",
		function(object,value){
			standardGeneric("setforecasts<-")
		})

setMethod("getforecasts",
		signature(object="userConstraints"),
		function(object){object@forecasts})

setReplaceMethod("setforecasts",
		signature(object="userConstraints"),
		function(object,value){
			object@forecasts<-value
			object
		}
)
#--------------------------------------------
# portfolioReturn
setGeneric("getportfolioReturn",
		function(object){
			standardGeneric("getportfolioReturn")
		})

setGeneric("setportfolioReturn<-",
		function(object,value){
			standardGeneric("setportfolioReturn<-")
		})

setMethod("getportfolioReturn",
		signature(object="userConstraints"),
		function(object){object@portfolioReturn})

setReplaceMethod("setportfolioReturn",
		signature(object="userConstraints"),
		function(object,value){
			object@portfolioReturn<-value
			object
		}
)
# risk Aversion
setGeneric("getriskAversion",
		function(object){
			standardGeneric("getriskAversion")
		})

setGeneric("setriskAversion<-",
		function(object,value){
			standardGeneric("setriskAversion<-")
		})

setMethod("getriskAversion",
		signature(object="userConstraints"),
		function(object){object@riskAversion})

setReplaceMethod("setriskAversion",
		signature(object="userConstraints"),
		function(object,value){
			object@riskAversion<-value
			object
		}
)
#--------------------------------------------
# budget
setGeneric("getbudget",
		function(object){
			standardGeneric("getbudget")
		})

setGeneric("setbudget<-",
		function(object,value){
			standardGeneric("setbudget<-")
		})

setMethod("getbudget",
		signature(object="userConstraints"),
		function(object){object@budget})

setReplaceMethod("setbudget",
		signature(object="userConstraints"),
		function(object,value){
			object@budget<-value
			object
		}
)
#--------------------------------------------
# group
setGeneric("getgroup",
		function(object){
			standardGeneric("getgroup")
		})

setGeneric("setgroup<-",
		function(object,value){
			standardGeneric("setgroup<-")
		})

setMethod("getgroup",
		signature(object="userConstraints"),
		function(object){object@group})

setReplaceMethod("setgroup",
		signature(object="userConstraints"),
		function(object,value){
			object@group<-value
			object
		}
)
#--------------------------------------------
# groupUB
setGeneric("getgroupUB",
		function(object){
			standardGeneric("getgroupUB")
		})

setGeneric("setgroupUB<-",
		function(object,value){
			standardGeneric("setgroupUB<-")
		})

setMethod("getgroupUB",
		signature(object="userConstraints"),
		function(object){object@groupUB})

setReplaceMethod("setgroupUB",
		signature(object="userConstraints"),
		function(object,value){
			object@groupUB<-value
			object
		}
)
#--------------------------------------------
# groupLB
setGeneric("getgroupLB",
		function(object){
			standardGeneric("getgroupLB")
		})

setGeneric("setgroupLB<-",
		function(object,value){
			standardGeneric("setgroupLB<-")
		})

setMethod("getgroupLB",
		signature(object="userConstraints"),
		function(object){object@groupLB})

setReplaceMethod("setgroupLB",
		signature(object="userConstraints"),
		function(object,value){
			object@groupLB<-value
			object
		}
)
#--------------------------------------------
# assetsUB
setGeneric("getassetsUB",
		function(object){
			standardGeneric("getassetsUB")
		})

setGeneric("setassetsUB<-",
		function(object,value){
			standardGeneric("setassetsUB<-")
		})

setMethod("getassetsUB",
		signature(object="userConstraints"),
		function(object){object@assetsUB})

setReplaceMethod("setassetsUB",
		signature(object="userConstraints"),
		function(object,value){
			object@assetsUB<-value
			object
		}
)
#--------------------------------------------
# assetsLB
setGeneric("getassetsLB",
		function(object){
			standardGeneric("getassetsLB")
		})

setGeneric("setassetsLB<-",
		function(object,value){
			standardGeneric("setassetsLB<-")
		})

setMethod("getassetsLB",
		signature(object="userConstraints"),
		function(object){object@assetsLB})

setReplaceMethod("setassetsLB",
		signature(object="userConstraints"),
		function(object,value){
			object@assetsLB<-value
			object
		}
)
#--------------------------------------------
# risk Free
setGeneric("getriskFree",
		function(object){
			standardGeneric("getriskFree")
		})

setGeneric("setriskFree<-",
		function(object,value){
			standardGeneric("setriskFree<-")
		})

setMethod("getriskFree",
		signature(object="userConstraints"),
		function(object){object@riskFree})

setReplaceMethod("setriskFree",
		signature(object="userConstraints"),
		function(object,value){
			object@riskFree<-value
			object
		}
)
#--------------------------------------------