###############################################################################
# This program 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.
#
# This program 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.
#
# You should have received a copy of the GNU General Public License
# along with this program.  If not, see <http://www.gnu.org/licenses/>.
###############################################################################
# Asset Allocation Functions
# Copyright (C) 2011  Michael Kapler
#
# For more information please visit my blog at www.SystematicInvestor.wordpress.com
# or drop me a line at TheSystematicInvestor at gmail
###############################################################################

###############################################################################
# Building constraints for quadprog, solve.QP
# min(-d^T w.i + 1/2 w.i^T D w.i) constraints A^T w.i >= b_0
#  the first meq constraints are treated as equality constraints,
#  all further as inequality constraints
###############################################################################
# new.constraints - create new constraints structure
#' @export
###############################################################################
new.constraints <- function
(
	n,			# number of variables
	A = NULL,	# matrix with constraints
	b = NULL,	# vector b
	type = c('=', '>=', '<='),	# type of constraints
	lb = NA,	# vector with lower bounds
	ub = NA		# vector with upper bounds
)
{
	meq = 0
	if ( is.null(A) || is.na(A) || is.null(b) || is.na(b) ) {
		A = matrix(0, n, 0)
		b = c()
	} else {
		if ( is.null(dim(A)) ) dim(A) = c(len(A), 1)

		if ( type[1] == '=' ) meq = len(b)
		if ( type[1] == '<=' ) {
			A = -A
			b = -b
		}
	}

	if ( is.null(lb) || is.na(lb) ) lb = rep(NA, n)
	if ( len(lb) != n ) lb = rep(lb[1], n)

	if ( is.null(ub) || is.na(ub) ) ub = rep(NA, n)
	if ( len(ub) != n ) ub = rep(ub[1], n)

	return( list(n = n, A = A, b = b, meq = meq, lb = lb, ub = ub) )
}

###############################################################################
# add.constraints - add to existing constraints structure
#' @export
###############################################################################
add.constraints <- function
(
	A,			# matrix with constraints
	b,			# vector b
	type = c('=', '>=', '<='),	# type of constraints
	constraints	# constraints structure
)
{
	if(is.null(constraints)) constraints = new.constraints(n = nrow(A))

	if(is.null(dim(A))) A = matrix(A)

	if(len(b) == 1) b = rep(b, ncol(A))

	if ( type[1] == '=' ) {
		constraints$A = cbind( A, constraints$A )
		constraints$b = c( b, constraints$b )
		constraints$meq = constraints$meq + len(b)
	}

	if ( type[1] == '>=' ) {
		constraints$A = cbind( constraints$A, A )
		constraints$b = c( constraints$b, b )
	}

	if ( type[1] == '<=' ) {
		constraints$A = cbind( constraints$A, -A )
		constraints$b = c( constraints$b, -b )
	}

	return( constraints )
}

###############################################################################
# add.variables - add to existing constraints structure
#' @export
###############################################################################
add.variables <- function
(
	n,			# number of variables to add
	constraints,	# constraints structure
	lb = NA,	# vector with lower bounds
	ub = NA	# vector with upper bounds
)
{
	constraints$A = rbind( constraints$A, matrix(0, n, len(constraints$b)) )

	if ( is.null(lb) || is.na(lb) ) lb = rep(NA, n)
	if ( len(lb) != n ) lb = rep(lb[1], n)

	if ( is.null(ub) || is.na(ub) ) ub = rep(NA, n)
	if ( len(ub) != n ) ub = rep(ub[1], n)

	constraints$lb = c(constraints$lb, lb)
	constraints$ub = c(constraints$ub, ub)
	constraints$n = constraints$n + n

	return( constraints )
}

###############################################################################
# delete.constraints - remove specified constraints from existing constraints structure
#' @export
###############################################################################
delete.constraints <- function
(
	delete.index,	# index of constraints to delete
	constraints	# constraints structure
)
{
	constraints$A = constraints$A[, -delete.index, drop=F]
	constraints$b = constraints$b[ -delete.index]
	constraints$meq = constraints$meq - len(intersect((1:constraints$meq), delete.index))
	return( constraints )
}

#' @export
type.constraints <- function(constraints)
{
	c(rep('=', constraints$meq), rep('>=', len(constraints$b) - constraints$meq))
}

###############################################################################
# create.basic.constraints - create basic constraints
#' @export
###############################################################################
create.basic.constraints <- function(
	n,
	const.lb = 0,
	const.ub = 1,
	const.sum = 1
)
{
	if(len(const.lb) == 1) const.lb = rep(const.lb, n)
	if(len(const.ub) == 1) const.ub = rep(const.ub, n)

	# 0 <= x.i <= 1
	constraints = new.constraints(n, lb = const.lb, ub = const.ub)
		constraints = add.constraints(diag(n), type='>=', b=const.lb, constraints)
		constraints = add.constraints(diag(n), type='<=', b=const.ub, constraints)

	# SUM x.i = 1
	if(!is.na(const.sum))
		constraints = add.constraints(rep(1, n), type = '=', b=const.sum, constraints)

	return(constraints)
}

###############################################################################
# create.basic.constraints - create basic constraints
#' @export
###############################################################################
merge.constraints <- function(constraints1, constraints2) {
	if(constraints1$n != constraints2$n) stop('merge.constraints: both constraints must be based on same number of assets')

	if(constraints2$meq > 0) {
		constraints1$A = cbind( constraints2$A[,1:constraints2$meq], constraints1$A, constraints2$A[,-c(1:constraints2$meq)] )
		constraints1$b = c( constraints2$b[1:constraints2$meq], constraints1$b, constraints2$b[-c(1:constraints2$meq)] )
		constraints1$meq = constraints1$meq + constraints2$meq
	} else {
		constraints1$A = cbind( constraints1$A, constraints2$A)
		constraints1$b = c(constraints1$b, constraints2$b)
	}

	constraints1$lb =  pmax(constraints1$lb, constraints2$lb, na.rm=T)
	constraints1$ub =  pmin(constraints1$ub, constraints2$ub, na.rm=T)

	constraints1
}

###############################################################################
# General interface to Finding portfolio that Minimizes Given Risk Measure
#' @export
###############################################################################
min.portfolio <- function
(
	ia,					# input assumptions
	constraints,		# constraints
	add.constraint.fn,
	min.risk.fn
)
{
	optimize.portfolio(ia, constraints, add.constraint.fn, min.risk.fn)
}

#' @export
optimize.portfolio <- function
(
	ia,					# input assumptions
	constraints,		# constraints
	add.constraint.fn,
	min.risk.fn,
	direction = 'min',
	full.solution = F
)
{
	# load / check required packages
	load.packages('quadprog,corpcor,lpSolve,kernlab')

	n = nrow(constraints$A)
	nt = nrow(ia$hist.returns)

	# objective is stored as a last constraint
	constraints = match.fun(add.constraint.fn)(ia, 0, '>=', constraints)

	f.obj = constraints$A[, ncol(constraints$A)]
		constraints = delete.constraints( ncol(constraints$A), constraints)

	# setup constraints
	f.con = constraints$A
	f.dir = c(rep('=', constraints$meq), rep('>=', len(constraints$b) - constraints$meq))
	f.rhs = constraints$b

	# find optimal solution
	x = NA

	binary.vec = 0
	if(!is.null(constraints$binary.index)) binary.vec = constraints$binary.index

	sol = try(solve.LP.bounds(direction, f.obj, t(f.con), f.dir, f.rhs,
				lb = constraints$lb, ub = constraints$ub, binary.vec = binary.vec,
				default.lb = -100), TRUE)

	if(!inherits(sol, 'try-error')) {
		x = sol$solution[1:n]

		#cat('sol.objval =', sol$objval, '\n')

		# to check
		if( F ) {
			f.obj %*% sol$solution  - match.fun(min.risk.fn)(t(x), ia)
		}
	}

	if( full.solution ) x = sol
	return( x )
}

###############################################################################
# Rdonlp2 only works with R version before 2.9
# Rdonlp2 is not avilable for latest version of R
# for more help please visit http://arumat.net/Rdonlp2/
#
# Conditions of use:
# 1. donlp2 is under the exclusive copyright of P. Spellucci
#    (e-mail:spellucci@mathematik.tu-darmstadt.de)
#    "donlp2" is a reserved name
# 2. donlp2 and its constituent parts come with no warranty, whether ex-
#    pressed or implied, that it is free of errors or suitable for any
#    specific purpose.
#    It must not be used to solve any problem, whose incorrect solution
#    could result in injury to a person , institution or property.
#    It is at the users own risk to use donlp2 or parts of it and the
#    author disclaims all liability for such use.
# 3. donlp2 is distributed "as is". In particular, no maintenance, support
#    or trouble-shooting or subsequent upgrade is implied.
# 4. The use of donlp2 must be acknowledged, in any publication which contains
#    results obtained with it or parts of it. Citation of the authors name
#    and netlib-source is suitable.
# 5. The free use of donlp2 and parts of it is restricted for research purposes
#    commercial uses require permission and licensing from P. Spellucci.
#' @export
###############################################################################
optimize.portfolio.nlp <- function
(
	ia,					# input assumptions
	constraints,		# constraints
	fn,
	nl.constraints = NULL,	# Non-Linear constraints
	direction = 'min',
	full.solution = F
)
{
	# Rdonlp2 only works with R version before 2.9
	load.packages('Rdonlp2', repos ='http://R-Forge.R-project.org')

	# fnscale(1) - set -1 for maximization instead of minimization.
	if( direction == 'min' ) fnscale = 1 else fnscale = -1

	# control structure: as.numeric( sessionInfo()$R.version$minor ) < 9
	cntl = donlp2Control()
	cntl$silent = T
	cntl$fnscale = fnscale
	cntl$iterma =10000
	cntl$nstep = 100
	cntl$epsx = 1e-10

	# lower/upper bounds
	par.l = constraints$lb
	par.u = constraints$ub

	# intial guess
	p = rep(1, nrow(constraints$A))
	if(!is.null(constraints$x0)) {
		# if no NA's in constraints$x0
		if( sum(is.na(constraints$x0)) == 0) p = constraints$x0
	}

	# linear constraints
	A = t(constraints$A)
	lin.l = constraints$b
	lin.u = constraints$b
	lin.u[ -c(1:constraints$meq) ] = +Inf

	# find optimal solution
	x = NA

	if( !is.null(nl.constraints) ) {
		sol = donlp2(p, fn,
					par.lower=par.l, par.upper=par.u,
					A=A, lin.u=lin.u, lin.l=lin.l,
					control=cntl,
					nlin=nl.constraints$constraints,
					nlin.upper=nl.constraints$upper, nlin.lower=nl.constraints$lower
					)
	} else {
		sol = donlp2(p, fn,
					par.lower=par.l, par.upper=par.u,
					A=A, lin.u=lin.u, lin.l=lin.l,
					control=cntl)
	}

	if(!inherits(sol, 'try-error')) {
		x = sol$par
	}

	if( full.solution ) x = sol
	return( x )
}

###############################################################################
# Maximum Loss
# page 34, Comparative Analysis of Linear Portfolio Rebalancing Strategies by Krokhmal, Uryasev, Zrazhevsky
#
# Let x.i , i= 1,...,n  be weights of instruments in the portfolio.
# Let us suppose that j = 1,...,T scenarios of returns are available
# ( r.ij denotes return of i -th asset in the scenario j ).
#
# The Maximum Loss (MaxLoss) function has the form
#  w
#  such that
#  - [ SUM <over i> r.ij * x.i ] < w, for each j = 1,...,T
#' @export
###############################################################################
add.constraint.maxloss <- function
(
	ia,			# input assumptions
	value,		# b value
	type = c('=', '>=', '<='),	# type of constraints
	constraints	# constraints structure
)
{
	n0 = ncol(ia$hist.returns)
	n = nrow(constraints$A)
	nt = nrow(ia$hist.returns)

	# adjust constraints, add w
	constraints = add.variables(1, constraints)

	#  - [ SUM <over i> r.ij * x.i ] < w, for each j = 1,...,T
	a = rbind( matrix(0, n, nt), 1)
		a[1 : n0, ] = t(ia$hist.returns)
	constraints = add.constraints(a, rep(0, nt), '>=', constraints)

	# objective : maximum loss, w
	constraints = add.constraints(c(rep(0, n), 1), value, type[1], constraints)

	return( constraints )
}

#' @export
portfolio.maxloss <- function
(
	weight,		# weight
	ia			# input assumptions
)
{
	weight = weight[, 1:ia$n, drop=F]

	portfolio.returns = weight %*% t(ia$hist.returns)
	return( -apply(portfolio.returns, 1, min) )
}

#' @export
min.maxloss.portfolio <- function
(
	ia,				# input assumptions
	constraints		# constraints
)
{
	min.portfolio(ia, constraints, add.constraint.maxloss, portfolio.maxloss)

}

###############################################################################
# Mean-Absolute Deviation (MAD)
# page 33, Comparative Analysis of Linear Portfolio Rebalancing Strategies by Krokhmal, Uryasev, Zrazhevsky
#
# Let x.i , i= 1,...,n  be weights of instruments in the portfolio.
# Let us suppose that j = 1,...,T scenarios of returns are available
# ( r.ij denotes return of i -th asset in the scenario j ).
#
# The Mean-Absolute Deviation (MAD) function has the form
#  1/T * [ SUM <over j> (u+.j + u-.j) ]
#  such that
#  [ SUM <over i> r.ij * x.i ] - 1/T * [ SUM <over j> [ SUM <over i> r.ij * x.i ] ] = u+.j - u-.j , for each j = 1,...,T
#  u+.j, u-.j >= 0, for each j = 1,...,T
#' @export
###############################################################################
add.constraint.mad <- function
(
	ia,			# input assumptions
	value,		# b value
	type = c('=', '>=', '<='),	# type of constraints
	constraints	# constraints structure
)
{
	n0 = ncol(ia$hist.returns)
	n = nrow(constraints$A)
	nt = nrow(ia$hist.returns)

	# adjust constraints, add u+.j, u-.j
	constraints = add.variables(2 * nt, constraints, lb = 0)

	# [ SUM <over i> r.ij * x.i ] - 1/T * [ SUM <over j> [ SUM <over i> r.ij * x.i ] ] = u+.j - u-.j , for each j = 1,...,T
	a = rbind( matrix(0, n, nt), -diag(nt), diag(nt))
		a[1 : n0, ] = t(ia$hist.returns) - repmat(colMeans(ia$hist.returns), 1, nt)
	constraints = add.constraints(a, rep(0, nt), '=', constraints)

	# objective : Mean-Absolute Deviation (MAD)
	# 1/T * [ SUM <over j> (u+.j + u-.j) ]
	constraints = add.constraints(c(rep(0, n), (1/nt) * rep(1, 2 * nt)), value, type[1], constraints)

	return( constraints )
}

