#################################################################################
##
## R package rmgarch by Alexios Ghalanos Copyright (C) 2008-2013.
## This file is part of the R package rmgarch.
##
## The R package rmgarch is free software: you can redistribute it and/or modify
## it under the terms of the GNU General Public License as published by
## the Free Software Foundation, either version 3 of the License, or
## (at your option) any later version.
##
## The R package rmgarch 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.
##
#################################################################################
.copulasolver = function(solver, pars, fun, Ifn, ILB, IUB, gr, hessian, control, LB, UB, ...)
{
gocontrol = control
control = .copulagetcontrol(solver, control)
retval = switch(solver,
nlminb = .copulanlminbsolver(pars, fun, gr, hessian, control, LB, UB, ...),
solnp = .copulasolnpsolver(pars, fun, Ifn, ILB, IUB, control, LB, UB, ...),
lbfgs = .copulalbfgssolver(pars, fun, gr, control, LB, UB, ...),
gosolnp = .copulagosolnpsolver(pars, fun, Ifn, ILB, IUB, gocontrol, LB, UB, ...))
return(retval)
}
.copulasolnpsolver = function(pars, fun, Ifn, ILB, IUB, control, LB, UB, ...)
{
op <- options()
options(warn = 0)
ans = try(solnp(pars = pars, fun = fun, eqfun = NULL,
eqB = NULL, ineqfun = Ifn, ineqLB = ILB,
ineqUB = IUB, LB = LB, UB = UB, control = control, ...),
silent = TRUE)
if(inherits(ans,"try-error")){
sol = list()
sol$convergence = 1
sol$message = ans
sol$par = rep(NA, length(pars))
names(sol$par) = names(pars)
} else{
sol = ans
}
hess = NULL
options(op)
return(list(sol = sol, hess = hess))
}
.copulagosolnpsolver = function(pars, fun, Ifn, ILB, IUB, gocontrol, LB, UB, arglist){
control = .copulasolnpctrl(gocontrol)
gocontrol = .copulagosolnpctrl(gocontrol)
n.restarts = gocontrol$n.restarts
rseed = gocontrol$rseed
n.sim = gocontrol$n.sim
cluster = arglist$cluster
op <- options()
options(warn = 0)
ans = try(gosolnp(pars = pars, fixed = NULL, fun = fun, eqfun = NULL,
eqB = NULL, ineqfun = Ifn, ineqLB = ILB, ineqUB = IUB, LB = LB,
UB = UB, control = control, distr = rep(1, length(LB)),
distr.opt = list(), n.restarts = n.restarts, n.sim = n.sim,
cluster = cluster, rseed = rseed, arglist),
silent = TRUE)
if(inherits(ans,"try-error")){
sol = list()
sol$convergence = 1
sol$message = ans
sol$par = rep(NA, length(pars))
names(sol$par) = names(pars)
} else{
sol = ans
}
hess = NULL
options(op)
return(list(sol = sol, hess = hess))
}
.copulanlminbsolver = function(pars, fun, gr, hessian, control, LB, UB,...){
parscale = rep(1, length(pars))
ans = try(nlminb(start = pars, objective = fun, gradient = gr, hessian = hessian,
..., scale = 1/parscale, control = control, lower = LB, upper = UB), silent = TRUE)
if(inherits(ans, "try-error")){
sol = list()
sol$convergence = 1
sol$message = ans
sol$par = rep(NA, length(pars))
names(sol$par) = names(pars)
} else{
sol = ans
}
hess = NULL
return(list(sol = sol,hess = hess))
}
.copulalbfgssolver = function(pars, fun, gr, control, LB, UB, ...){
control$parscale = rep(1, length(pars))
ans = try(optim(par = pars, fn = fun, gr = gr, ...,
method = "L-BFGS-B", lower = LB, upper = UB, control = control,
hessian = TRUE),silent=TRUE)
if(inherits(ans, "try-error")){
sol = list()
sol$convergence = 1
sol$message = ans
} else{
sol = ans
}
hess = sol$hessian
return(list(sol = sol, hess = hess))
}
# default control for solvers:
.copulagetcontrol = function(solver, control)
{
ans = switch(solver,
nlminb = .copulanlminbctrl(control),
solnp = .copulasolnpctrl(control),
gosolnp = .copulagosolnpctrl(control),
lbfgs = .copulalbfgsctrl(control))
return(ans)
}
.copulanlminbctrl = function(control)
{
if(is.null(control$eval.max)) control$eval.max = 2000
if(is.null(control$iter.max)) control$iter.max = 1500
if(is.null(control$abs.tol)) control$abs.tol = 1e-20
if(is.null(control$rel.tol)) control$rel.tol = 1e-10
if(is.null(control$x.tol)) control$x.tol = 1.5e-8
if(is.null(control$step.min)) control$step.min = 2.2e-14
return(control)
}
.copulalbfgsctrl = function(control)
{
if(is.null(control$REPORT)) control$REPORT = 10
if(is.null(control$lmm)) control$lmm = 15
if(is.null(control$pgtol)) control$pgtol = 1e-8
if(is.null(control$factr)) control$factr = 1e-8
return(control)
}
.copulasolnpctrl = function(control){
# parameters check is now case independent
ans = list()
params = unlist(control)
if(is.null(params)) {
ans$rho = 0.5
ans$outer.iter = 50
ans$inner.iter = 1800
ans$delta = 1.0e-7
ans$tol = 1.0e-8
ans$trace = 0
} else{
npar = tolower(names(unlist(control)))
names(params) = npar
if(any(substr(npar, 1, 3) == "rho")) ans$rho = as.numeric(params["rho"]) else ans$rho = 0.5
if(any(substr(npar, 1, 5) == "outer.iter")) ans$outer.iter = as.numeric(params["outer.iter"]) else ans$outer.iter = 50
if(any(substr(npar, 1, 5) == "inner.iter")) ans$inner.iter = as.numeric(params["inner.iter"]) else ans$inner.iter = 1000
if(any(substr(npar, 1, 5) == "delta")) ans$delta = as.numeric(params["delta"]) else ans$delta = 1.0e-7
if(any(substr(npar, 1, 3) == "tol")) ans$tol = as.numeric(params["tol"]) else ans$tol = 1.0e-8
if(any(substr(npar, 1, 5) == "trace")) ans$trace = as.numeric(params["trace"]) else ans$trace = 0
}
return(ans)
}
.copulagosolnpctrl = function(control){
# parameters check is now case independent
ans = list()
params = unlist(control)
if(is.null(params)) {
ans$n.restarts = 1
ans$rseed
ans$n.sim = 500
} else{
npar = tolower(names(unlist(control)))
names(params) = npar
if(any(substr(npar, 1, 10) == "n.restarts")) ans$n.restarts = as.numeric(params["n.restarts"]) else ans$n.restarts = 1
if(any(substr(npar, 1, 5) == "rseed")) ans$rseed = as.numeric(params["rseed"]) else ans$rseed = NULL
if(any(substr(npar, 1, 5) == "n.sim")) ans$n.sim = as.numeric(params["n.sim"]) else ans$n.sim = 500
}
return(ans)
}
# unlike the standard aDCC model, Z must be recalculated
copula.adcccon = function(pars, arglist){
ipars = arglist$ipars
estidx = arglist$estidx
idx = arglist$model$pidx
udata = arglist$ures
m = arglist$m
Z = switch(arglist$model$modeldesc$distribution,
"mvt" = matrix(rugarch:::qstd(udata, shape = ipars[idx["mshape",1], 1]), ncol=m),
"mvnorm" = qnorm(udata))
Qbar = cov(Z)
# Take care of the Asymmetry Matrices
Ibar = .asymI(Z)
aZ = Ibar*Z
Nbar = cov(aZ)
ipars[estidx, 1] = pars
dcca = ipars[idx["dcca", 1]:idx["dcca", 2], 1]
dccb = ipars[idx["dccb", 1]:idx["dccb", 2], 1]
dccg = ipars[idx["dccg", 1]:idx["dccg", 2], 1]
Qbar2 = solve( .sqrtsymmat(Qbar) )
delta = max( eigen( Qbar2 %*% Nbar %*% Qbar2, symmetric = TRUE, only.values = TRUE )$values )
#print(delta)
#if(!is.finite(delta) | is.na(delta) |is.nan(delta) | is.complex(delta)) delta = 1
return( sum(dcca) + sum(dccb) + delta*sum(dccg) )
}
copula.dcccon = function(pars, arglist){
ipars = arglist$ipars
estidx = arglist$estidx
idx = arglist$model$pidx
ipars[estidx, 1] = pars
dcca = ipars[idx["dcca", 1]:idx["dcca", 2], 1]
dccb = ipars[idx["dccb", 1]:idx["dccb", 2], 1]
return( sum(dcca) + sum(dccb) )
}
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.