#' @export
portfolio.mad <- function
(
	weight,		# weight
	ia			# input assumptions
)
{
	if(is.null(dim(weight))) dim(weight) = c(1, len(weight))
	weight = weight[, 1:ia$n, drop=F]

	portfolio.returns = weight %*% t(ia$hist.returns)
	return( apply(portfolio.returns, 1, function(x) mean(abs(x - mean(x))) ) )
}

#' @export
min.mad.portfolio <- function
(
	ia,				# input assumptions
	constraints		# constraints
)
{
	min.portfolio(ia, constraints, add.constraint.mad, portfolio.mad)
}

###############################################################################
# Conditional Value at Risk (CVaR)
# page 30-32, Comparative Analysis of Linear Portfolio Rebalancing Strategies by Krokhmal, Uryasev, Zrazhevsky
#
# Let x.i , i= 1,...,n  be weights of instruments in the portfolio.
# Let us suppose that j = 1,...,T scenarios of returns are available
# ( r.ij denotes return of i -th asset in the scenario j ).
#
# The Conditional Value at Risk (CVaR) function has the form
#  E + 1/(1-a) * 1/T * [ SUM <over j> w.j ]
#  -E - [ SUM <over i> r.ij * x.i ] < w.j, for each j = 1,...,T
#  w.j >= 0, for each j = 1,...,T
#' @export
###############################################################################
add.constraint.cvar <- function
(
	ia,			# input assumptions
	value,		# b value
	type = c('=', '>=', '<='),	# type of constraints
	constraints	# constraints structure
)
{
	if(is.null(ia$parameters.alpha)) alpha = 0.95 else alpha = ia$parameters.alpha

	n0 = ncol(ia$hist.returns)
	n = nrow(constraints$A)
	nt = nrow(ia$hist.returns)

	# adjust constraints, add w.j, E
	constraints = add.variables(nt + 1, constraints, lb = c(rep(0,nt),-Inf))

	#  -E - [ SUM <over i> r.ij * x.i ] < w.j, for each j = 1,...,T
	a = rbind( matrix(0, n, nt), diag(nt), 1)
		a[1 : n0, ] = t(ia$hist.returns)
	constraints = add.constraints(a, rep(0, nt), '>=', constraints)

	# objective : Conditional Value at Risk (CVaR)
	#  E + 1/(1-a) * 1/T * [ SUM <over j> w.j ]
	constraints = add.constraints(c(rep(0, n), (1/(1-alpha))* (1/nt) * rep(1, nt), 1), value, type[1], constraints)

	return( constraints )
}

# average of portfolio returns that are below portfolio's VaR
#' @export
portfolio.cvar <- function
(
	weight,		# weight
	ia			# input assumptions
)
{
	weight = weight[, 1:ia$n, drop=F]
	if(is.null(ia$parameters.alpha)) alpha = 0.95 else alpha = ia$parameters.alpha

	portfolio.returns = weight %*% t(ia$hist.returns)
	return( apply(portfolio.returns, 1, function(x) -compute.cvar(x, 1-alpha) ) )
}

#' @export
min.cvar.portfolio <- function
(
	ia,				# input assumptions
	constraints		# constraints
)
{
	min.portfolio(ia, constraints, add.constraint.cvar, portfolio.cvar)
}

###############################################################################
# portfolio.var
#' @export
###############################################################################
portfolio.var <- function
(
	weight,		# weight
	ia			# input assumptions
)
{
	weight = weight[, 1:ia$n, drop=F]
	if(is.null(ia$parameters.alpha)) alpha = 0.95 else alpha = ia$parameters.alpha

	portfolio.returns = weight %*% t(ia$hist.returns)
	return( apply(portfolio.returns, 1, function(x) -compute.var(x, 1-alpha) ) )
}

###############################################################################
# compute.var/cvar - What is the most I can with a 95% level of confidence expect to lose
# http://www.investopedia.com/articles/04/092904.asp
###############################################################################
#compute.var <- function(x, alpha){ return( -quantile(x, probs = (1-alpha)) )}
#compute.cvar <- function(x, alpha) { return( -mean(x[ x < quantile(x, probs = (1-alpha)) ]) )}

###############################################################################
# Conditional Drawdown at Risk (CDaR)
# page 33, Comparative Analysis of Linear Portfolio Rebalancing Strategies by Krokhmal, Uryasev, Zrazhevsky
# page 15-20, Portfolio Optimization Using Conditional Value-At-Risk and Conditional Drawdown-At-Risk by Enn Kuutan
#
# Let x.i , i= 1,...,n  be weights of instruments in the portfolio.
# Let us suppose that j = 1,...,T scenarios of returns are available
# ( r.ij denotes return of i -th asset in the scenario j ).
#
# The Conditional Drawdown at Risk (CDaR) function has the form
#  E + 1/(1-a) * 1/T * [ SUM <over j> w.j ]
#  u.j - [ SUM <over i> [ SUM <over j> r.ij ] * x.i ] - E < w.j, for each j = 1,...,T
#  [ SUM <over i> [ SUM <over j> r.ij ] * x.i ] < u.j, for each j = 1,...,T
#  u.j-1 < u.j, for each j = 1,...,T - portfolio high water mark
#  w.j >= 0, for each j = 1,...,T
#
# Please note that MaxDD and AvgDD are special cases of CDaR i.e.
# MaxDD is CDaR with alpha = 1
# AvgDD is CDaR with alpha = 0
# DRAWDOWN MEASURE IN PORTFOLIO OPTIMIZATION, ALEXEI CHEKHLOV, STANISLAV URYASEV, MICHAEL ZABARANKIN
# Proposition 3.4, page 25(13)
# http://www.math.columbia.edu/~chekhlov/IJTheoreticalAppliedFinance.8.1.2005.pdf
#
#' @export
###############################################################################
add.constraint.cdar <- function
(
	ia,			# input assumptions
	value,		# b value
	type = c('=', '>=', '<='),	# type of constraints
	constraints	# constraints structure
)
{
	if(is.null(ia$parameters.alpha)) alpha = 0.95 else alpha = ia$parameters.alpha

	n0 = ncol(ia$hist.returns)
	n = nrow(constraints$A)
	nt = nrow(ia$hist.returns)

	# adjust constraints, add w.j, E, u.j
	constraints = add.variables(2*nt + 1, constraints, lb = c(rep(0,nt), rep(-Inf,nt+1)))

	#  u.j - [ SUM <over i> [ SUM <over j> r.ij ] * x.i ] - E < w.j, for each j = 1,...,T
	a = rbind( matrix(0, n, nt), diag(nt), 1, -diag(nt))
		a[1 : n0, ] = t(apply( t(ia$hist.returns), 1, cumsum))
	constraints = add.constraints(a, rep(0, nt), '>=', constraints)

	#  [ SUM <over i> [ SUM <over j> r.ij ] * x.i ] < u.j, for each j = 1,...,T
	a = rbind( matrix(0, n, nt), 0*diag(nt), 0, diag(nt))
		a[1 : n0, ] = -t(apply( t(ia$hist.returns), 1, cumsum))
	constraints = add.constraints(a, rep(0, nt), '>=', constraints)

	#  u.j-1 < u.j, for each j = 1,...,T - portfolio high water mark is increasing
	temp = diag(nt);
		temp[-nt,-1]=-diag((nt-1))
		diag(temp) = 1
	a = rbind( matrix(0, n, nt), 0*diag(nt), 0, temp)
		a = a[,-1]
	constraints = add.constraints(a, rep(0, (nt-1)), '>=', constraints)

	# objective : Conditional Drawdown at Risk (CDaR)
	#  E + 1/(1-a) * 1/T * [ SUM <over j> w.j ]
	constraints = add.constraints(c(rep(0, n), (1/(1-alpha))* (1/nt) * rep(1, nt), 1, rep(0, nt)), value, type[1], constraints)

	return( constraints )
}

#' @export
portfolio.cdar <- function
(
	weight,		# weight
	ia			# input assumptions
)
{
	weight = weight[, 1:ia$n, drop=F]
	if(is.null(ia$parameters.alpha)) alpha = 0.95 else alpha = ia$parameters.alpha

	portfolio.returns = weight %*% t(ia$hist.returns)
	# use CVaR formula
	return( apply(portfolio.returns, 1,
			function(x) {
				x = cumsum(x)
				x = x - cummax(x)
				-compute.cvar(x, 1-alpha)
			}
		))

}

#' @export
min.cdar.portfolio <- function
(
	ia,				# input assumptions
	constraints		# constraints
)
{
	min.portfolio(ia, constraints, add.constraint.cdar, portfolio.cdar)
}

###############################################################################
# Compute CDaR based on data
#' @export
###############################################################################
portfolio.cdar.real <- function
(
	weight,		# weight
	ia			# input assumptions
)
{
	weight = weight[, 1:ia$n, drop=F]
	if(is.null(ia$parameters.alpha)) alpha = 0.95 else alpha = ia$parameters.alpha

	portfolio.returns = weight %*% t(ia$hist.returns)
	out = rep(0, nrow(weight))

	for( i in 1:nrow(weight) ) {
		portfolio.equity = cumprod(1 + portfolio.returns[i,])
		x = compute.drawdowns(portfolio.equity)

		# use CVaR formula
		out[i] = compute.cvar(x, alpha)
	}

	return( out )
}

###############################################################################
# Compute Portfolio Drawdowns
#' @export
###############################################################################
compute.drawdowns <- function( portfolio.equity, make.plot = FALSE )
{
	temp = portfolio.equity / cummax(portfolio.equity) - 1
	temp = c(temp, 0)

	drawdown.start = which( temp == 0 & mlag(temp, -1) != 0 )
	drawdown.end = which( temp == 0 & mlag(temp, 1) != 0 )

	if(make.plot) {
		plot((1:len(temp)), temp, type='l')
			points((1:len(temp))[drawdown.start] , temp[drawdown.start], col='red')
			points((1:len(temp))[drawdown.end] , temp[drawdown.end], col='blue')
	}

	return( apply(cbind(drawdown.start, drawdown.end), 1,
					function(x){ min(temp[ x[1]:x[2] ], na.rm=T)} )
		)
}

###############################################################################
# Find portfolio that Minimizes Average Correlation
# Rdonlp2 only works with R version before 2.9
# Rdonlp2 is not avilable for latest version of R
# for more help please visit http://arumat.net/Rdonlp2/
#
# Conditions of use:
# 1. donlp2 is under the exclusive copyright of P. Spellucci
#    (e-mail:spellucci@mathematik.tu-darmstadt.de)
#    "donlp2" is a reserved name
# 2. donlp2 and its constituent parts come with no warranty, whether ex-
#    pressed or implied, that it is free of errors or suitable for any
#    specific purpose.
#    It must not be used to solve any problem, whose incorrect solution
#    could result in injury to a person , institution or property.
#    It is at the users own risk to use donlp2 or parts of it and the
#    author disclaims all liability for such use.
# 3. donlp2 is distributed "as is". In particular, no maintenance, support
#    or trouble-shooting or subsequent upgrade is implied.
# 4. The use of donlp2 must be acknowledged, in any publication which contains
#    results obtained with it or parts of it. Citation of the authors name
#    and netlib-source is suitable.
# 5. The free use of donlp2 and parts of it is restricted for research purposes
#    commercial uses require permission and licensing from P. Spellucci.
#' @export
###############################################################################
min.avgcor.portfolio <- function
(
	ia,				# input assumptions
	constraints		# constraints
)
{
	cov = ia$cov[1:ia$n, 1:ia$n]
	s = sqrt(diag(cov))

	# avgcor
	fn <- function(x){
		sd_x = sqrt( t(x) %*% cov %*% x )
		mean( ( x %*% cov ) / ( s * sd_x ) )
	}

	x = optimize.portfolio.nlp(ia, constraints, fn)

	return( x )
}

#' @export
portfolio.avgcor <- function
(
	weight,		# weight
	ia			# input assumptions
)
{
	weight = weight[, 1:ia$n, drop=F]
	cov = ia$cov[1:ia$n, 1:ia$n]
	s = sqrt(diag(cov))

	return( apply(weight, 1, function(x) {
								sd_x = sqrt( t(x) %*% cov %*% x )
								mean( ( x %*% cov ) / ( s * sd_x ) )
							})	)
}

###############################################################################
# Use Correlation instead of Variance in Find Minimum Risk Portfolio
# (i.e. assume all assets have same risk = 1)
#' @export
###############################################################################
min.cor.insteadof.cov.portfolio <- function
(
	ia,				# input assumptions
	constraints		# constraints
)
{
	if(is.null(ia$cov.temp)) ia$cov.temp = ia$cov

	sol = solve.QP.bounds(Dmat = ia$correlation, dvec = rep(0, nrow(ia$cov.temp)) ,
		Amat=constraints$A, bvec=constraints$b, constraints$meq,
		lb = constraints$lb, ub = constraints$ub)
	return( sol$solution )
}

###############################################################################
# portfolio.avgcor - average correlation
#' @export
###############################################################################
portfolio.avgcor.real <- function
(
	weight,		# weight
	ia			# input assumptions
)
{
	weight = weight[, 1:ia$n, drop=F]

	portfolio.returns = weight %*% t(ia$hist.returns)

	return( apply(portfolio.returns, 1, function(x) mean(cor(ia$hist.returns, x)) ) )
}

###############################################################################
# Mean-Lower-Semi-Absolute Deviation (M-LSAD)
# page 6, Portfolio Optimization under Lower Partial Risk Measure by H. Konno, H. Waki and A. Yuuki
# http://www.kier.kyoto-u.ac.jp/fe-tokyo/workingpapers/AFE-KyotoU_WP01-e.html
#
# Let x.i , i= 1,...,n  be weights of instruments in the portfolio.
# Let us suppose that j = 1,...,T scenarios of returns are available
# ( r.ij denotes return of i -th asset in the scenario j ).
#
# Mean-Lower-Semi-Absolute Deviation (M-LSAD) function has the form
#  1/T * [ SUM <over j> z.j ]
#  such that
#  - [ SUM <over i> (r.ij - r.i) * x.i ] <= z.j , for each j = 1,...,T
#  z.j >= 0, for each j = 1,...,T
#' @export
###############################################################################
add.constraint.mad.downside <- function
(
	ia,			# input assumptions
	value,		# b value
	type = c('=', '>=', '<='),	# type of constraints
	constraints	# constraints structure
)
{
	n0 = ncol(ia$hist.returns)
	n = nrow(constraints$A)
	nt = nrow(ia$hist.returns)

	# adjust constraints, add z.j
	constraints = add.variables(nt, constraints, lb = 0)

	#  - [ SUM <over i> (r.ij - r.i) * x.i ] <= z.j , for each j = 1,...,T
	a = rbind( matrix(0, n, nt), diag(nt))
	if(is.null(ia$parameters.mar) || is.na(ia$parameters.mar)) {
		a[1 : n0, ] = t(ia$hist.returns) - repmat(colMeans(ia$hist.returns), 1, nt)
		constraints = add.constraints(a, rep(0, nt), '>=', constraints)
	} else {
		#  MAR - [ SUM <over i> r.ij * x.i ] <= z.j , for each j = 1,...,T
		a[1 : n0, ] = t(ia$hist.returns)
		constraints = add.constraints(a, rep(ia$parameters.mar, nt), '>=', constraints)
	}

	# objective : Mean-Lower-Semi-Absolute Deviation (M-LSAD)
	#  1/T * [ SUM <over j> z.j ]
	constraints = add.constraints(c(rep(0, n), (1/nt) * rep(1, nt)), value, type[1], constraints)

	return( constraints )
}

#' @export
portfolio.mad.downside <- function
(
	weight,		# weight
	ia			# input assumptions
)
{
	weight = weight[, 1:ia$n, drop=F]

	portfolio.returns = weight %*% t(ia$hist.returns)

	if(is.null(ia$parameters.mar) || is.na(ia$parameters.mar)) {
		return( apply(portfolio.returns, 1, function(x) mean(pmax(mean(x) - x, 0)) ) )
	} else {
		return( apply(portfolio.returns, 1, function(x) mean(pmax(ia$parameters.mar - x, 0)) ) )
	}
}

#' @export
min.mad.downside.portfolio <- function
(
	ia,				# input assumptions
	constraints		# constraints
)
{
	min.portfolio(ia, constraints, add.constraint.mad.downside, portfolio.mad.downside)
}

###############################################################################
# Mean-Lower Semi-Variance (MV)
# page 6, Portfolio Optimization under Lower Partial Risk Measure by H. Konno, H. Waki and A. Yuuki
# http://www.kier.kyoto-u.ac.jp/fe-tokyo/workingpapers/AFE-KyotoU_WP01-e.html
#
# Same logic as add.constraint.mad.downside, but minimize (z.j)^2
# use quadratic solver
#' @export
###############################################################################
portfolio.risk.downside <- function
(
	weight,		# weight
	ia			# input assumptions
)
{
	weight = weight[, 1:ia$n, drop=F]

	portfolio.returns = weight %*% t(ia$hist.returns)

	if(is.null(ia$parameters.mar) || is.na(ia$parameters.mar)) {
		return( apply(portfolio.returns, 1, function(x) sqrt(mean(pmax(mean(x) - x, 0)^2)) ) )
	} else {
		return( apply(portfolio.returns, 1, function(x) sqrt(mean(pmax(ia$parameters.mar - x, 0)^2)) ) )
	}
}

#' @export
min.risk.downside.portfolio <- function
(
	ia,				# input assumptions
	constraints		# constraints
)
{
	n = nrow(constraints$A)
	nt = nrow(ia$hist.returns)

	# objective is stored as a last constraint
	constraints = add.constraint.mad.downside(ia, 0, '>=', constraints)

	f.obj = constraints$A[, ncol(constraints$A)]
		constraints = delete.constraints( ncol(constraints$A), constraints)

	# setup Dmat
	Dmat = diag( len(f.obj) )
	diag(Dmat) = f.obj
	if(!is.positive.definite(Dmat)) {
		Dmat <- make.positive.definite(Dmat)
	}

	# find optimal solution
	x = NA

	binary.vec = 0
	if(!is.null(constraints$binary.index)) binary.vec = constraints$binary.index

	sol = try(solve.QP.bounds(Dmat = Dmat, dvec = rep(0, nrow(Dmat)) ,
		Amat=constraints$A, bvec=constraints$b, constraints$meq,
		lb = constraints$lb, ub = constraints$ub, binary.vec = binary.vec),TRUE)

	if(!inherits(sol, 'try-error')) {
		x = sol$solution[1:n]

		# to check
		if( F ) {
			sol$solution %*% Dmat %*% (sol$solution) - portfolio.risk.downside(t(x), ia)^2
		}
	}

	return( x )
}

###############################################################################
# Gini mean difference
# The mean difference is also known as the absolute mean difference and the Gini mean difference
# http://en.wikipedia.org/wiki/Mean_difference
#
# The Generation of Mean Gini Efficient Sets by J. Okunev (1991)
# Can be made more efficient by solving for dual
#' @export
###############################################################################
add.constraint.gini <- function
(
	ia,			# input assumptions
	value,		# b value
	type = c('=', '>=', '<='),	# type of constraints
	constraints	# constraints structure
)
{
	n0 = ncol(ia$hist.returns)
	n = nrow(constraints$A)
	nt = nrow(ia$hist.returns)

	# adjust constraints, add a.long, a.short 2 * nt*(nt-1)/2
	constraints = add.variables(nt*(nt-1), constraints, lb=0)

	# [ SUM <over i> x.i * (r.ij - r.ik) ] - a.long.jk + a.short.jk = 0
	# for each j = 1,...,T , k>j
	a = matrix(0, n0 + nt*(nt-1), nt*(nt-1)/2)
		diag(a[(n0+1) : (n0 + nt*(nt-1)/2), ]) = -1
		diag(a[(n0+1+nt*(nt-1)/2) : (n0 + nt*(nt-1)), ]) = 1
	#a = rbind( matrix(0, n, nt*(nt-1)/2), -diag(nt*(nt-1)/2), diag(nt*(nt-1)/2))
	#	a[1 : n0, ] = t(ia$hist.returns)
	hist.returns = as.matrix(ia$hist.returns)

	i.start = 0
	for(t in 1:(nt-1)) {
		index = (i.start+1) : (i.start + nt -t)
		for(i in 1:n0) {
			a[i, index] = ( hist.returns[t,i] - hist.returns[,i] ) [ (t+1) : nt ]
		}
		i.start = i.start + nt -t

	}

	constraints = add.constraints(a, 0, '=', constraints)

	# objective : maximum loss, w
	constraints = add.constraints(c(rep(0, n), rep(1, nt*(nt-1))), value, type[1], constraints)

	return( constraints )
}

#' @export
min.gini.portfolio <- function
(
	ia,				# input assumptions
	constraints		# constraints
)
{
	min.portfolio(ia, constraints, add.constraint.gini, portfolio.gini.coefficient)

}

#' @export
portfolio.gini.coefficient <- function
(
	weight,		# weight
	ia			# input assumptions
)
{
	if(is.null(dim(weight))) dim(weight) = c(1, len(weight))

	weight = weight[, 1:ia$n, drop=F]

	portfolio.returns = weight %*% t(ia$hist.returns)

	n = ncol(portfolio.returns)

#portfolio.returns = rnorm(100)
#n = len(portfolio.returns)
#
# http://en.wikipedia.org/wiki/Mean_difference
#sum(outer(portfolio.returns, portfolio.returns, function(x,y) abs(x-y))) / (n*(n-1))
#
# unmht:///file.5/C:/Desktop/1save/blog_entries/ERC/Gini%20Coefficient%20--%20from%20Wolfram%20MathWorld.mht/
#temp = sort(portfolio.returns, decreasing = F)
#2* sum( (2*(1:n) - n - 1) * temp ) / (n*(n-1) )

	one.to.n = 1:n
	out = weight[,1] * NA
	out[] = apply( portfolio.returns, 1, function(x) {
		temp = sort(x, decreasing = F)
		sum( (2*one.to.n - n - 1) * temp )
		} )
	out = 2 * out /(n*(n-1))
	return(out)
}

###############################################################################
# Solve LP Portfolio Problem
#' @export
###############################################################################
lp.obj.portfolio <- function
(
	ia,				# input assumptions
	constraints,	# constraints
	f.obj = c(ia$expected.return, rep(0, nrow(constraints$A) - ia$n)),
	direction = 'min'
)
{
	x = NA

	binary.vec = 0
	if(!is.null(constraints$binary.index)) binary.vec = constraints$binary.index

	sol = try(solve.LP.bounds(direction, f.obj,
		t(constraints$A),
		c(rep('=', constraints$meq), rep('>=', len(constraints$b) - constraints$meq)),
		constraints$b, lb = constraints$lb, ub = constraints$ub, binary.vec = binary.vec), TRUE)

	if(!inherits(sol, 'try-error')) {
		x = sol$solution
	}

	return( x )
}

###############################################################################
# Find Maximum Return Portfolio
###############################################################################
# maximize     C x
# subject to   A x <= B
#' @export
###############################################################################
max.return.portfolio <- function
(
	ia,				# input assumptions
	constraints		# constraints
)
{
	lp.obj.portfolio(ia, constraints, direction = 'max')
}

###############################################################################
# portfolio.return - weight * expected.return
#' @export
###############################################################################
portfolio.return <- function
(
	weight,		# weight
	ia			# input assumptions
)
{
	if(is.null(dim(weight))) dim(weight) = c(1, len(weight))

	weight = weight[, 1:ia$n, drop=F]
	portfolio.return = weight %*% ia$expected.return
	return( portfolio.return )
}

###############################################################################
# portfolio.geometric.return
#' @export
###############################################################################
portfolio.geometric.return <- function
(
	weight,		# weight
	ia			# input assumptions
)
{
	weight = weight[, 1:ia$n, drop=F]

	portfolio.returns = weight %*% t(ia$hist.returns)
	return( apply(portfolio.returns, 1, function(x) (prod(1+x)^(1/len(x)))^ia$annual.factor - 1 ) )
}

###############################################################################
# Find Maximum Geometric Return Portfolio
#' @export
###############################################################################
max.geometric.return.portfolio <- function
(
	ia,				# input assumptions
	constraints,	# constraints
	min.risk,
	max.risk
)
{
	# Geometric return
	fn <- function(x){
		portfolio.returns = x %*% t(ia$hist.returns)
		prod(1 + portfolio.returns)
	}

	# Nonlinear constraints
	nlcon1 <- function(x){
		sqrt(t(x) %*% ia$cov %*% x)
	}

	nl.constraints = list()
		nl.constraints$constraints = list(nlcon1)
		nl.constraints$upper = c(max.risk)
		nl.constraints$lower = c(min.risk)

	x = optimize.portfolio.nlp(ia, constraints, fn, nl.constraints, direction = 'max')

	return( x )
}

###############################################################################
# portfolio.unrebalanced.return
# http://www.effisols.com/mvoplus/sample1.htm
#' @export
###############################################################################
portfolio.unrebalanced.return <- function
(
	weight,		# weight
	ia			# input assumptions
)
{
	weight = weight[, 1:ia$n, drop=F]

	total.return = apply(1+ia$hist.returns,2,prod)
	total.portfolio.return = weight %*% total.return / rowSums(weight)
	total.portfolio.return = (total.portfolio.return^(1/nrow(ia$hist.returns)))^ia$annual.factor - 1
	return( total.portfolio.return )
}

###############################################################################
# Functions to convert between Arithmetic and Geometric means
###############################################################################
# page 8, DIVERSIFICATION, REBALANCING, AND THE GEOMETRIC MEAN FRONTIER by W. Bernstein and D. Wilkinson (1997)
#' @export
###############################################################################
geom2aritm <- function(G, V, a, b)
{
	(2*G + a*V^2) / (1 - b*G + sqrt((1+b*G)^2 + 2*a*b*V^2))
}

#' @export
aritm2geom <- function(R, V, a, b)
{
	R - a*V^2 / (2*(1 + b*R))
}

###############################################################################
# page 14, A4, On the Relationship between Arithmetic and Geometric Returns by D. Mindlin
#' @export
###############################################################################
geom2aritm4 <- function(G, V)
{
	(1+G)*sqrt(1/2 + 1/2*sqrt(1 + 4*V^2/(1+G)^2)) - 1
}

#' @export
aritm2geom4 <- function(R, V)
{
	(1+R)/(sqrt(1 + V^2/(1+R)^2)) - 1
}

###############################################################################
# Find Portfolio with Minimum Risk and given Target Return
#' @export
###############################################################################
target.return.portfolio.helper <- function
(
	ia,				# input assumptions
	constraints,	# constraints
	target.return
)
{
	constraints.target = add.constraints(ia$expected.return, type='>=', b=target.return, constraints)
	sol = try(min.var.portfolio(ia, constraints.target), silent = TRUE)

	if(inherits(sol, 'try-error'))
		sol = max.return.portfolio(ia, constraints)

	sol
}

#' @export
target.return.portfolio <- function
(
	target.return,
	annual.factor = 252
)
{
	target.return = as.double(target.return[1])
	if(target.return > 1) target.return = target.return / 100
	target.return = target.return / annual.factor

	function
	(
		ia,			# input assumptions
		constraints	# constraints
	)
	{
		target.return.portfolio.helper(ia, constraints, target.return)
	}
}

###############################################################################
# Find Portfolio with Minimum Risk and given Target Risk
#' @export
###############################################################################
target.risk.portfolio.helper <- function
(
	ia,				# input assumptions
	constraints,	# constraints
	target.risk,
	silent = T,
	min.w = NA,
	max.w = NA
)
{
	if( is.na(max.w) ) max.w = max.return.portfolio(ia, constraints)
	if( is.na(min.w) ) min.w = min.var.portfolio(ia, constraints)

	max.r = portfolio.return(max.w, ia)
	min.r = portfolio.return(min.w, ia)

	max.s = portfolio.risk(max.w, ia)
	min.s = portfolio.risk(min.w, ia)

	if( target.risk >= min.s & target.risk <= max.s ) {
		# function to compute risk given return x
		f <- function (x, ia, constraints, target.risk) {
			portfolio.risk(target.return.portfolio.helper(ia, constraints, x), ia) - target.risk
		}

		f.lower = min.s - target.risk
		f.upper = max.s - target.risk

		sol = uniroot(f, c(min.r, max.r), f.lower=f.lower, f.upper=f.upper, tol = 0.0001,
			ia=ia, constraints=constraints, target.risk=target.risk)
		if(!silent) cat('Found solution in', sol$iter, 'itterations', '\n')
		return( target.return.portfolio.helper(ia, constraints, sol$root) )
	} else if( target.risk < min.s ) {
		return( min.w )
	} else {
		return( max.w )
	}

	stop(paste('target.risk =', target.risk, 'is not possible, max risk =', max.s, ', min risk =', min.s))
}

#' @export
target.risk.portfolio <- function
(
	target.risk,
	annual.factor = 252
)
{
	target.risk = as.double(target.risk[1])
	if(target.risk > 1) target.risk = target.risk / 100
	target.risk = target.risk / sqrt(annual.factor)

	function
	(
		ia,			# input assumptions
		constraints	# constraints
	)
	{
		target.risk.portfolio.helper(ia, constraints, target.risk)
	}
}

###############################################################################
# Find Minimum Risk Portfolio
###############################################################################
# solve.QP function from quadprog library
# min(-d^T w.i + 1/2 w.i^T D w.i) constraints A^T w.i >= b_0
#' @export
###############################################################################
min.risk.portfolio <- function
(
	ia,				# input assumptions
	constraints		# constraints
)
{
	x = NA

	binary.vec = 0
	if(!is.null(constraints$binary.index)) binary.vec = constraints$binary.index

	if(is.null(ia$cov.temp)) ia$cov.temp = ia$cov

	sol = try(solve.QP.bounds(Dmat = ia$cov.temp, dvec = rep(0, nrow(ia$cov.temp)) ,
		Amat=constraints$A, bvec=constraints$b, constraints$meq,
		lb = constraints$lb, ub = constraints$ub, binary.vec = binary.vec),TRUE)

	if(!inherits(sol, 'try-error')) {
		if(binary.vec[1] != 0) cat(sol$counter,'QP calls made to solve problem with', len(constraints$binary.index), 'binary variables using Branch&Bound', '\n')

		x = sol$solution;
	}

	return( x )
}

###############################################################################
# portfolio.risk - square root of portfolio volatility
#' @export
###############################################################################
portfolio.risk <- function
(
	weight,		# weight
	ia			# input assumptions
)
{
	if(is.null(dim(weight))) dim(weight) = c(1, len(weight))

	weight = weight[, 1:ia$n, drop=F]
	cov = ia$cov[1:ia$n, 1:ia$n]

	return( apply(weight, 1, function(x) sqrt(t(x) %*% cov %*% x)) )
}

###############################################################################
# Find Equal-Risk-Contribution (ERC) Portfolio
#
# Unproxying weight constraints by Pat Burns
# http://www.portfolioprobe.com/2011/04/13/unproxying-weight-constraints/
#
# Analytical Solution for the Equal-Risk-Contribution Portfolio
# http://www.wilmott.com/messageview.cfm?catid=34&threadid=38497
#
# Equally-weighted risk contributions: a new method to build risk balanced diversified portfolios by S. Maillard, T. Roncalli and J. Teiletche (2008)
# http://www.thierry-roncalli.com/download/erc-slides.pdf
#
# On the property of equally-weighted risk contributions portfolios by S. Maillard, T. Roncalli and J. Teiletche (2008)
# http://www.thierry-roncalli.com/download/erc.pdf
#
# Matlab code for Equal Risk Contribution Portfolio by Farid Moussaoui
# http://mfquant.net/erc_portfolio.html
#' @export
###############################################################################
find.erc.portfolio <- function
(
	ia,				# input assumptions
	constraints		# constraints
)
{
	cov = ia$cov[1:ia$n, 1:ia$n]

	# obj
	fn <- function(x){
		risk.contribution = (x * (cov %*% x))
		sum( abs(risk.contribution - mean(risk.contribution)) )
	}

	x = optimize.portfolio.nlp(ia, constraints, fn)

	return( x )
}

#' @export
find.erc.portfolio.simple <- function
(
	ia,				# input assumptions
	constraints		# constraints
)
{
	cov = ia$cov[1:ia$n, 1:ia$n]

	# obj
	fn <- function(x){
		# sum(x) = 1
		if (sum(x) == 0) x = x + 1e-2
		x  = x / sum(x)

		risk.contribution = (x * (cov %*% x))
		var(as.double(risk.contribution))
	}

	x0 = 1/sqrt(diag(cov))
		x0 = x0 / sum(x0)

	x = nlminb(start = x0, objective = fn, lower = constraints$lb, upper = constraints$ub)

	x$par = x$par / sum(x$par)
	return(x$par)
}

find.erc.portfolio.test <- function() {
	#--------------------------------------------------------------------------
	# Create Efficient Frontier
	#--------------------------------------------------------------------------
	ia = aa.test.create.ia.rebal()
	n = ia$n

	#--------------------------------------------------------------------------
	# Construct ERC Equal-Risk Portfolio
	#--------------------------------------------------------------------------
	x0 = 1/sqrt(diag(ia$cov))
		temp = x0 / sum(x0)
	rc.temp = portfolio.risk.contribution(temp, ia)
		rc.temp = abs(as.vector(rc.temp))
	plot(rc.temp,ylim=c(0,0.4))

	diff(range(rc.temp))
	sd(rc.temp)

	#--------------------------------------------------------------------------
	# Create constraints
	#--------------------------------------------------------------------------
	# 0 <= x.i <= 1
	constraints = new.constraints(n, lb = 0, ub = 1)

	# SUM x.i = 1
	constraints = add.constraints(rep(1, n), 1, type = '=', constraints)

	#--------------------------------------------------------------------------
	# Construct ERC Equal-Risk-Contribution Portfolio
	#--------------------------------------------------------------------------
	temp = find.erc.portfolio(ia, constraints)
	rc.temp = portfolio.risk.contribution(temp, ia)
		rc.temp = abs(as.vector(rc.temp))
	plot(rc.temp,ylim=c(0,0.4))

	diff(range(rc.temp))
	sd(rc.temp)

	#--------------------------------------------------------------------------
	# Construct ERC Equal-Risk-Contribution Portfolio
	#--------------------------------------------------------------------------
	temp = find.erc.portfolio.simple(ia, constraints)
		temp = temp / sum(temp)
	rc.temp = portfolio.risk.contribution(temp, ia)
		rc.temp = abs(as.vector(rc.temp))
	plot(rc.temp,ylim=c(0,0.4))

	diff(range(rc.temp))
	sd(rc.temp)

	#--------------------------------------------------------------------------
	# Construct ERC Equal-Risk-Contribution Portfolio
	#--------------------------------------------------------------------------
	temp = equal.risk.contribution.portfolio(ia, constraints)
		temp = temp / sum(temp)
	rc.temp = portfolio.risk.contribution(temp, ia)
		rc.temp = abs(as.vector(rc.temp))
	plot(rc.temp,ylim=c(0,0.4))

	diff(range(rc.temp))
	sd(rc.temp)

}

###############################################################################
# portfolio.risk.contribution - (w * V %*% w) / (w %*% V %*% w)
# Unproxying weight constraints by Pat Burns
# http://www.portfolioprobe.com/2011/04/13/unproxying-weight-constraints/
#' @export
###############################################################################
portfolio.risk.contribution <- function
(
	weight,		# weight
	ia			# input assumptions
)
{
	if(is.null(dim(weight))) dim(weight) = c(1, len(weight))

	weight = weight[, 1:ia$n, drop=F]
	cov = ia$cov[1:ia$n, 1:ia$n]

	out = weight
	out[] = t(apply( weight, 1, function(x) (x * (cov %*% x)) / (t(x) %*% cov %*% x)[1] ))
	return(out)
}

###############################################################################
# Create efficient frontier
#' @export
###############################################################################
portopt <- function
(
	ia,						# Input Assumptions
	constraints = NULL,		# Constraints
	nportfolios = 50,		# Number of portfolios
	name = 'Risk',			# Name
	min.risk.fn = min.risk.portfolio,	# Risk Measure
	equally.spaced.risk = F	# Add extra portfolios so that portfolios on efficient frontier
							# are equally spaced on risk axis
)
{
	# load / check required packages
	load.packages('quadprog,corpcor,lpSolve,kernlab')

	# set up constraints
	if( is.null(constraints) ) {
		constraints = new.constraints(rep(0, ia$n), 0, type = '>=')
	}

	# set up solve.QP
	ia$risk = iif(ia$risk == 0, 0.000001, ia$risk)
	if( is.null(ia$cov) ) ia$cov = ia$correlation * (ia$risk %*% t(ia$risk))

	# setup covariance matrix used in solve.QP
	ia$cov.temp = ia$cov

	# check if there are dummy variables
	n0 = ia$n
	n = nrow(constraints$A)

	if( n != nrow(ia$cov.temp) ) {
		temp =  matrix(0, n, n)
		temp[1:n0, 1:n0] = ia$cov.temp[1:n0, 1:n0]
		ia$cov.temp = temp
	}

	if(!is.positive.definite(ia$cov.temp, method = 'chol')) {
		ia$cov.temp <- make.positive.definite(ia$cov.temp, 0.000000001)
	}

	# set up output
	if(nportfolios<2) nportfolios = 2
	out = list(weight = matrix(NA, nportfolios, nrow(constraints$A)))
		colnames(out$weight) = rep('', ncol(out$weight))
		colnames(out$weight)[1:ia$n] = ia$symbols

	# find maximum return portfolio
	out$weight[nportfolios, ] = max.return.portfolio(ia, constraints)

	# find minimum risk portfolio
	out$weight[1, ] = match.fun(min.risk.fn)(ia, constraints)
		constraints$x0 = out$weight[1, ]

	if(nportfolios > 2) {
		# find points on efficient frontier
		out$return = portfolio.return(out$weight, ia)
		target = seq(out$return[1], out$return[nportfolios], length.out = nportfolios)

		constraints = add.constraints(c(ia$expected.return, rep(0, nrow(constraints$A) - ia$n)),
							target[1], type = '>=', constraints)

		for(i in 2:(nportfolios - 1) ) {
			constraints$b[ len(constraints$b) ] = target[i]
			out$weight[i, ] = match.fun(min.risk.fn)(ia, constraints)
				constraints$x0 = out$weight[i, ]

#cat(i, '\n')

		}

		if( equally.spaced.risk ) {
			out$risk = portfolio.risk(out$weight, ia)

			temp = diff(out$risk)
			index = which(temp >= median(temp) + mad(temp))

			if( len(index) > 0 ) {
				index = min(index)

				proper.spacing = ceiling((out$risk[nportfolios] - out$risk[index])/temp[(index-1)])-1
				nportfolios1 = proper.spacing + 2

				if(nportfolios1 > 2) {
					out$return = portfolio.return(out$weight, ia)
					out$risk = portfolio.risk(out$weight, ia)
					temp = spline(out$risk, out$return, n = nportfolios, method = 'natural')

					target = temp$y[ which(temp$y > out$return[index] & temp$y < out$return[nportfolios] &
						temp$x > out$risk[index] & temp$x < out$risk[nportfolios])]
					target = c(out$return[index], target, out$return[nportfolios])
					nportfolios1 = len(target)

					out1 = list(weight = matrix(NA, nportfolios1, nrow(constraints$A)))
						out1$weight[1, ] = out$weight[index, ]
						out1$weight[nportfolios1, ] = out$weight[nportfolios, ]

					constraints$x0 = out1$weight[1, ]
					for(i in 2:(nportfolios1 - 1) ) {
						constraints$b[ len(constraints$b) ] = target[i]
						out1$weight[i, ] = match.fun(min.risk.fn)(ia, constraints)
							constraints$x0 = out1$weight[i, ]
					}

					out$weight = rbind(out$weight[-c(index:nportfolios),], out1$weight)
				}

			}

		}
	}

	# remove empty solutions
	rm.index = is.na(rowSums(out$weight))
	if(any(rm.index)) out$weight = out$weight[!rm.index,]

	# compute risk / return
	out$return = portfolio.return(out$weight, ia)
	out$risk = portfolio.risk(out$weight, ia)
	out$name = name

	return(out)
}

###############################################################################
# Visualize input assumptions
#' @export
###############################################################################
plot.ia <- function
(
	ia,				# input assumptions
	layout = NULL	# flag to idicate if layout is already set
)
{
	# create a table with summary statistics
	if( is.null(layout) ) layout(matrix(1:2, nr=1))
	temp = cbind(ia$expected.return, ia$risk)
		temp[] = plota.format(100 * temp[], 1, '', '%')
		colnames(temp) = spl('Return,Risk')
	plot.table(temp, 'Symbol')

	# visualize correlation  matrix
	temp = ia$correlation
		temp[lower.tri(temp, TRUE)] = NA
		temp = temp[-ia$n, -1]
		temp[] = plota.format(100 * temp[], 1, '', '%')
	plot.table(temp, highlight = TRUE, colorbar = TRUE)
}

###############################################################################
# Plot efficient fontier(s) and transitopn map
#' @export
###############################################################################
plot.ef <- function
(
	ia,						# input assumption
	efs,					# efficient fontier(s)
	portfolio.risk.fn = portfolio.risk,	# risk measure
	transition.map = TRUE,	# flag to plot transitopn map
	layout = NULL			# flag to idicate if layout is already set
)
{
	# extract name of risk measure
	risk.label = as.character(substitute(portfolio.risk.fn))

	# prepare plot data
	n = ia$n
	x = match.fun(portfolio.risk.fn)(diag(n), ia)
	y = ia$expected.return

	# prepare plot ranges
	xlim = range(c(0, x,
			max( sapply(efs, function(x) max(match.fun(portfolio.risk.fn)(x$weight,ia))) )
			), na.rm = T)

	ylim = range(c(0, y,
			min( sapply(efs, function(x) min(portfolio.return(x$weight,ia))) ),
			max( sapply(efs, function(x) max(portfolio.return(x$weight,ia))) )
			), na.rm = T)

	# convert x and y to percentages
	x = 100 * x
	y = 100 * y
	xlim = 100 * xlim
	ylim = 100 * ylim

	# plot
	if( !transition.map ) layout = T
	if( is.null(layout) ) layout(1:2)

	par(mar = c(4,3,2,1), cex = 0.8)
	plot(x, y, xlim = xlim, ylim = ylim,
		xlab='', ylab='', main=paste(risk.label, 'vs Return'), col='black')
		mtext('Return', side = 2,line = 2, cex = par('cex'))
		mtext(risk.label, side = 1,line = 2, cex = par('cex'))
	grid();
	text(x, y, ia$symbols,	col = 'blue', adj = c(1,1), cex = 0.8)

	# plot fontiers
	for(i in len(efs):1) {
		ef = efs[[ i ]]

		x = 100 * match.fun(portfolio.risk.fn)(ef$weight, ia)
		y = 100 * ef$return

		lines(x, y, col=i)
	}
	plota.legend(sapply(efs, function(x) x$name), 1:len(efs))

	# Transition Map plot
	if(transition.map) {
		plot.transition.map(efs[[i]]$weight, x, risk.label, efs[[i]]$name)
	}
}

# Add portfolios to plot
#' @export
plot.add.portfolios = function(ia, portfolio.risk.fn = portfolio.risk, ...) {
	portfolios = lst(...)

	col = plota.colors(portfolios)

	for(i in 1:len(portfolios))
		points(100 * portfolio.risk.fn(portfolios[[i]],ia), 100 * portfolio.return(portfolios[[i]],ia), pch=15, col=col[i])

	plota.legend(names(portfolios), col, x='bottomright')
}

###############################################################################
# Plot Transition Map
#' @export
###############################################################################
plot.transitopn.map <- function(x,y,xlab = 'Risk',name = '',type=c('s','l')) {
	plot.transition.map(x,y,xlab,name,type)
}

#' @export
plot.transition.map <- function
(
	y,				# weights
	x,				# x data
	xlab = 'Risk',	# x label
	name = '',		# name
	type=c('s','l'),# type
	col = NA		# colors

)
{
	if( is.list(y) ) {
		name = y$name
		x = 100 * y$risk
		y = y$weight
	}

	y[is.na(y)] = 0

	par(mar = c(4,3,2,1), cex = 0.8)
	plota.stacked(x, y, xlab = xlab, main = paste('Transition Map for', name),
		type=type[1], col=ifna(col, plota.colors(ncol(y))) )
}

###############################################################################
# Helper functions from the following paper:
# On the property of equally-weighted risk contributions portfolios by S. Maillard,
# T. Roncalli and J. Teiletche (2008), page 22
# http://www.thierry-roncalli.com/download/erc.pdf
#' @export
###############################################################################
portfolio.turnover <- function
(
	weight		# weight
)
{
	if(is.null(dim(weight))) dim(weight) = c(1, len(weight))

	out = weight[,1] * NA
	out[] = rowSums( abs(weight - mlag(weight)) ) / 2
	return(out)
}

# Herfindahl Index of portfolio weights
# http://en.wikipedia.org/wiki/Herfindahl_index
#' @export
portfolio.concentration.herfindahl.index <- function
(
	weight		# weight
)
{
	if(is.null(dim(weight))) dim(weight) = c(1, len(weight))

	one.over.n = 1/ rowSums(!is.na(weight))
	out = weight[,1] * NA
	out[] = (rowSums(weight^2, na.rm=T) - one.over.n) / (1 - one.over.n)
	return(out)

	one.over.n = 1/ncol(weight)
	out = weight[,1] * NA
	out[] = (rowSums(weight^2) - one.over.n) / (1 - one.over.n)
	return(out)
}

# Gini Coefficient of portfolio weights
# Gini is designed to work with positive numbers!!!
# http://en.wikipedia.org/wiki/Gini_coefficient
# http://en.wikipedia.org/wiki/Mean_difference
#' @export
portfolio.concentration.gini.coefficient <- function
(
	weight		# weight
)
{
	if(is.null(dim(weight))) dim(weight) = c(1, len(weight))

	n = ncol(weight)

	# The mean difference formula
	# weight = rep(1/n,n)
	# 1/2 * (sum(outer(weight, weight, function(x,y) abs(x-y))) / (n*(n-1))) / sum(abs(weight)/n)

	# Gini formula by Angus Deaton, more efficient
	#(n+1)/(n-1) - 2 * sum(weight * rank(-weight)) /(n*(n-1)* mean(weight))
	#(n+1)/(n-1) - 2 * sum(abs(weight) * rank(-abs(weight))) /(n*(n-1)* sum(abs(weight)/n))

	# same formula, but faster
	#temp = sort(weight, decreasing = T)
	#(n+1)/(n-1) - 2 * sum(temp * (1:n)) /(n*(n-1)* mean(temp))

	one.to.n = 1:n
	out = weight[,1] * NA

	for(i in 1:nrow(weight)) {
		x = coredata(weight[i,])
		index = !is.na(x)
		n1 = sum(index)
		if( n1 > 0 ) {
			temp = sort(x[index], decreasing = T)

			# make sure all weights are positive
			if(temp[n1] < 0) temp = temp - temp[n1]

			out[i] = (n1+1)/(n1-1) - 2 * sum(temp * one.to.n[1:n1]) /(n1*(n1-1)* sum(temp) / n1)
		}
	}
	return(out)

	out[] = apply( weight, 1, function(x) {
		temp = sort(x, decreasing = T)
		sum(temp * one.to.n)
		} )
	out = (n+1)/(n-1) - 2 * out /(n*(n-1)* apply(weight, 1, mean))
	return(out)
}


#####################################################################################################
#
# Mark Cembrowski, Janelia Research Campus, April 25 2015
#
# This script plots a scatter of count values.
#
# It is analogous to the fpkmScatter approach used for FPKM data.
#
# OPTIONAL ARGUMENTS:
# cpm=T: logical.  Use counts per million (default) or raw counts?
# quiet=T: logical. If F, print out correlation coefficient and number of DE genes.
#
#####################################################################################################

geneScatter <- function(sampleX,sampleY,fdr=0.05,doFpkm=T,maxX=-1,minX=-1,minY=-1,maxY=-1,cpm=T,
			label=F,colour=c('green'),gsnList=c(),quiet=T){

	# Check if supplied a replicate, which means suffix will be _X, where
	# X is an integer.
	suff1 <- substr(sampleX,nchar(sampleX)-1,nchar(sampleX)-1)
	suff2 <- substr(sampleX,nchar(sampleX),nchar(sampleX))

	if( (suff1=="_") && (!is.na(suppressWarnings(as.numeric(suff2)))) ){
		doRep <- T
		print('Detected a replicate sample.')
	}else{
		doRep <- F
	}

	# Retrieve values for visualisation and analysis.
	if(doFpkm){
		ids <- rownames(fpkmPoolMat) #same for rep or pool
		if(doRep){
			xVals <- fpkmRepMat[,sampleX]+1
			yVals <- fpkmRepMat[,sampleY]+1
		}else{
			xVals <- fpkmPoolMat[,sampleX]+1 # additive smoothing
			yVals <- fpkmPoolMat[,sampleY]+1 # additive smoothing
		}
	}else{
		ids <- rownames(cpmPoolMat) # same for rep or pool; cpm or count
		if(cpm){
			if(doRep){
				xVals <- cpmRepMat[,sampleX]+1
				yVals <- cpmRepMat[,sampleY]+1
			}else{
				xVals <- cpmPoolMat[,sampleX]+1 # additive smoothing
				yVals <- cpmPoolMat[,sampleY]+1 # additive smoothing
			}
		}else{
			if(doRep){
				xVals <- countRepMat[,sampleX]+1
				yVals <- countRepMat[,sampleY]+1
			}else{
				xVals <- countPoolMat[,sampleX]+1 # additive smoothing
				yVals <- countPoolMat[,sampleY]+1 # additive smoothing
			}
		}
	}

	# Get DE'ed genes.
	if(length(gsnList)<0.1){
		if(doFpkm){
			isDe <- vector(length=nrow(fpkmPoolMat))>0.1
			if(!doRep){
				names(isDe) <- rownames(fpkmPoolMat)
				theDe <- getSig(cuff_data,sampleX,sampleY,alpha=fdr,level='genes')
				isDe[theDe] <- T
			}
		}else{
			if(!doRep){
				toKeep <- grepl(paste(c(sampleX,sampleY),collapse='|'),colnames(countRepMat))
				subMat <- countRepMat[,toKeep]

				toKeep <- grepl(paste(c(sampleX,sampleY),collapse='|'),countRepData$condition)
				subCol <- countRepData[toKeep,]
				subCol$condition <- droplevels(subCol$condition)

				dds <- DESeqDataSetFromMatrix(countData=subMat,colData=subCol,design=~condition)

				dds <- DESeq(dds)
				res <- results(dds)

				isDe <- res[,'padj']<fdr
				isDe[is.na(isDe)] <- F
			}else{
				isDe <- vector(length=length(ids))>0.1 # No DE genes for replicates.
			}
		}
	}else{
		if(doFpkm){
			isDe <- vector(length=nrow(fpkmPoolMat))>0.1
			names(isDe) <- rownames(fpkmPoolMat)
		}else{
			isDe <- vector(length=nrow(cpmPoolMat))>0.1
			names(isDe) <- rownames(cpmPoolMat)
		}

		if(!isGeneId(gsnList)){
			isDe[unlist(symToId(gsnList))] <- T
		}else{
			isDe[gsnList] <- T
		}
	}

	df <- data.frame(gene_id=ids,valX=xVals,valY=yVals)
	df[,'gene_short_name'] <- unlist(idToSym(ids))
	rownames(df) <- df$gene_id

	if(!quiet){
		print(paste("Number of DE genes:",sum(isDe)))
		print(paste("Pearson corr of non-log-transformed vals:",cor(df$valX,df$valY)))
	}

	if(length(colour)>1.1){
		# Have suggested two colours; add in two levels of highlighting values.
		yEnr <- df$valY>df$valX
		yEnrDe <- (yEnr*isDe)>0.1
		toHl <- isDe
		toHl[yEnrDe] <- 2
		df[,'highlight'] <- toHl
	}else{
		df[,'highlight'] <- isDe
	}
	theMax <- max(max(df[,2]),max(df[,3]))
	theMin <- 1
	theMaxX <- theMax
	theMaxY <- theMax
	theMinX <- theMin
	theMinY <- theMin
	if (maxX>0){theMaxX <- maxX}
	if (maxY>0){theMaxY <- maxY}
	if (minX>0){if (minX<maxX){theMinX <- minX}}
	if (minY>0){if (minY<maxY){theMinY <- minY}}

	gg <- ggplot(df,aes(x=valX,y=valY,label=gene_short_name))
	gg <- gg + geom_point(aes(colour=factor(highlight)),alpha=0.2)
	gg <- gg + scale_colour_manual(values=c("black",colour))
	gg <- gg + theme_bw()
	gg <- gg + scale_x_log10(limits=c(theMin,theMax))
	gg <- gg + scale_y_log10(limits=c(theMin,theMax))
	if(doFpkm){
			gg <- gg + xlab(paste('FPKM+1',sampleX))
			gg <- gg + ylab(paste('FPKM+1',sampleY))
			gg <- gg + geom_abline(slope=1,linetype='dashed',weight=0.1)
	}else{
		if(cpm){
			gg <- gg + xlab(paste('CPM+1,',sampleX))
			gg <- gg + ylab(paste('CPM+1,',sampleY))
			gg <- gg + geom_abline(slope=1,linetype='dashed',weight=0.1)
		}else{
			gg <- gg + xlab(paste('Count+1,',sampleX))
			gg <- gg + ylab(paste('Count+1,',sampleY))
		}
	}
	gg <- gg + theme(legend.position='none')
	if(label){gg <- gg + geom_text(data=subset(df,highlight>0.1),hjust=0,vjust=0,size=2)}

	print(gg)
}


# read "sms_spam.csv" file,
# we must add encoding='UTF-8'otherwise we can't use DocumentTermMatrix funciton later
sms_raw <- read.csv("sms_spam.csv", stringsAsFactors = FALSE,encoding='UTF-8')

# rename
names(sms_raw)[1] <- 'type'

# check the variables
str(sms_raw$type)
table(sms_raw$type)

# change spam and ham to factor
sms_raw$type <- factor(sms_raw$type)

# import text mining package "tm"
library(tm)

# build a Volatiel Corpora containing the SMS messages in the training data
sms_corpus <- VCorpus(VectorSource(sms_raw$text))

# check corpora
print(sms_corpus)
inspect(sms_corpus[1:3])
view1[[1]]$content
view1[[2]]$content
view1[[3]]$content
# we can also use as.character(sms_corpus[[1]]) to check the content
as.character(sms_corpus[[1]])
# and also can use lapply(sms_corpus[1:3], as.character) to check the content
lapply(sms_corpus[1:3], as.character)

# convert all of the SMS messages to lowercase and remove any numbers:
sms_corpus_clean <- tm_map(sms_corpus, content_transformer(tolower))
sms_corpus_clean <- tm_map(sms_corpus_clean, removeNumbers)

# delete stop words
sms_corpus_clean <- tm_map(sms_corpus_clean, removeWords, stopwords())

# define replace function
# replacePunctuation <- function(x) { gsub("[[:punct:]]+", " ", x) }

# remove punctuation
sms_corpus_clean <- tm_map(sms_corpus_clean, removePunctuation)

# install SnowballC package, which can handle same word with different type
library(SnowballC)
wordStem(c("learn", "learned", "learning", "learns"))

# make different words' type to single one
sms_corpus_clean <- tm_map(sms_corpus_clean, stemDocument)

# remove additional whitespace, leave a single one
sms_corpus_clean <- tm_map(sms_corpus_clean, stripWhitespace)

# create a sparse matrix
sms_dtm <- DocumentTermMatrix(sms_corpus_clean)

# create train set and test set
sms_dtm_train <- sms_dtm[1:4169, ]
sms_dtm_test  <- sms_dtm[4170:5559, ]

# keep classical label
sms_train_labels <- sms_raw[1:4169, ]$type
sms_test_labels  <- sms_raw[4170:5559, ]$type

# word cloud
library(wordcloud)
# wordcloud example, input 26 letters, the frequency is 1 to 26 according to a to z.
# wordcloud(c(letters), seq(1, 26),random.order=F)
# wordcloud example, show three words which the most frequency
# wordcloud(iris$Species, max.words=3)

# wordcloud can support corpus type. a word appear more than 50 times can be showed in cloud
wordcloud(sms_corpus_clean, min.freq = 50, random.order = FALSE)

# make the train set into two sets, discovery the word cloud
spam <- subset(sms_raw, type == "spam")
ham  <- subset(sms_raw, type == "ham")
# the typeface is 0.5 to 3
wordcloud(spam$text, max.words = 40, scale = c(3, 0.5))
wordcloud(ham$text, max.words = 40, scale = c(3, 0.5))

# find and save these words which frequency greater than 5
sms_freq_words <- findFreqTerms(sms_dtm_train, 5)

# use the high frequency words to build a new sparse matrix
sms_dtm_freq_train <- sms_dtm_train[ , sms_freq_words]
sms_dtm_freq_test <- sms_dtm_test[ , sms_freq_words]

# change frequency to "yes" and "no"
convert_counts <- function(x) {
  x <- ifelse(x > 0, "Yes", "No")
}

# make the change, margin=2 means use for columns
sms_train <- apply(sms_dtm_freq_train, MARGIN = 2, convert_counts)
sms_test  <- apply(sms_dtm_freq_test, MARGIN = 2, convert_counts)

# use e1071 package to do naive byes analyzation
library(e1071)
sms_classifier <- naiveBayes(sms_train, sms_train_labels)

# evaluate the performance
sms_test_pred <- predict(sms_classifier, sms_test)

# use crosstable to show the performance
library(gmodels)
CrossTable(sms_test_pred, sms_test_labels,
           prop.chisq = FALSE, prop.t = FALSE, prop.r = FALSE,
           dnn = c('predicted', 'actual'))

# boost property
sms_classifier2 <- naiveBayes(sms_train, sms_train_labels, laplace = 1)
sms_test_pred2 <- predict(sms_classifier2, sms_test)
CrossTable(sms_test_pred2, sms_test_labels,
           prop.chisq = FALSE, prop.t = FALSE, prop.r = FALSE,
           dnn = c('predicted', 'actual'))


library(quantmod)

stock <- get(getSymbols('2330.TW'))

#getSymbols('^TWII')
#stock <- TWII

stock <- to.weekly(stock)
#View(stock)
chartSeries(stock['2020'],
            theme='white',
            up.col='red', dn.col='green' # chinese convention
           )
(Hi(stock) + Lo(stock)) / 2
plot(Cl(stock))
money <- -Op(stock) + Cl(stock)
View(money)
#View( cbind( Op(stock), Cl(stock), money ) )

money <- na.omit(money)
sum(money)
plot( cumsum(money) )


#' Data Processing for Simulations
#'
#' Processes output from data simulation functions for posterior use in model validation procedures. Only package internal use.
#' @param simulated_data Data frame or tibble.
#' @return Returns a list with two entries: "forstan" is the data in the correct format to be used in fitting. "forsim" is for data simulation.
fake_data_processing <- function(data){

    a <- data

    a$suj <- as.factor(a$suj)
    SUB <- length(levels(a$suj))#amount of subjects
    names <- levels(a$suj) <- 1:SUB

    aggreg <- ddply(a, c('suj'), summarise, freq = length(rt), .drop = FALSE )
    dat_amt <- aggreg$freq #vector with amount of data per subject

    N_min <- min(aggreg$freq) # min amount of data
    N_max <- max(aggreg$freq) # max amount of data

    Nu <- ddply(a, c('suj'), summarise, value = sum(cor==1), .drop = FALSE )$value
    Nl <- ddply(a, c('suj'), summarise, value = sum(cor==0), .drop = FALSE )$value

    minRT <- ddply(a, c('suj'), summarise, value = min(rt), .drop = FALSE ) #min RT per subject
    minRT$suj <- as.numeric(minRT$suj)
    minRT <- minRT$value

    # Reaction times for upper and lower boundary responses, PADDED matrices
    RTu <- array(-1, c(SUB, max(Nu)))
    RTl <- array(-1, c(SUB, max(Nl)))

    # Store each subjects' reaction time data
    for (i in 1:SUB){
        tmp             <- subset(a, a$suj == i)
        RTu[i, 1:Nu[i]] <- tmp$rt[tmp$cor == 1] # (Nu/Nl[i]+1):Nu/Nl_max will be padded with 0's
        RTl[i, 1:Nl[i]] <- tmp$rt[tmp$cor == 0] # 0 padding is skipped in likelihood calculation
    }

    RTbound <- 0.1

    # List of data sent to Stan
    forstan <- list(
        N       = SUB, # Number of subjects
        Nu_max  = max(Nu),  # Max (across subjects) number of upper boundary responses
        Nl_max  = max(Nl),  # Max (across subjects) number of lower boundary responses
        Nu      = Nu,       # Number of upper boundary responses for each subj
        Nl      = Nl,       # Number of lower boundary responses for each subj
        RTu     = RTu,      # upper boundary response times
        RTl     = RTl,      # lower boundary response times
        minRT   = minRT,    # minimum RT for each subject of the observed data
        RTbound = RTbound   # lower bound or RT across all subjects (e.g., 0.1 second)
    )

    forsim <- list(
        names = 1:SUB,
        rawdat = a[c('suj', 'rt', 'cor')]
    )

    return(list(forstan = forstan, forsim = forsim))
}


library(quantreg)
library(Rfit)

# plot function
plot_df <- function(df, rankscale = FALSE, ylim = NULL, stripcol = c("#21A883CC", "#4591CCCC", "#673AB7CC"), COL = c("#21A883", "#4591CC", "#673AB7") ) {
  path <- rownames(df$tau)
  tau <- df$tau
  df <- df$df; df$x <- df$x + 1

  if(rankscale == TRUE) {
    range_y <- range(df$y)
    rank_y <- rank(df$y)
    rank_y_sc <- (rank_y - min(rank_y))/(max(rank_y)-min(rank_y) )
    df$y <- (rank_y_sc)*(max(range_y)-min(range_y)) + min(range_y)
  }

  q0 = round(tau$tau, 3)
  ptau = round(tau$p, 5)

  X0 <- seq(1, 3, 0.1)
  mm <- model.matrix( ~ X0)
  m1 <- rfit(y ~ x, df)
  pred.m1 <- coef(m1)[[1]] + X0*coef(m1)[[2]]
  pred.se <- apply(mm, 1, function(Xrow) t(Xrow) %*% vcov(m1) %*% Xrow)
  upp <- pred.m1 + 1.96*sqrt(pred.se)
  lwr <- pred.m1 - 1.96*sqrt(pred.se)

  upp_sd <- aggregate(y ~ x, data=df, function(x) mean(x) + sd(x))$y
  lwr_sd <- aggregate(y ~ x, data=df, function(x) mean(x) - sd(x))$y

  if(is.null(ylim)) { ylim <- range(c(df$y, upp, lwr, upp_sd, lwr_sd))  }

  stripchart(df$y ~ I(df$x-1), vertical=T, method="jitter", pch=c(15,16, 17), col=stripcol, add=F, cex=2, ylab = colnames(H1N1_noise_paths)[H1N1_idx], ylim = ylim, las=1)
  polygon(c(X0, rev(X0)), c(lwr, rev(upp)), col="#00000033", border = NA);
  lines(X0, pred.m1, col=1, lty=2, lwd=3);
  segments(c(1:3), upp_sd, c(1:3), lwr_sd, col = COL, lwd=3  )
  points(c(1:3), aggregate(y ~ x, data=df, function(x) mean(x))$y, pch=21, col = COL, bg = "white", cex=3, lwd=3  )
  legend("topleft", legend = paste0("H1N1: tau = ", q0, ", p = ", ptau))

}

################################################################################
setwd("/media/yuri/Data/home1/GNI_data/infection/ResultsSciRep")
load("CAP_Sepsis_Ensemble_noise_sig.RDat")
load("H1N1_Ensemble_noise_sig.RDat")

pheno_CAP$mort_num[pheno_CAP$mort == "NA"] <- -1
pheno_CAP$mort_num <- pheno_CAP$mort_num + 1
pheno_SPS$mort_num[pheno_SPS$mort == "NA"] <- -1
pheno_SPS$mort_num <- pheno_SPS$mort_num + 1

ALL_UP <- Reduce(intersect, list( H1N1 = rownames(padjR_H1N1_stage_sig_UP),
                 CAP = rownames(padjR_CAP_stage_sig_UP),
                 sepsis = rownames(padjR_SPS_stage_sig_UP)))
CAP_H1N1_UP <- Reduce(intersect, list( H1N1 = rownames(padjR_H1N1_stage_sig_UP), CAP = rownames(padjR_CAP_stage_sig_UP) ) )
CAP_H1N1_UP <-  CAP_H1N1_UP[!(CAP_H1N1_UP %in% ALL_UP)]

CAP_SPS_UP <- Reduce(intersect, list( SPS = rownames(padjR_SPS_stage_sig_UP), CAP = rownames(padjR_CAP_stage_sig_UP) ) )
CAP_SPS_UP <-  CAP_SPS_UP[!(CAP_SPS_UP %in% ALL_UP)]

################################################################################
setwd("/media/yuri/Data/home1/GNI_data/infection/ResultsSciRep/Figures")

pdf("Figure2B.pdf", paper="a4r", width=8, height=5)

for(k in seq(ALL_UP)) {

idx <- ALL_UP[k]
H1N1_idx <- which(colnames(H1N1_noise_paths) == idx)
df0 <- data.frame(y=H1N1_noise_paths[,H1N1_idx] , x = as.numeric(factor(H1N1_stage))-1)

cap_idx <- which(colnames(affyDat_noise_paths_CAP) == idx)
df1 <- data.frame(y = affyDat_noise_paths_CAP[,cap_idx] , x = pheno_CAP$mort_num, age=pheno_CAP$age)
m00 <- lm(y ~ age, data=df1)
df1$y <-coefficients(m00)[[1]] + resid(m00)
df1$age <- NULL

sps_idx <- which(colnames(affyDat_noise_paths_SPS) == idx)
df2 <- data.frame(y = affyDat_noise_paths_SPS[,cap_idx] , x = pheno_SPS$mort_num, age=pheno_SPS$age)
m00 <- lm(y ~ age, data=df2)
df2$y <- coefficients(m00)[[1]] + resid(m00)
df2$age <- NULL

ylim = range(c(df1$y, df2$y))

par(mfrow = c(1,3))
plot_df(list(df = df0, tau = padjR_H1N1_stage[H1N1_idx,]), ylim = NULL, stripcol = c("#21A883CC", "#4591CCCC", "#673AB7CC"), COL=1)
plot_df(list(df = df1, tau = padjR_CAP_stage[cap_idx,]),   ylim = ylim, stripcol = c("#21A88388", "#4591CC88", "#673AB788"), COL=1)
plot_df(list(df = df2, tau = padjR_SPS_stage[sps_idx,]),   ylim = ylim, stripcol = c("#21A88388", "#4591CC88", "#673AB788"), COL=1)
}

dev.off()

################################################################################

pdf("Figure2C.pdf", paper="a4r", width=8, height=5)

for(k in seq(CAP_H1N1_UP)) {

idx <- CAP_H1N1_UP[k]
H1N1_idx <- which(colnames(H1N1_noise_paths) == idx)
df0 <- data.frame(y=H1N1_noise_paths[,H1N1_idx] , x = as.numeric(factor(H1N1_stage))-1)

cap_idx <- which(colnames(affyDat_noise_paths_CAP) == idx)
df1 <- data.frame(y = affyDat_noise_paths_CAP[,cap_idx] , x = pheno_CAP$mort_num, age=pheno_CAP$age)
m00 <- lm(y ~ age, data=df1)
df1$y <-coefficients(m00)[[1]] + resid(m00)
df1$age <- NULL

sps_idx <- which(colnames(affyDat_noise_paths_SPS) == idx)
df2 <- data.frame(y = affyDat_noise_paths_SPS[,cap_idx] , x = pheno_SPS$mort_num, age=pheno_SPS$age)
m00 <- lm(y ~ age, data=df2)
df2$y <- coefficients(m00)[[1]] + resid(m00)
df2$age <- NULL

ylim = range(c(df1$y, df2$y))

par(mfrow = c(1,3))
plot_df(list(df = df0, tau = padjR_H1N1_stage[H1N1_idx,]), ylim = NULL, stripcol = c("#21A883CC", "#4591CCCC", "#673AB7CC"), COL=1)
plot_df(list(df = df1, tau = padjR_CAP_stage[cap_idx,]),   ylim = ylim, stripcol = c("#21A88388", "#4591CC88", "#673AB788"), COL=1)
plot_df(list(df = df2, tau = padjR_SPS_stage[sps_idx,]),   ylim = ylim, stripcol = c("#21A88388", "#4591CC88", "#673AB788"), COL=1)
}

dev.off()

################################################################################
# Supplementary tables
# ALL_UP_table <- lapply(seq(ALL_UP), function(k) {
#   idx <- ALL_UP[k]
#   H1N1_idx <- which(colnames(H1N1_noise_paths) == idx)
#   cap_idx <- which(colnames(affyDat_noise_paths_CAP) == idx)
#   sps_idx <- which(colnames(affyDat_noise_paths_SPS) == idx)
#
#   path <- names(core_paths_subset)[grep(ALL_UP[k], names(core_paths_subset), fixed=T)]
#   genes <- sort(core_paths_subset[grep(ALL_UP[k], names(core_paths_subset), fixed=T)][[1]])
#   tau_h1n <- round(as.numeric(padjR_H1N1_stage[H1N1_idx,1]),3)
#   tau_cap <-   round(as.numeric(padjR_CAP_stage[cap_idx,1]),3)
#   tau_sps <-   round(as.numeric(padjR_SPS_stage[sps_idx,1]),3)
#
#   p_h1n <- round(as.numeric(padjR_H1N1_stage[H1N1_idx,2]),6)
#   p_cap <-   round(as.numeric(padjR_CAP_stage[cap_idx,2]),6)
#   p_sps <-   round(as.numeric(padjR_SPS_stage[sps_idx,2]),6)
#
#   res <- data.frame(path = path,
#     H1N1 = paste(tau_h1n, p_h1n, sep="; "),
#     CAP  = paste(tau_cap, p_cap, sep="; "),
#     SPS  = paste(tau_sps, p_sps, sep="; "),
#     genes = paste(genes, collapse = "; ") )
#   res
# })
# ALL_UP_table <- do.call(rbind, ALL_UP_table)
#
#
# CAP_H1N1_UP_table <- lapply(seq(CAP_H1N1_UP), function(k) {
#   idx <- CAP_H1N1_UP[k]
#   H1N1_idx <- which(colnames(H1N1_noise_paths) == idx)
#   cap_idx <- which(colnames(affyDat_noise_paths_CAP) == idx)
#   sps_idx <- which(colnames(affyDat_noise_paths_SPS) == idx)
#
#   path <- names(core_paths_subset)[grep(CAP_H1N1_UP[k], names(core_paths_subset), fixed=T)]
#   genes <- sort(core_paths_subset[grep(CAP_H1N1_UP[k], names(core_paths_subset), fixed=T)][[1]])
#   tau_h1n <- round(as.numeric(padjR_H1N1_stage[H1N1_idx,1]),3)
#   tau_cap <-   round(as.numeric(padjR_CAP_stage[cap_idx,1]),3)
#   tau_sps <-   round(as.numeric(padjR_SPS_stage[sps_idx,1]),3)
#
#   p_h1n <- round(as.numeric(padjR_H1N1_stage[H1N1_idx,2]),6)
#   p_cap <-   round(as.numeric(padjR_CAP_stage[cap_idx,2]),6)
#   p_sps <-   round(as.numeric(padjR_SPS_stage[sps_idx,2]),6)
#
#   res <- data.frame(path = path,
#     H1N1 = paste(tau_h1n, p_h1n, sep="; "),
#     CAP  = paste(tau_cap, p_cap, sep="; "),
#     SPS  = paste(tau_sps, p_sps, sep="; "),
#     genes = paste(genes, collapse = "; ") )
#   res
# })
# CAP_H1N1_UP_table <- do.call(rbind, CAP_H1N1_UP_table)
#
# write.table(ALL_UP_table, "ALL_UP_table.txt", row.names=F, col.names=T, quote=F, sep="\t")
# write.table(CAP_H1N1_UP_table, "CAP_H1N1_UP_table.txt", row.names=F, col.names=T, quote=F, sep="\t")


 printallargs1 <- function(...) list(...)
 printallargs1(1:5, "abc", TRUE)
# [[1]]
# [1] 1 2 3 4 5
#
# [[2]]
# [1] "abc"
#
# [[3]]
# [1] TRUE


##############################Statistics###############################
#check if each segment is significant using t-test checking distance from 0
#t-test for Half-life
#select HL fragments
setwd("path_new_directory_data_comparison/")
statistics <- function(data){

    frag_HL <-
    unique(data[,"HL_comb_fragment"][
        grep(paste0("Dc_\\d+$"), df_comb[,"HL_comb_fragment"])])

    frag_int <-
    unique(df_comb[",intensity_comb_fragment"][
        grep(paste0("I_\\d+$"), df_comb[,"intensity_comb_fragment"])])

    data <-
        t_test_function(
            data = data,
            par = "HL",
            par1 = "half_life",
            cdt1 = "sc",
            cdt2 = "fe",
            frag = frag_HL
        )
    p_adjusted <-
        as.numeric(p.adjust(as.numeric(data[ ,"p_value_distance_HL"]),
                            method = "fdr"))
    data <-
        tibble::add_column(data, formatC(p_adjusted, format = "e", digits = 2),
                           .after = ncol(data)-1)

    colnames(data)[ncol(data)] <- "p_adjusted_HL"

    data <-
        t_test_function(
            data = data,
            par = "intensity",
            par1 = "intensity",
            cdt1 = "sc",
            cdt2 = "fe",
            frag = frag_int
        )

        p_adjusted <-
            as.numeric(p.adjust(as.numeric(data[ ,"p_value_distance_intensity"]),
                                method = "fdr"))
        data <-
            tibble::add_column(data, formatC(p_adjusted, format = "e", digits = 2),
                               .after = ncol(data)-1)

        colnames(data)[ncol(data)] <- "p_adjusted_intensity"
        return(data)
        }

df_comb <- statistics(data = df_comb)

#remove duplicated intensity fragments to save it on table
df_comb_uniq <-
    df_comb[!duplicated(df_comb$intensity_comb_fragment), ]

#save the data
write_xlsx(df_comb_uniq, "df_comb_uniq_se.xlsx")
save(df_comb, file="df_comb_se.rda")


getwd()
FEM_dir <- "/home/luke/Documents/E_FEM_clean/E_FEM/input_data"
setwd(FEM_dir)

require(haven)
require(mice)
require(lattice)
require(tidyverse)

set.seed(500) # Set seed for reproducibility

# Read in the reshaped_data and get a summary
H_ELSA_base <- read_dta('H_ELSA_pre_reshape.dta')
#H_ELSA_base <- read_dta('H_ELSA_f_2002-2016.dta')
summary(H_ELSA_base)

# Select only the vars we want to impute, plus those to use in the imputation
H_ELSA <- H_ELSA_base %>% select(contains(c('idauniq', 'iwindy', 'rabyear', 'radyear', 'ragender', 'raracem', 'raeducl', 'hlthlm', 'work', 'itearn', 'retemp',
                                            'vgactx_e', 'mdactx_e', 'ltactx_e', 'ipubpen', 'drink', 'drinkd', 'bmi', 'smoken', 'smokev', 'smokef')))

# Assign impossible bmi values as missing (values with BMI < 10. Only happens in wave 8, 4 cases)
H_ELSA$bmi8[H_ELSA$bmi8 < 10] <- NA

# Run the imputation
impData <-mice(H_ELSA, m = 5, maxit=5, seed=500, tol=1e-15)

# Now collect all imputed datasets in long format
completedData <- complete(impData, 'long')

# Extract only bmi vars
bmiVars <- completedData %>% select(contains(c('id', 'bmi')))

# Aggregate the data
a<-aggregate(bmiVars , by = list(bmiVars$.id),FUN= mean)

# Remove vars generated in imputation
colnames(a)
final <- a %>% select(-c('Group.1', '.id'))
# Rename bmivars to make it clear these include imputed values
colnames(final)[2:5] <- c('bmi2_imp', 'bmi4_imp', 'bmi6_imp', 'bmi8_imp')

write_path <- '/home/luke/Documents/E_FEM_clean/E_FEM/input_data/bmi_imputed_R.dta'

# Finally, export data as Stata .dta
write_dta(final, write_path)

summary(final)


#' @export
triangleplot <- function(mat, positions, colors, color.scale, drawscale=TRUE, scale.cex=0.6, ...) {

  if ( ncol(mat) != nrow(mat) ) stop('Matrix must be square.')

  n <- ncol(mat)

  if ( missing(positions) ) {
    positions <- 0:(n+1)
  } else if ( length(positions) != n && length(positions) != n+1 ) stop('positions must match matrix size')

  if ( is.unsorted(positions) ) warning('Positions are not in order!')

  if ( missing(colors) ) {
    if ( 'RColorBrewer' %in% rownames(installed.packages()) ) {
      require('RColorBrewer')
      colors <- extend.color.range(brewer.pal(11, 'RdYlGn'), 100)
    } else {
      colors <- grey(0:99/99)
    }
  }

  if ( missing(color.scale) ) color.scale <- range(mat, na.rm=TRUE)

  plot(0, type='n', ylim=c(min(positions)-max(positions), 0),
       xlim=range(positions),
       axes=FALSE, xlab='', ylab='', yaxs='i', ...)

  # Calculate positions for SNPs
  if ( length(positions) == n) {
    x.pos <- positions
    x.pos.mids <- (x.pos[-1] + x.pos[-n])/2
    x.pos.left <- c(x.pos[1], x.pos.mids)
    x.pos.right <- c(x.pos.mids, x.pos[n])
  } else {
    x.pos.left <- positions[-(n+1)]
    x.pos.right <- positions[-1]
  }

  # Loop through each position in the matrix and draw polygon of appropriate shade
  for ( i in 1:n ) {
    for ( j in 1:i ) {
      fill.color <- assign.scale.colors(mat[i, j], colors, color.scale)
      # Draw a diamond shape
      polygon(c(x.pos.left[i]+x.pos.left[j],
                x.pos.right[i]+x.pos.left[j],
                x.pos.right[i]+x.pos.right[j],
                x.pos.left[i]+x.pos.right[j])/2,
              -c(x.pos.left[i]-x.pos.left[j],
                 x.pos.right[i]-x.pos.left[j],
                 x.pos.right[i]-x.pos.right[j],
                 x.pos.left[i]-x.pos.right[j]),
              col=fill.color, border=fill.color, ljoin='bevel')
      # NOTE: not drawing polygon borders (i.e. border=NA) causes jagged,
      # pixelated edges. So we draw a border in the same color as the fill
    }
  }

  if ( drawscale ) {
    draw.scale(colors, color.scale, pos='bottomleft')
  }
}


# packages needed
rm(list = ls())
source("project_paths.r")

library(tidyverse)
library(plm)
library(lmtest)
library(broom)
# library(flextable)
# library(officer)
library(knitr)

outcomes <- read_rds(paste(PATH_OUT_DATA, "outcomes.rds", sep="/"))
events_by_time <-  read_rds(paste(PATH_OUT_DATA, "events_by_time.rds", sep="/"))
demographics <-read_rds(paste(PATH_OUT_DATA, "demographics.rds", sep="/"))

outcomes['year']= apply(outcomes, 1, function(x) (which(letters == x['wave']) + 2000))

#demographics$wave <- apply(outcomes, 1, function(x) (which(letters == x['wave']) + 2000))

outcomes %>%
  filter(code == 'losat') %>%
  mutate(
    life_satisfaction = case_when(
      val < 0 ~ NA_integer_,
      TRUE ~ as.integer(val)
    )
  ) %>%
  dplyr::select(-code, -val) -> cognitive.df

cognitive_mean_by_year.df=cognitive.df %>%
  group_by(year) %>%
  dplyr::summarize(Mean = mean(life_satisfaction, na.rm=TRUE)) # grouping by year

demographics %>%
  filter(code == 'hgage') %>%
  mutate(age = floor(val/10)) %>%
  dplyr::select(xwaveid, wave, age) -> age.df

demographics %>%
  filter(code == 'female') %>%
  mutate(sex = val) %>%
  dplyr::select(xwaveid,sex) -> female.df

demographics %>%
  filter(code == 'hhda10') %>%
  mutate(
    val = case_when(
      val < 0 ~ NA_integer_, # recode missing values as NA
      TRUE ~ as.integer(val)
    )
  ) %>%
  group_by(xwaveid) %>%
  arrange(xwaveid, wave) %>%
  fill(val, .direction = 'down') %>%
  fill(val, .direction = 'up') %>%
  dplyr::select(xwaveid, wave, seifa = val) %>%
  replace_na(list(seifa = 0)) -> seifa.df

# level of highest education (edhigh1)
demographics %>%
  filter(code == 'edhigh1') %>%
  mutate(
    reval = case_when(
      val < 0 ~ NA_real_,   # recode missing values as NA
      val == 10 ~ NA_real_, # recode undetermined values as NA
      val == 1 ~  3,        # PhD
      val == 2 ~  2,        # Grad diploma
      val == 3 ~  2,        # Bachelors
      val == 4 ~  1,        # Diploma
      val == 5 ~  1,        # Certificate
      val == 8 ~  0,        # Year 12
      val == 9 ~ -1         # Year 10
    )
  ) %>%
  group_by(xwaveid) %>%
  arrange(xwaveid, wave) %>%
  fill(reval, .direction = 'down') %>%
  fill(reval, .direction = 'up') %>%
  dplyr::select(xwaveid, wave, edu = reval) %>%
  replace_na(list(edu = 0)) -> edu.df

edu.df %>%
  left_join(age.df, by = c("xwaveid", "wave")) %>%
  left_join(seifa.df, by = c("xwaveid", "wave")) %>%
  left_join(female.df, by = c("xwaveid"))-> covariates

main_df=cognitive.df %>%
  left_join(covariates, by = c("xwaveid", "wave"))

main_df=main_df%>% filter(!is.na(life_satisfaction))

means_female=main_df %>%
  group_by(year) %>%filter(sex==1)%>%
  dplyr::summarize(Mean_female = mean(life_satisfaction, na.rm=TRUE)) %>% dplyr::select(-year)# grouping by year

means_male=main_df %>%
  group_by(year) %>%filter(sex==0)%>%
  dplyr::summarize(Mean_male = mean(life_satisfaction, na.rm=TRUE)) %>% dplyr::select(-year)# grouping by year

means_all=main_df %>%
  group_by(year) %>%
  dplyr::summarize(Mean_all = mean(life_satisfaction, na.rm=TRUE)) # grouping by year

means_to_plot <-cbind(means_all,means_male,means_female)

x_axis_labels <- min(means_to_plot[,'year']):max(means_to_plot[,'year'])

filename=paste(PATH_OUT_FIGURES, "average_life_satisfaction_all.png", sep="/")

ggplot(means_to_plot, aes(x=year)) +
  geom_line(aes(y = Mean_female, color = "female")) +
  scale_x_continuous(labels = x_axis_labels, breaks = x_axis_labels)+
  geom_line(aes(y = Mean_male, color="Males"), linetype="twodash") +
  geom_line(aes(y = Mean_all, color="All"), linetype="twodash",size=2)+
   scale_color_manual(values = c(
  'Y1' = 'darkblue',
  'Y2' = 'red',
  'Y2' = 'black')) +
  labs(color = 'Y series')+ggtitle("Average Life Satisfaction of Australians (2002-2016)")+ labs(y="Life Satisfaction", x = "Year")

ggsave(filename)


# Libraries used
library(boot)
library(car)
library(QuantPsyc)
library(lmtest)
library(sandwich)
library(vars)
library(nortest)
library(MASS)

# Changing name of given dataset to data and checking structure and summary of data
setwd("F:/Projects/Customer Value Analysis in Insurance Marketing")
data <- read.csv("Insurance_Marketing_Customer_Value_Analysis.csv")
str(data)
summary(data)

# Converting character variables into Factor variables
data$State <- as.factor(data$State)
data$Response <- as.factor(data$Response)
data$Coverage <- as.factor(data$Coverage)
data$Education <- as.factor(data$Education)
data$EmploymentStatus <- as.factor(data$EmploymentStatus)
data$Gender <- as.factor(data$Gender)
data$Location_Code  <- as.factor(data$Location_Code )
data$Marital_Status  <- as.factor(data$Marital_Status)
data$Policy_Type  <- as.factor(data$Policy_Type)
data$Renew_Offer_Type  <- as.factor(data$Renew_Offer_Type)
data$Policy  <- as.factor(data$Policy)
data$Sales_Channel  <- as.factor(data$Sales_Channel)
data$Vehicle_Class  <- as.factor(data$Vehicle_Class)
data$Vehicle_Size  <- as.factor(data$Vehicle_Size)

# Converting two numerical variables as factors
data$Number_of_Open_Complaints <- as.factor(data$Number_of_Open_Complaints)
data$Number_of_Policies <- as.factor(data$Number_of_Policies)
str(data)

# Checking for the missing values : No missing values found
sapply(data, function(x) sum(is.na(x)))
summary(data)

# Checking for the presence of Outliers in Dependent variable and removing them
boxplot(data$Customer_Lifetime-Value)
quantile(data$Customer_Lifetime_Value, c(0,0.05,0.1,0.25,0.5,0.75,0.90,0.95,0.99,0.995,1))
data <- data[data$Customer_Lifetime_Value <15628.739, ]
boxplot(data$Customer_Lifetime_Value)

boxplot(data$Customer_Lifetime-Value)
quantile(data$Customer_Lifetime_Value, c(0,0.05,0.1,0.25,0.5,0.75,0.90,0.95,0.99,0.995,1))
data <- data[data$Customer_Lifetime_Value <14956.300, ]
boxplot(data$Customer_Lifetime_Value)

boxplot(data$Customer_Lifetime-Value)
quantile(data$Customer_Lifetime_Value, c(0,0.05,0.1,0.25,0.5,0.75,0.90,0.95,0.99,0.995,1))
data <- data[data$Customer_Lifetime_Value <14956.300, ]
boxplot(data$Customer_Lifetime_Value)

# Checking the presence of Outliers in other independent variables and removing them
boxplot(data$Income)

boxplot(data$Monthly_Premium_Auto)
quantile(data$Monthly_Premium_Auto, c(0,0.05,0.1,0.25,0.5,0.75,0.90,0.95,0.99,0.995,1))
data <- data[data$Monthly_Premium_Auto <167, ]
boxplot(data$Months_Since_Policy_Inception)

boxplot(data$Total_Claim_Amount)
quantile(data$Total_Claim_Amount, c(0,0.05,0.1,0.25,0.5,0.75,0.90,0.95,0.99,0.995,1))
data <- data[data$Total_Claim_Amount <944.994931, ]
boxplot(data$Total_Claim_Amount)

nrow(data)
names(data)

# Preparing the Regression model :

#Iteration 1 :

fit<- lm(Customer_Lifetime_Value ~ 	State+Response+	Coverage +
           Education+Effective_To_Date +EmploymentStatus+Gender+
           Income+Location_Code+Months_Since_Policy_Inception+
           Marital_Status+ Months_Since_Last_Claim+Policy_Type+
           Monthly_Premium_Auto + Policy+Sales_Channel+
           Number_of_Open_Complaints + Number_of_Policies +
           Renew_Offer_Type +  Total_Claim_Amount+
           Vehicle_Class+Vehicle_Size, data=data)

summary(fit)

#Iteration 2 :

fit<- lm(Customer_Lifetime_Value ~ Response+	Coverage +
           Education+Effective_To_Date +EmploymentStatus+Gender+
           Income+Location_Code+Months_Since_Policy_Inception+
           Marital_Status+ Months_Since_Last_Claim+Policy_Type+
           Monthly_Premium_Auto + Policy+Sales_Channel+
           Number_of_Open_Complaints + Number_of_Policies +
           Renew_Offer_Type +  Total_Claim_Amount+
           Vehicle_Class+Vehicle_Size, data=data)

summary(fit)

#Iteration 3 :

fit<- lm(Customer_Lifetime_Value ~ Coverage +
           Education+Effective_To_Date +EmploymentStatus+Gender+
           Income+Location_Code+Months_Since_Policy_Inception+
           Marital_Status+ Months_Since_Last_Claim+Policy_Type+
           Monthly_Premium_Auto + Policy+Sales_Channel+
           Number_of_Open_Complaints + Number_of_Policies +
           Renew_Offer_Type +  Total_Claim_Amount+
           Vehicle_Class+Vehicle_Size, data=data)

summary(fit)

#Iteration 4 :

fit<- lm(Customer_Lifetime_Value ~
           Education+Effective_To_Date +EmploymentStatus+Gender+
           Income+Location_Code+Months_Since_Policy_Inception+
           Marital_Status+ Months_Since_Last_Claim+Policy_Type+
           Monthly_Premium_Auto + Policy+Sales_Channel+
           Number_of_Open_Complaints + Number_of_Policies +
           Renew_Offer_Type +  Total_Claim_Amount+
           Vehicle_Class+Vehicle_Size, data=data)

summary(fit)

#Iteration 5 :

fit<- lm(Customer_Lifetime_Value ~
           Education +EmploymentStatus+Gender+
           Income+Location_Code+Months_Since_Policy_Inception+
           Marital_Status+ Months_Since_Last_Claim+Policy_Type+
           Monthly_Premium_Auto + Policy+Sales_Channel+
           Number_of_Open_Complaints + Number_of_Policies +
           Renew_Offer_Type +  Total_Claim_Amount+
           Vehicle_Class+Vehicle_Size, data=data)

summary(fit)

#Iteration 6 :

fit<- lm(Customer_Lifetime_Value ~
           Education +EmploymentStatus+Gender+
           Income+Location_Code+Months_Since_Policy_Inception+
           Marital_Status+ Months_Since_Last_Claim+Policy_Type+
           Monthly_Premium_Auto + Policy+Sales_Channel+
           Number_of_Open_Complaints + Number_of_Policies +
           Renew_Offer_Type +  Total_Claim_Amount+
           Vehicle_Class, data=data)

summary(fit)

#Iteration 7 :

fit<- lm(Customer_Lifetime_Value ~
           Education +EmploymentStatus+Gender+
           Income+Location_Code+Months_Since_Policy_Inception+
           Marital_Status+ Months_Since_Last_Claim+Policy_Type+
           Monthly_Premium_Auto + Policy+Sales_Channel+
           Number_of_Open_Complaints + Number_of_Policies +
           Renew_Offer_Type +  Total_Claim_Amount
           , data=data)

summary(fit)

#Iteration 8 :

fit<- lm(Customer_Lifetime_Value ~
           Education +EmploymentStatus+Gender+
           Income+Location_Code+Months_Since_Policy_Inception+
           Marital_Status+ Policy_Type+
           Monthly_Premium_Auto + Policy+Sales_Channel+
           Number_of_Open_Complaints + Number_of_Policies +
           Renew_Offer_Type +  Total_Claim_Amount
         , data=data)

summary(fit)

#Iteration 9 : Sales_channel

fit<- lm(Customer_Lifetime_Value ~
           Education +EmploymentStatus+Gender+
           Income+Location_Code+Months_Since_Policy_Inception+
           Marital_Status+ Policy_Type+
           Monthly_Premium_Auto + Policy+
           Number_of_Open_Complaints + Number_of_Policies +
           Renew_Offer_Type +  Total_Claim_Amount
         , data=data)

summary(fit)

#Iteration 10 :

fit<- lm(Customer_Lifetime_Value ~
           Education +EmploymentStatus+Gender+
           Income+ I(Location_Code == "Suburban")+Months_Since_Policy_Inception+
           Marital_Status+ Policy_Type+
           Monthly_Premium_Auto + Policy +
           Number_of_Open_Complaints + Number_of_Policies +
           Renew_Offer_Type +  Total_Claim_Amount
         , data=data)

summary(fit)

#Iteration 11 :

fit<- lm(Customer_Lifetime_Value ~
           Education +EmploymentStatus+Gender+
           Income+ Months_Since_Policy_Inception+
           Marital_Status+ Policy_Type+
           Monthly_Premium_Auto + Policy +
           Number_of_Open_Complaints + Number_of_Policies +
           Renew_Offer_Type +  Total_Claim_Amount
         , data=data)

summary(fit)

#Iteration 12 :

fit<- lm(Customer_Lifetime_Value ~
           Education + I(EmploymentStatus == "Employed") +
           I(EmploymentStatus == "Unemployed") + Gender+
           Income+ Months_Since_Policy_Inception+
           Marital_Status+ Policy_Type+
           Monthly_Premium_Auto + Policy +
           Number_of_Open_Complaints + Number_of_Policies +
           Renew_Offer_Type +  Total_Claim_Amount
         , data=data)

summary(fit)

#Iteration 13 :

fit<- lm(Customer_Lifetime_Value ~
           Education + I(EmploymentStatus == "Employed") +
           I(EmploymentStatus == "Unemployed") + Gender+
           Income+ Months_Since_Policy_Inception+
           Marital_Status+ Policy_Type+
           Monthly_Premium_Auto + Policy +
           Number_of_Open_Complaints + Number_of_Policies +
           I(Renew_Offer_Type == "2") +  Total_Claim_Amount
         , data=data)

summary(fit)

#Iteration 14 :

fit<- lm(Customer_Lifetime_Value ~
           Education + I(EmploymentStatus == "Employed") +
           I(EmploymentStatus == "Unemployed") + Gender+
           Income+ Months_Since_Policy_Inception+
           Marital_Status+ Policy_Type+
           Monthly_Premium_Auto + Policy +
           Number_of_Open_Complaints + Number_of_Policies +
           Total_Claim_Amount
         , data=data)

summary(fit)

#Iteration 15 :

fit<- lm(Customer_Lifetime_Value ~
           Education + I(EmploymentStatus == "Employed") +
           I(EmploymentStatus == "Unemployed") + Gender+
           Income+ Months_Since_Policy_Inception+
           Marital_Status+ I(Policy_Type == "Personal Auto") +
           Monthly_Premium_Auto + Policy +
           Number_of_Open_Complaints + Number_of_Policies +
           Total_Claim_Amount
         , data=data)

summary(fit)

#Iteration 16 :

fit<- lm(Customer_Lifetime_Value ~
           Education + I(EmploymentStatus == "Employed") +
           I(EmploymentStatus == "Unemployed") + Gender+
           Income+ Months_Since_Policy_Inception+
           Marital_Status+ I(Policy_Type == "Personal Auto") +
           Monthly_Premium_Auto + I(Policy == "Corporate L2") +
           I(Policy == "Corporate L3") +
           Number_of_Open_Complaints + Number_of_Policies +
           Total_Claim_Amount
         , data=data)

summary(fit)

#Iteration 17 :

fit<- lm(Customer_Lifetime_Value ~
           Education + I(EmploymentStatus == "Employed") +
           I(EmploymentStatus == "Unemployed") + Gender+
           Income+ Months_Since_Policy_Inception+
           Marital_Status+
           Monthly_Premium_Auto + I(Policy == "Corporate L2") +
           I(Policy == "Corporate L3") +
           Number_of_Open_Complaints + Number_of_Policies +
           Total_Claim_Amount
         , data=data)

summary(fit)

#Iteration 18 :

fit<- lm(Customer_Lifetime_Value ~
           Education + I(EmploymentStatus == "Employed") +
           I(EmploymentStatus == "Unemployed") + Gender+
           Income+ Months_Since_Policy_Inception+
           Marital_Status+
           Monthly_Premium_Auto +
           Number_of_Open_Complaints + Number_of_Policies +
           Total_Claim_Amount
         , data=data)

summary(fit)

#Iteration 19 :

fit<- lm(Customer_Lifetime_Value ~
           Education + I(EmploymentStatus == "Employed") +
           I(EmploymentStatus == "Unemployed") + Gender+
           Income+ Months_Since_Policy_Inception+
           Marital_Status+
           Monthly_Premium_Auto +
           I(Number_of_Open_Complaints == "1") + I(Number_of_Open_Complaints == "3") +
          Number_of_Policies +I(Number_of_Open_Complaints == "4") +  I(Number_of_Open_Complaints == "5")
           + Total_Claim_Amount
         , data=data)

summary(fit)

#Iteration 20 : FINAL MODEL

fit<- lm(Customer_Lifetime_Value ~
           Education + I(EmploymentStatus == "Employed") +
           I(EmploymentStatus == "Unemployed") + Gender+
           Income+ Months_Since_Policy_Inception+
           Marital_Status+
           Monthly_Premium_Auto +
           I(Number_of_Open_Complaints == "1") + I(Number_of_Open_Complaints == "3")+
           Number_of_Policies + I(Number_of_Open_Complaints == "4") +
           I(Number_of_Open_Complaints == "5"), data=data)

summary(fit)

# Checking the Assumptions :
# checking Multicollinearity Assumption :
vif(fit)

# checking Normality Assumption :
resids <- fit$residuals
ad.test(resids)

# checking Homoscedasticity Assumption :
# Breusch-Pagan test
bptest(fit)

# checking Auto-Correlation Assumption :
dwt(fit)

# Get the predicted or fitted values
fitted(fit)
data$pred <- fitted(fit)

# Calculating MAPE
attach(data)
(sum((abs(Customer_Lifetime_Value-pred))/Customer_Lifetime_Value))/nrow(data)