fGarch/ 0000755 0001762 0000144 00000000000 15116757102 011451 5 ustar ligges users fGarch/tests/ 0000755 0001762 0000144 00000000000 15104730075 012610 5 ustar ligges users fGarch/tests/doRUnit.R 0000644 0001762 0000144 00000001516 15104730075 014322 0 ustar ligges users #### doRUnit.R --- Run RUnit tests
####------------------------------------------------------------------------
### Origianlly follows Gregor Gojanc's example in CRAN package 'gdata'
### and the corresponding section in the R Wiki:
### http://wiki.r-project.org/rwiki/doku.php?id=developers:runit
### MM: Vastly changed: This should also be "runnable" for *installed*
## package which has no ./tests/
## ----> put the bulk of the code e.g. in ../inst/unitTests/runTests.R :
if(require("RUnit", quietly = TRUE)) {
## --- Setup ---
wd <- getwd()
pkg <- sub("\\.Rcheck$", '', basename(dirname(wd)))
library(package=pkg, character.only = TRUE)
path <- system.file("unitTests", package = pkg)
stopifnot(file.exists(path), file.info(path.expand(path))$isdir)
source(file.path(path, "runTests.R"), echo = TRUE)
}
fGarch/MD5 0000644 0001762 0000144 00000014660 15116757102 011770 0 ustar ligges users 8ddf42e368503fb9cb47500e2e44adab *ChangeLog
4f71371d19e7d6fd2e807b2d8c7fd134 *DESCRIPTION
5e5b16b802185cb5c6bd6bd0e3135dd0 *NAMESPACE
d01b5402eed9f3c05bc089883b40bb3c *NEWS.md
c7a13a689bb6a905b6bbd9d191c7f0df *R/class-fGARCH.R
0eb2fa2612486d6e24b7ca89f27003c2 *R/class-fGARCHSPEC.R
aaf7406e83fe74c1c684f7ae6d43f9e7 *R/cvar-VaR.R
97a094a106805ce33f4621ed5082266b *R/dist-absMoments.R
7b40285ba3f868b015ff905335f6d1df *R/dist-ged.R
c4703f63fc51a3420476e610ab77c7b2 *R/dist-gedFit.R
d35be82ca2b203f6e3ecb0678d6f2fb1 *R/dist-gedSlider.R
63642d3ad7536e4fa55e82e7eaa0593e *R/dist-sged.R
cd5ff5e91cc2ed186ec0e60cabb16661 *R/dist-sgedFit.R
f4b5d342a48c57b36f4a98a08f637e56 *R/dist-sgedSlider.R
485ae781212f3a00ffefd12dc1659815 *R/dist-snorm.R
ec77009ba98b3bc98362da3e9812d7e0 *R/dist-snormFit.R
0c71233088546c742adfa6de041994d1 *R/dist-snormSlider.R
2835e2bd72ebd6989b091bd0a6f13347 *R/dist-sstd.R
2a8ac9d4ac150fa20428fdaf62281ab7 *R/dist-sstdFit.R
7e19de8d0b578ea3171bc050fd81784a *R/dist-sstdSlider.R
97fbe5d8149c1a0ff7cca075826c4c5f *R/dist-std.R
de9f483be2041746c02cf755fd367145 *R/dist-stdFit.R
d06897dd68e8f25e9678913e4bd4fa90 *R/dist-stdSlider.R
224624b554b51119fc6e56b3d489277c *R/fGarch-package.R
9741bff5bd063d83445d8457cbfb9f28 *R/fGarchEnv.R
049762f686f27bcb47b7838830e277d1 *R/garch-Distribution.R
2ac7c7d170ecd4434eb201e4d04ec7bf *R/garch-FitFromFormula.R
d399b6182fe861dfef382d8428f56256 *R/garch-FitFromSpec.R
c0e91199a1630adf9eff532496639380 *R/garch-FitInternal.R
fff4d1f43e02a27c8dbb7f3a878158a7 *R/garch-GlobalVars.R
9556d8f69fddef06228e47462fbe19ea *R/garch-Gradient.R
dd3e449a6b3875a242357390634738af *R/garch-Hessian.R
e1b1fa3c676e0da11af6333cdaba9361 *R/garch-Initialization.R
2e36274f7c8891fc1c72083717a3d327 *R/garch-Sim.R
d02bb65ed394232775cc7a65bec1c7a3 *R/garch-Solver.R
effee1524457176e544a4159f06f9e65 *R/garch-SolverControl.R
774e7a534931a660f39b489e03503518 *R/garch-Spec.R
b4c216db11d187be7b33a1b9208abcb5 *R/garch-Stats.R
a0af43ada8cf98ae21ff931574f48317 *R/loglik-aparch.R
85dbb41d543618dd30d9b0514794a3b0 *R/loglik-egarch.R
6377dd1ccf33c655fd9163dd5511a4d0 *R/loglik.R
39efcefff0257a13ba13c2807d1c0b6c *R/methods-coef.R
1b8a1beeea7a7a993a169b0baf7e09f0 *R/methods-fitted.R
7f19cf78ce22bbab0b2322e96def3b39 *R/methods-formula.R
0011a6dd0b46cd74862cdc949cb2404a *R/methods-plot.R
4e940d8bba28b0a04f043c87b5fc7b28 *R/methods-predict.R
c46ae3e7eb3ca4eaffbf35b6be00ab35 *R/methods-residuals.R
0d6e705fa0f87f27e5d42c9b2f0e1094 *R/methods-show.R
c587c956b776ee0bbc21f6addb03bd47 *R/methods-summary.R
2a8962e41ed5a4de63d2fe649a9e12e3 *R/methods-update.R
1b223cf816ecee7b9fe1d26245fe9baa *R/methods-volatility.R
8da3513457c3bc1ac9d1edd0ef14d5c1 *R/mgarch-FitFromFormula.R
9edf9566b34ba6611b26b3639b8c4c04 *R/stats-tsdiag.R
5ba9ac762a4cd5bae7ed6ed15ea799f5 *R/zzz.R
f30845041a4823f724f0d700b9fde7ad *README.md
48656f3176e3fe01ac9c3107ccd8cdef *build/partial.rdb
fe75772d65e05a3b189023e372d3d1a2 *data/dem2gbp.csv.gz
58bbdc46c698bc7b97657229e8de1277 *data/sp500dge.csv.gz
ea951cd95578aafc953dcd33c7e2631d *inst/NEWS.Rd
70a0d93bc75a19be75bdab2f50fc48a0 *inst/THANKS
e7fedc2a130e66921ef3314fed34631c *inst/_pkgdown.yml
7c03c7017fafaa655d97074e21aa087b *inst/pkgdown.yml
665e719c6c9360340268b2e6ac891515 *inst/unitTests/Makefile
6daf0e9de9a62ce7c24edd2e9cd2f7e1 *inst/unitTests/runTests.R
8fa067e349485ddf6c94644cde5e3767 *inst/unitTests/runit.bugfix_6061.R
464451cc881cb5d016b445a5aa1dafb0 *inst/unitTests/runit.formula-methods.R
34ce038d4e5a9b92efb5c01751078296 *inst/unitTests/runit.garch-methods.R
14316d3164dc2ef549773a1197e97f34 *inst/unitTests/runit.garchFit.R
1bbc596063ca7584964b89c23608cb83 *inst/unitTests/runit.garchFit.algorithm.R
3107d6eaf4651d41432ccc76fbf01c6a *inst/unitTests/runit.garchFit.aparch.R
e2e025242284f7379f314d39fe81e7ef *inst/unitTests/runit.garchFit.dist.R
5d9915d560e060cbfda0b531129f167d *inst/unitTests/runit.garchFit.faked.R
b3764d2f99905a0c9d787c1f79484742 *inst/unitTests/runit.garchFit.garch.R
cc8a22d3718b70390d1ad14e36e4ac11 *inst/unitTests/runit.garchFit.init.R
1807810452bb1abf15dd3ea36eedb5d8 *inst/unitTests/runit.garchHessian.R
0cd0ecf3aebbea146c02c31b3f517af1 *inst/unitTests/runit.garchSim.R
9fd027295b05fa559e7db79b2cb01be0 *inst/unitTests/runit.garchSolver.R
d0df67b7fcd6fd58444049b69c29c2ec *inst/unitTests/runit.garchSpec.R
2db651c11a011446c606514d5022edbc *inst/unitTests/runit.plot-methods.R
afeb0877a73a8b55095082caca3a9f40 *inst/unitTests/runit.predict-methods.R
37173cf965fe63542466f8af50a12fbd *inst/unitTests/runit.sged.R
c5d4c5fc8f4880e61c1a3880e79bfba3 *inst/unitTests/runit.snorm.R
dff8337ddb27e8865b4eb21996feff85 *inst/unitTests/runit.sstd.R
8d008c88b4056574c5ac40778b80c379 *man/00fGarch-package.Rd
118fc8bc9680e4e0aad2e0aae1163803 *man/VaR.Rd
f0a337a3484a722d92902d7b5cdf846c *man/class-fGARCH.Rd
4259f79090ebc2e6b4fe246077776660 *man/class-fGARCHSPEC.Rd
e859dfb8a543235ee8136cfb19125146 *man/class-fUGARCHSPEC.Rd
9f9a9806ab4f5a405f881764f768e18b *man/dist-Slider.Rd
7ded9413775d3b586593f53276e5525e *man/dist-absMoments.Rd
9f1673b3c1faf59873cd026523f5664e *man/dist-ged.Rd
20b8bb2c1fbdedda8b10db9d2219913a *man/dist-gedFit.Rd
e58c8b6adcc7d83607bf3dbd30a2af4b *man/dist-sged.Rd
9b504e5799e7dc35479f82b4f8a0201f *man/dist-sgedFit.Rd
d534007524a59bc0c13d8174fbd72b73 *man/dist-snorm.Rd
dc8100d0a9975a84474534090807c201 *man/dist-snormFit.Rd
0144fde616bd439e681db26c76bf835f *man/dist-sstd.Rd
632e4579ffecb01795b4eb8efc076d1d *man/dist-sstdFit.Rd
37920c4de3cce5bab86c09c8fef50f7b *man/dist-std.Rd
294cd0c453c9c72af72fd8638d6485cd *man/dist-stdFit.Rd
9b30944f18aa44177f839db277e54717 *man/fGarchData.Rd
e85b4974798bb5d6637814ad3e5f426c *man/garchFit.Rd
e42ca3cab6d4fd30ba35675dc3d61513 *man/garchFitControl.Rd
bd2e01e7b5db33dee913d05580197d2c *man/garchSim.Rd
e77727456ad53183a9242d4b4b80d800 *man/garchSpec.Rd
277ae00d2592b628be2e554b2d404c2c *man/methods-coef.Rd
e877368b273d1e1bd371b8848ed5fac0 *man/methods-fitted.Rd
85f72b13fe76ad9cb64dc64b0d520ac7 *man/methods-formula.Rd
5eb9400992905923967f0abfe64037d1 *man/methods-plot.Rd
4dd9a93782b34638ffc62b0ca8ac4ad8 *man/methods-predict.Rd
eeed6ad45deab1e23d6fea0e42fbb2f0 *man/methods-residuals.Rd
5571ad61183ead5d70f46606493f0e15 *man/methods-summary.Rd
d58a80a99aa551ad469ab40587edf152 *man/methods-volatility.Rd
35d8fdda60e66294a99cf4cb39776aae *man/stats-tsdiag.Rd
3996e7c16bfb96fad295ee425815cb4d *src/Makevars
4276e1893140fa52dab90c5f041511b0 *src/dist.f
fce86d34d35e081f121901a423fc4bf1 *src/init.c
ef9c63dfb10dc8f4460e339354e73ce5 *src/llhGarch.f
39ec04391b2bb400783da91b890d064c *src/math.f
ca566e590ec30abd0718c5375e1a446f *tests/doRUnit.R
fGarch/R/ 0000755 0001762 0000144 00000000000 15116747657 011670 5 ustar ligges users fGarch/R/garch-FitInternal.R 0000644 0001762 0000144 00000033560 15104730075 015302 0 ustar ligges users
# This library is free software; you can redistribute it and/or
# modify it under the terms of the GNU Library General Public
# License as published by the Free Software Foundation; either
# version 2 of the License, or (at your option) any later version.
#
# This library 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 Library General Public License for more details.
#
# You should have received a copy of the GNU Library General
# Public License along with this library; if not, write to the
# Free Foundation, Inc., 59 Temple Place, Suite 330, Boston,
# MA 02111-1307 USA
################################################################################
# FUNCTION: DESCRIPTION:
# .garchFit Internal GARCH Fit
# .garchArgsParser Parses formula and data for garchFit
# .garchModelSeries Composes model series like in lm fits
# .garchOptimizerControl Sets default values for Garch Optimizer
# .garchNames Slot names, @fit slot, parameters and controls
################################################################################
## called from garchFit() and .ugarchFit()
.garchFit <-
function(
formula.mean = ~arma(0, 0),
formula.var = ~garch(1, 1),
series,
init.rec = c("mci", "uev"),
delta = 2,
skew = 1,
shape = 4,
cond.dist = c("norm", "snorm", "ged", "sged", "std", "sstd", "QMLE"),
include.mean = TRUE,
include.delta = NULL,
include.skew = NULL,
include.shape = NULL,
leverage = NULL,
trace = TRUE,
algorithm = c("sqp", "nlminb", "lbfgsb", "nlminb+nm", "lbfgsb+nm"),
hessian = c("ropt", "rcd"),
robust.cvar,
control = list(),
title = NULL,
description = NULL,
...)
{
# A function implemented by Diethelm Wuertz
# Description
# Fit parameters to a ARMA-GARCH model
# Arguments:
# formula.mean - ARMA(m,n) mean specification
# formula.var - GARCH/APARCH(p,q) variance specification
# series - time series
# init.rec - names type of initialization of recurrence
# mci = mu-current-iteration, or
# uev = unconditional-expected-variances
# delta - numeric value of the exponent delta
# skew - optional skewness parameter
# shape - optional shape parameter
# cond.dist - name of the conditional distribution
# include.mean - should the mean value be estimated ?
# include.delta - should the exponent be estimated ?
# leverage - should the leverage factors be estimated ?
# trace - should the optimization be traced ?
# algorithm -
# control - list of additional control parameters for solver
# title - an optional title string
# description - an optional project description string
# Note:
# This is the old version of garchFit, we keep it for backward
# compatibility.
# FUNCTION:
# Debug Mode:
DEBUG <- FALSE
# Allow only full formula specification:
if(DEBUG) print("Formula Specification ...")
fcheck = rev(all.names(formula.mean))[1]
if (fcheck == "ma") {
stop("Use full formula: arma(0,q) for ma(q)")
} else if (fcheck == "ar") {
stop("Use full formula expression: arma(p,0) for ar(p)")
}
# Check for Recursion Initialization:
if(DEBUG) print("Recursion Initialization ...")
if(init.rec[1] != "mci" & algorithm[1] != "sqp") {
stop("Algorithm only supported for mci Recursion")
}
# Get Start Time:
.StartFit <- Sys.time()
# Generate Control List - Define Default Settings:
if(DEBUG) print("Generate Control List ...")
con <- .garchOptimizerControl(algorithm, cond.dist)
con[(namc <- names(control))] <- control
# Initialize Time Series Information - Save Globally:
# keep copy of input data
if(DEBUG) print("Initialize Time Series ...")
data <- series
# scale time series
scale <- if (con$xscale) sd(series) else 1
series <- series/scale
.series <- .garchInitSeries(
formula.mean = formula.mean,
formula.var = formula.var,
cond.dist = cond.dist[1],
series = series,
scale = scale,
init.rec = init.rec[1],
h.start = NULL,
llh.start = NULL,
trace = trace)
.setfGarchEnv(.series = .series)
# Initialize Model Parameters - Save Globally:
if(DEBUG) print("Initialize Model Parameters ...")
.params <- .garchInitParameters(
formula.mean = formula.mean,
formula.var = formula.var,
delta = delta,
skew = skew,
shape = shape,
cond.dist = cond.dist[1],
include.mean = include.mean,
include.delta = include.delta,
include.skew = include.skew,
include.shape = include.shape,
leverage = leverage,
algorithm = algorithm[1],
control = con,
trace = trace)
.setfGarchEnv(.params = .params)
# Select Conditional Distribution Function:
if(DEBUG) print("Select Conditional Distribution ...")
.setfGarchEnv(.garchDist = .garchSetCondDist(cond.dist[1]))
# Estimate Model Parameters - Minimize llh, start from big value:
if(DEBUG) print("Estimate Model Parameters ...")
.setfGarchEnv(.llh = 1.0e99)
.llh <- .getfGarchEnv(".llh")
fit = .garchOptimizeLLH(hessian, robust.cvar, trace)
# Add to Fit:
if (DEBUG) print("Add to fit ...")
.series <- .getfGarchEnv(".series")
.params <- .getfGarchEnv(".params")
names(.series$h) <- NULL
fit$series = .series
fit$params = .params
# Retrieve Residuals and Fitted Values:
if (DEBUG) print("Retrieve Residuals and Fitted Values ...")
residuals = .series$z
fitted.values = .series$x - residuals
h.t = .series$h
deltainv <- 1/(if(.params$includes["delta"]) fit$par["delta"] else fit$params$delta)
sigma.t = (.series$h)^deltainv
# Standard Errors and t-Values:
if (DEBUG) print("Standard Errors and t-Values ...")
fit$cvar <-
if (robust.cvar)
(solve(fit$hessian) %*% (t(fit$gradient) %*% fit$gradient) %*%
solve(fit$hessian))
else
- solve(fit$hessian)
fit$se.coef = sqrt(diag(fit$cvar))
fit$tval = fit$coef/fit$se.coef
fit$matcoef = cbind(fit$coef, fit$se.coef,
fit$tval, 2*(1-pnorm(abs(fit$tval))))
dimnames(fit$matcoef) = list(names(fit$tval), c(" Estimate",
" Std. Error", " t value", "Pr(>|t|)"))
# Add Title and Description:
if (DEBUG) print("Add Title and Description ...")
if(is.null(title)) title = "GARCH Modelling"
if(is.null(description)) description = description() # {timeSeries}
# Total Execution Time:
Time = Sys.time() - .StartFit
if(trace) {
cat("\nTime to Estimate Parameters:\n ")
print(Time)
}
# Return Value:
new("fGARCH",
call = as.call(match.call()),
formula = formula(paste("~", formula.mean, "+", formula.var, collapse = " ")),
method = "Max Log-Likelihood Estimation",
data = data,
fit = fit,
residuals = residuals,
fitted = fitted.values,
h.t = h.t,
sigma.t = as.vector(sigma.t),
title = as.character(title),
description = as.character(description)
)
}
# ------------------------------------------------------------------------------
.garchArgsParser <-
function(formula, data, trace = FALSE)
{
# A function implemented by Diethelm Wuertz
# Description:
# Parses formula and data for garchFit
# Arguments:
# formula - ARMA(m,n) + GARCH/APARCH(p,q) mean and variance
# specification
# data - time series input as a timeSeries
# Note:
# This function returns the input formula and input data in
# proper formats. Two cases are deistinguished
# FUNCTION:
# Get Data:
allVars = unique(sort(all.vars(formula)))
allVarsTest = mean(allVars %in% colnames(data))
if (allVarsTest != 1) {
print(allVars)
print(colnames(data))
stop ("Formula and data units do not match.")
}
formula.lhs = as.character(formula)[2]
# Model frame:
mf = match.call(expand.dots = FALSE)
if(trace) {
cat("\nMatched Function Call:\n ")
print(mf)
}
m = match(c("formula", "data"), names(mf), 0)
mf = mf[c(1, m)]
# Model the timeSeries - Have a look on the function .garchModelSeries() ...
# here we cant use "model/frame" !
mf[[1]] = as.name(".garchModelSeries")
mf$fake = FALSE
mf$lhs = TRUE
if(trace) {
cat("\nModelSeries Call:\n ")
print(mf)
}
x = eval(mf, parent.frame())
if(trace) print(x)
# Now extract the modelled series ...
x = as.vector(x[, 1])
names(x) = rownames(data)
if(trace) print(x)
# Compose Mean and Variance Formula:
allLabels = attr(terms(formula), "term.labels")
if(trace) {
cat("\nAll Term Labels:\n ")
print(allLabels)
}
if(length(allLabels) == 2) {
formula.mean = as.formula(paste("~", allLabels[1]))
formula.var = as.formula(paste("~", allLabels[2]))
} else if(length(allLabels) == 1) {
formula.mean = as.formula("~ arma(0, 0)")
formula.var = as.formula(paste("~", allLabels[1]))
}
if(trace) {
cat("\nMean Formula:\n ")
print(formula.mean)
cat("\nVariance Formula:\n ")
print(formula.var)
}
# Result:
ans <- list(
formula.mean = formula.mean,
formula.var = formula.var,
formula.lhs = formula.lhs,
series = x)
# Return Value:
ans
}
# ------------------------------------------------------------------------------
.garchModelSeries <-
function (formula, data, fake = FALSE, lhs = FALSE)
{
# A function implemented by Diethelm Wuertz
# Description:
# Composes model series like in lm fits
# Arguments:
# Note:
# ... have a look on model.frame()
# FUNCTION:
# Formula:
if (length(formula) == 2) {
formula = as.formula(paste("x", formula[1], formula[2],
collapse = ""))
stopifnot(!missing(data))
}
# Missing Data ?
if (missing(data)) {
data = eval(parse(text = search()[2]), parent.frame())
}
# Numeric Data ?
if (is.numeric(data)) {
data = data.frame(data)
colnames(data) = all.vars(formula)[1]
lhs = TRUE
}
# Faked Formula ?
if (fake) {
response = as.character(formula)[2]
Call = as.character(match.call()[[2]][[3]])
method = Call[1]
predictors = Call[2]
formula = as.formula(paste(response, "~", predictors))
}
# Left-Hand-Side Formula ?
if (lhs) {
response = as.character(formula)[2]
formula = as.formula(paste(response, "~", 1))
}
# Compose Model Frame:
x = model.frame(formula, data)
# timeSeries ?
if (inherits(data, "timeSeries"))
x = timeSeries(x)
# Add control atrribute:
if (fake) {
attr(x, "control") <- method
}
# Return Value:
x
}
# ------------------------------------------------------------------------------
.garchOptimizerControl <-
function(algorithm, cond.dist)
# function(algorithm, cond.dist)
{
# A function implemented by Diethelm Wuertz
# Description:
# Sets default values for Garch Optimizer
# Arguments:
# none
# FUNCTION:
# Check llh for the standardized NIG Distribution:
llh = "internal"
if (cond.dist == "snig") llh = "filter"
# Generate Control List with Default Settings:
con <- list(
# In General:
fscale = TRUE,
xscale = TRUE,
algorithm = algorithm,
llh = llh,
# BFGS - NLMINB Algorithm:
tol1 = 1,
tol2 = 1,
# SQP Algorithm:
MIT = 2000, # maximum number of iterations (200)
MFV = 5000, # maximum number of function evaluations (500)
MET = 5, # specifies scaling strategy:
# MET=1 - no scaling
# MET=2 - preliminary scaling in 1st iteration (default)
# MET=3 - controlled scaling
# MET=4 - interval scaling
# MET=5 - permanent scaling in all iterations
MEC = 2, # correction for negative curvature:
# MEC=1 - no correction
# MEC=2 - Powell correction (default)
MER = 1, # restarts after unsuccessful variable metric updates:
# MER=0 - no restarts
# MER=1 - standard restart
MES = 4, # interpolation method selection in a line search:
# MES=1 - bisection
# MES=2 - two point quadratic interpolation
# MES=3 - three point quadratic interpolation
# MES=4 - three point cubic interpolation (default)
XMAX = 1.0e3,
TOLX = 1.0e-10,
TOLC = 1.0e-6,
TOLG = 1.0e-6,
TOLD = 1.0e-6,
TOLS = 1.0e-4,
RPF = 1.0e-2) # 1.0e-4)
# Return Value:
con
}
# ------------------------------------------------------------------------------
.garchNames <-
function(object)
{
# A function implemented by Diethelm Wuertz
# Description:
# Print slot names, @fit slot, parameters and controls
# Arguments:
# object - an object of class 'fGARCH'
# FUNCTION:
# Slot Names:
cat("\nNames - @ \n")
print(slotNames(object))
# @fit Slot:
cat("\nNames - @fit \n")
print(names(object@fit))
# Parameters:
cat("\nNames - @fit$params \n")
print(names(object@fit$params))
# Control:
cat("\nNames - @fit$params$control \n")
print(names(object@fit$params$control))
# Return Value:
invisible()
}
################################################################################
fGarch/R/garch-Solver.R 0000644 0001762 0000144 00000012332 15104730075 014327 0 ustar ligges users
# This library is free software; you can redistribute it and/or
# modify it under the terms of the GNU Library General Public
# License as published by the Free Software Foundation; either
# version 2 of the License, or (at your option) any later version.
#
# This library 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 Library General Public License for more details.
#
# You should have received a copy of the GNU Library General
# Public License along with this library; if not, write to the
# Free Foundation, Inc., 59 Temple Place, Suite 330, Boston,
# MA 02111-1307 USA
################################################################################
# FUNCTION: SOLVER:
# .garchRnlminb R coded solver nlmin
# .garchRlbgfsb R coded solver optim using method lbgfsb
# .garchRnm R coded solver nm as hybrid addon
################################################################################
.garchRnlminb <-
function(.params, .series, .garchLLH, trace)
{
# A function implemented by Diethelm Wuertz
# Description:
# Port3 nlminb R-code Solver
# Arguments:
# FUNCTION:
# Port3 nlminb R-code Solver:
if(trace) cat("\nR coded nlminb Solver: \n\n")
# Scale Function and Parameters:
INDEX = .params$index
parscale = rep(1, length = length(INDEX))
names(parscale) = names(.params$params[INDEX])
parscale["omega"] = var(.series$x)^(.params$delta/2)
parscale["mu"] = abs(mean(.series$x))
# Control:
TOL1 = .params$control$tol1
# Fit Parameters - par | objective:
fit <- nlminb(
start = .params$params[INDEX],
objective = .garchLLH,
lower = .params$U[INDEX],
upper = .params$V[INDEX],
scale = 1/parscale,
control = list(
eval.max = 2000,
iter.max = 1500,
rel.tol = 1.0e-14 * TOL1,
x.tol = 1.0e-14 * TOL1,
trace = as.integer(trace)),
fGarchEnv = FALSE) # to speed up .garchLLH
fit$value <- fit.llh <- fit$objective
names(fit$par) = names(.params$params[INDEX])
# make sure to save new h and z (important to speed up code)
.garchLLH(fit$par, trace = FALSE, fGarchEnv = TRUE)
# Result:
fit$coef <- fit$par
fit$llh <- fit$objective
# Return Value:
fit
}
# ------------------------------------------------------------------------------
.garchRlbfgsb <-
function(.params, .series, .garchLLH, trace)
{
# A function implemented by Diethelm Wuertz
# Description:
# optim[L-BFGS-B] Solver
# Arguments:
# FUNCTION:
# optim[L-BFGS-B] Solver:
if(trace) cat("\nR coded optim[L-BFGS-B] Solver: \n\n")
# Scale Function and Parameters:
INDEX = .params$index
parscale = rep(1, length = length(INDEX))
names(parscale) = names(.params$params[INDEX])
parscale["omega"] = var(.series$x)^((.params$params["delta"])/2)
# Control:
TOL1 = .params$control$tol1
# Fit Parameters - par, value:
fit <- optim(
par = .params$params[INDEX],
fn = .garchLLH,
lower = .params$U[INDEX],
upper = .params$V[INDEX],
method = "L-BFGS-B",
control = list(
parscale = parscale,
lmm = 20,
pgtol = 1.0e-11 * TOL1,
factr = 1.0 * TOL1,
trace = as.integer(trace)),
fGarchEnv = FALSE) # to speed up .garchLLH
names(fit$par) = names(.params$params[INDEX])
# make sure to save new h and z (important to speed up code)
.garchLLH(fit$par, trace = FALSE, fGarchEnv = TRUE)
# Print Hessian Matrix:
# print(fit$hessian)
# Add to Result:
fit$coef = fit$par
fit$llh = fit$value
# Return Value:
fit
}
# ------------------------------------------------------------------------------
.garchRnm <-
function(.params, .series, .garchLLH, trace)
{
# A function implemented by Diethelm Wuertz
# Description:
# Nelder-Mead as Hybrid Solver
# Arguments:
# FUNCTION:
# Nelder-Mead as Hybrid Solver:
if(trace) cat("\nR coded Nelder-Mead Hybrid Solver: \n\n")
# Scale Function and Parameters:
INDEX = .params$index
fnscale = abs(.params$llh)
parscale = abs(.params$params[INDEX])
# Control:
TOL2 = .params$control$tol2
# Fit Parameters:
fit = optim(
par = .params$params[INDEX],
fn = .garchLLH,
method = "Nelder-Mead",
control = list(
ndeps = rep(1e-14*TOL2, length = length(INDEX)),
maxit = 10000,
reltol = 1.0e-11 * TOL2,
fnscale = fnscale,
parscale = c(1, abs((.params$params[INDEX])[-1])),
trace = as.integer(trace)),
hessian = TRUE,
fGarchEnv = FALSE) # to speed up .garchLLH
names(fit$par) = names(.params$params[INDEX])
# Make sure to save new h and z: (important to speed up code)
.garchLLH(fit$par, trace = FALSE, fGarchEnv = TRUE)
# Result:
fit$coef = fit$par
fit$llh = fit$value
# Return Value:
fit
}
################################################################################
fGarch/R/dist-ged.R 0000644 0001762 0000144 00000007271 15104730075 013501 0 ustar ligges users
# This library is free software; you can redistribute it and/or
# modify it under the terms of the GNU Library General Public
# License as published by the Free Software Foundation; either
# version 2 of the License, or (at your option) any later version.
#
# This library 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 Library General Public License for more details.
#
# You should have received a copy of the GNU Library General
# Public License along with this library; if not, write to the
# Free Foundation, Inc., 59 Temple Place, Suite 330, Boston,
# MA 02111-1307 USA
################################################################################
# FUNCTION: GED DISTRIBUTION:
# dged Density for the Generalized Error Distribution
# pged Probability function for the GED
# qged Quantile function for the GED
# rged Random Number Generator for the GED
################################################################################
dged <-
function(x, mean = 0, sd = 1, nu = 2, log = FALSE)
{
# A function imlemented by Diethelm Wuertz
# Description:
# Compute the density for the
# generalized error distribution.
# FUNCTION:
# Params:
if (length(mean) == 3) {
nu = mean[3]
sd = mean[2]
mean = mean[1]
}
# Compute Density:
z = (x - mean ) / sd
lambda = sqrt ( 2^(-2/nu) * gamma(1/nu) / gamma(3/nu) )
g = nu / ( lambda * (2^(1+1/nu)) * gamma(1/nu) )
result = g * exp (-0.5*(abs(z/lambda))^nu) / sd
# Log:
if(log) result = log(result)
# Return Value
result
}
# ------------------------------------------------------------------------------
pged <-
function(q, mean = 0, sd = 1, nu = 2)
{
# A function implemented by Diethelm Wuertz
# Description:
# Compute the probability for the
# generalized error distribution.
# FUNCTION:
# Compute Probability:
q = (q - mean ) / sd
lambda = sqrt ( 2^(-2/nu) * gamma(1/nu) / gamma(3/nu) )
g = nu / ( lambda * (2^(1+1/nu)) * gamma(1/nu) )
h = 2^(1/nu) * lambda * g * gamma(1/nu) / nu
s = 0.5 * ( abs(q) / lambda )^nu
result = 0.5 + sign(q) * h * pgamma(s, 1/nu)
# Return Value:
result
}
# ------------------------------------------------------------------------------
qged <-
function(p, mean = 0, sd = 1, nu = 2)
{
# A function implemented by Diethelm Wuertz
# Description:
# Compute the quantiles for the
# generalized error distribution.
# FUNCTION:
# Compute Quantiles:
lambda = sqrt ( 2^(-2/nu) * gamma(1/nu) / gamma(3/nu) )
q = lambda * (2*qgamma((abs(2*p-1)), 1/nu))^(1/nu)
result = q*sign(2*p-1) * sd + mean
# Return Value:
result
}
# ------------------------------------------------------------------------------
rged <-
function(n, mean = 0, sd = 1, nu = 2)
{
# A function implemented by Diethelm Wuertz
# Description:
# Generate GED random deviates. The function uses the
# method based on the transformation of a Gamma random
# variable.
# FUNCTION:
# Generate Random Deviates:
lambda = sqrt ( 2^(-2/nu) * gamma(1/nu) / gamma(3/nu) )
# print(lambda)
r = rgamma(n, 1/nu)
z = lambda * (2*r)^(1/nu) * sign(runif(n)-1/2)
result = z * sd + mean
# Return Value:
result
}
################################################################################
fGarch/R/fGarchEnv.R 0000644 0001762 0000144 00000003575 15104730075 013647 0 ustar ligges users
# This library is free software; you can redistribute it and/or
# modify it under the terms of the GNU Library General Public
# License as published by the Free Software Foundation; either
# version 2 of the License, or (at your option) any later version.
#
# This library 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 Library General Public License for more details.
#
# You should have received a copy of the GNU Library General
# Public License along with this library; if not, write to the
# Free Foundation, Inc., 59 Temple Place, Suite 330, Boston,
# MA 02111-1307 USA
################################################################################
# FUNCTION: DESCRIPTION:
# .fGarchEnv Create GARCH Environment
# .setfGarchEnv Set GARCH Environment
# .getfGarchEnv Get GARCH Environment
################################################################################
.fGarchEnv <-
new.env(hash = TRUE)
# ------------------------------------------------------------------------------
.setfGarchEnv <-
function(...)
{
x <- list(...)
nm <- names(x)
if (is.null(nm) || "" %in% nm)
stop("all arguments must be named")
sapply(nm, function(nm) assign(nm, x[[nm]], envir = .fGarchEnv))
invisible()
}
# ------------------------------------------------------------------------------
.getfGarchEnv <-
function(x = NULL, unset = "")
{
if (is.null(x))
x <- ls(all.names = TRUE, envir = .fGarchEnv)
### unlist(mget(x, envir = .fGarchEnv, mode = "any",
### ifnotfound = as.list(unset)), recursive = FALSE)
get(x, envir = .fGarchEnv, mode = "any")
}
################################################################################
fGarch/R/dist-sstdSlider.R 0000644 0001762 0000144 00000007160 15104730075 015057 0 ustar ligges users
# This library is free software; you can redistribute it and/or
# modify it under the terms of the GNU Library General Public
# License as published by the Free Software Foundation; either
# version 2 of the License, or (at your option) any later version.
#
# This library 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 Library General Public License for more details.
#
# You should have received a copy of the GNU Library General
# Public License along with this library; if not, write to the
# Free Foundation, Inc., 59 Temple Place, Suite 330, Boston,
# MA 02111-1307 USA
################################################################################
# FUNCTION: DESCRIPTION:
# sstdSlider Displays Variance-1 Student-t Distribution and RVS
################################################################################
sstdSlider <-
function(type = c("dist", "rand"))
{
# A function implemented by Diethelm Wuertz
# Description:
# Displays interactively skew Student-t distribution
# Note:
# dsstd(x, mean = 0, sd = 1, nu = 5, xi = 1.5)
# FUNCTION:
# Internal Function:
refresh.code = function(...)
{
# Sliders:
N = .sliderMenu(no = 1)
mean = .sliderMenu(no = 2)
sd = .sliderMenu(no = 3)
nu = .sliderMenu(no = 4)
xi = .sliderMenu(no = 5)
invert = .sliderMenu(no = 6)
# Compute Data:
if (invert == 1) xi = round(1/xi, digits = 4)
xmin = round(qsstd(0.01, mean, sd, nu, xi), digits = 2)
xmax = round(qsstd(0.99, mean, sd, nu, xi), digits = 2)
s = seq(xmin, xmax, length = N)
y1 = dsstd(s, mean, sd, nu, xi)
y2 = psstd(s, mean, sd, nu, xi)
main1 = paste("Skew Student-t Density\n",
"mean = ", as.character(mean), " | ",
"sd = ", as.character(sd), " | ",
"nu = ", as.character(nu), " | ",
"xi = ", as.character(xi) )
main2 = paste("Skew Student-t Probability\n",
"xmin [0.01] = ", as.character(xmin), " | ",
"xmax [0.99] = ", as.character(xmax) )
# Random Numbers:
if (type[1] == "rand") {
x = rsstd(N, mean, sd, nu, xi)
}
# Frame:
par(mfrow = c(2, 1), cex = 0.7)
# Density:
if (type[1] == "rand") {
hist(x, probability = TRUE, col = "steelblue", border = "white",
breaks = "FD",
xlim = c(xmin, xmax), ylim = c(0, 1.1*max(y1)), main = main1 )
lines(s, y1, col = "orange")
} else {
plot(s, y1, type = "l", xlim = c(xmin, xmax), col = "steelblue")
abline (h = 0, lty = 3)
title(main = main1)
grid()
}
# Probability:
plot(s, y2, type = "l", xlim = c(xmin, xmax), ylim = c(0, 1),
col = "steelblue" )
abline (h = 0, lty = 3)
title(main = main2)
grid()
# Frame:
par(mfrow = c(1, 1), cex = 0.7)
}
# Open Slider Menu:
.sliderMenu(refresh.code,
names = c( "N", "mean", "sd", "nu", "xi", "xi.inv"),
minima = c( 10, -5.0, 0.1, 2.1, 1.0, 0 ),
maxima = c( 500, +5.0, 5.0, 10.0, 10.0, 1 ),
resolutions = c( 10, 0.1, 0.1, 0.1, 0.1, 1 ),
starts = c( 100, 0.0, 1.0, 5.0, 1.0, 0 )
)
}
################################################################################
fGarch/R/loglik.R 0000644 0001762 0000144 00000017037 15104730075 013263 0 ustar ligges users
# This library is free software; you can redistribute it and/or
# modify it under the terms of the GNU Library General Public
# License as published by the Free Software Foundation; either
# version 2 of the License, or (at your option) any later version.
#
# This library 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 Library General Public License for more details.
#
# You should have received a copy of the GNU Library General
# Public License along with this library; if not, write to the
# Free Foundation, Inc., 59 Temple Place, Suite 330, Boston,
# MA 02111-1307 USA
################################################################################
# FUNCTION: DESCRIPTION:
# .garchLLH Computes log-likelihood function
# .garchOptimizeLLH Opimizes log-likelihood function
################################################################################
.garchLLH <-
function(params, trace = TRUE, fGarchEnv = FALSE)
{
# A function implemented by Diethelm Wuertz
# Description:
# Compute Log-Likelihood Function
# Arguments:
# params - a named numeric vector with the model parameters
# to be optimized
# Value:
# Returns the value of the max log-likelihood function.
# Note:
# The variables '.series' and '.params' must be global available
# FUNCTION:
# DEBUG:
DEBUG = FALSE
if (DEBUG) print("Entering Function .garchLLH")
# Get Global Variables:
.series <- .getfGarchEnv(".series")
.params <- .getfGarchEnv(".params")
.garchDist <- .getfGarchEnv(".garchDist")
.llh <- .getfGarchEnv(".llh")
# How to calculate the LLH Function?
if (DEBUG) print(.params$control$llh)
if(.params$control$llh == "internal") {
if (DEBUG) print("internal")
return(.aparchLLH.internal(params, trace = trace, fGarchEnv = fGarchEnv))
} else if (.params$control$llh == "filter") {
if (DEBUG) print("filter")
return(.aparchLLH.filter(params, trace = trace, fGarchEnv = fGarchEnv))
} else if (.params$control$llh == "testing") {
if (DEBUG) print("testing")
return(.aparchLLH.testing(params, trace = trace, fGarchEnv = fGarchEnv))
} else {
stop("LLH is neither internal, testing, nor filter!")
}
}
# ------------------------------------------------------------------------------
## Called from .garchFit() in ./garch-FitInternal.R -- itself called from garchFit() and .ugarchFit()
.garchOptimizeLLH <-
function(hessian = hessian, robust.cvar, trace)
{
# A function implemented by Diethelm Wuertz
# Description:
# Opimizes the Log-Likelihood Function
# Arguments:
# hessian - the Hessian matrix
# robust.cvar - a logical
# trace - a logical
# FUNCTION:
# DEBUG:
DEBUG = FALSE
if (DEBUG) print("Entering Function .garchOptimizeLLH")
# get global variables
.series <- .getfGarchEnv(".series")
.params <- .getfGarchEnv(".params")
# Initialization:
INDEX = .params$index
# Algorithm:
algorithm = .params$control$algorithm[1]
TOL1 = .params$control$tol1
TOL2 = .params$control$tol2
if(trace) {
cat("\n\n--- START OF TRACE ---")
cat("\nSelected Algorithm:", algorithm, "\n")
}
# First Method:
# Two Step Apparoach > Trust Region + Nelder-Mead Simplex
if(algorithm == "nlminb" | algorithm == "nlminb+nm") {
fit <- .garchRnlminb(.params, .series, .garchLLH, trace)
.params$llh = fit$llh
.params$params[INDEX] = fit$par
.setfGarchEnv(.params = .params)
}
if(algorithm == "nlminb+nm") {
fit <- .garchRnm(.params, .series, .garchLLH, trace)
.params$llh = fit$llh
.params$params[INDEX] = fit$par
.setfGarchEnv(.params = .params)
}
# Second Method:
# Two Step Approach > BFGS + Nelder-Mead Simplex
if(algorithm == "lbfgsb" | algorithm == "lbfgsb+nm") {
fit <- .garchRlbfgsb(.params, .series, .garchLLH, trace)
.params$llh = fit$llh
.params$params[INDEX] = fit$par
.setfGarchEnv(.params = .params)
}
if(algorithm == "lbfgsb+nm") {
fit <- .garchRnm(.params, .series, .garchLLH, trace)
.params$llh = fit$llh
.params$params[INDEX] = fit$par
.setfGarchEnv(.params = .params)
}
# Save parameters:
.params$llh = fit$llh
.params$params[INDEX] = fit$par
.setfGarchEnv(.params = .params)
# Compute the Hessian:
if (hessian == "ropt") {
fit$hessian <- - .garchRoptimhess(par = fit$par, .params = .params,
.series = .series)
titleHessian = "R-optimhess"
} else if (hessian == "rcd") {
fit$hessian <- - .garchRCDAHessian(par = fit$par, .params = .params,
.series = .series)
titleHessian = "Central"
} else if (hessian == "rts") {
fit$hessian <- - .garchTSHessian(par = fit$par, .params = .params,
.series = .series)
titleHessian = "Two Sided"
}
# Rescale Parameters:
if (.params$control$xscale) {
.series$x <- .series$x * .series$scale
if (.params$include["mu"])
fit$coef["mu"] <- fit$par["mu"] <- .params$params["mu"] <-
.params$params["mu"]*.series$scale
if (.params$include["omega"])
fit$coef["omega"] <- fit$par["omega"] <- .params$params["omega"] <-
.params$params["omega"]*.series$scale^(.params$params["delta"])
# save changes
.setfGarchEnv(.params = .params)
.setfGarchEnv(.series = .series)
}
# Rescale Hessian Matrix:
if (.params$control$xscale) {
if (.params$include["mu"]) {
fit$hessian[,"mu"] <- fit$hessian[,"mu"] / .series$scale
fit$hessian["mu",] <- fit$hessian["mu",] / .series$scale
}
if (.params$include["omega"]) {
fit$hessian[,"omega"] <-
fit$hessian[,"omega"] / .series$scale^(.params$params["delta"])
fit$hessian["omega",] <-
fit$hessian["omega",] / .series$scale^(.params$params["delta"])
}
}
# Recalculate llh, h, z with Rescaled Parameters:
.llh <- fit$llh <- fit$value <-
.garchLLH(fit$par, trace = FALSE, fGarchEnv = TRUE)
.series <- .getfGarchEnv(".series")
# Compute the Gradient:
# YC: needs to be after the calculation of h, z !
if (robust.cvar)
fit$gradient <- - .garchRCDAGradient(
par = fit$par, .params = .params, .series = .series)
# Compute Information Criterion Statistics:
N = length(.series$x)
NPAR = length(fit$par)
fit$ics = c(
AIC = c((2*fit$value)/N + 2 * NPAR/N),
BIC = (2*fit$value)/N + NPAR * log(N)/N,
SIC = (2*fit$value)/N + log((N+2*NPAR)/N),
HQIC = (2*fit$value)/N + (2*NPAR*log(log(N)))/N )
names(fit$ics) <- c("AIC", "BIC", "SIC", "HQIC")
# Print LLH if we trace:
if(trace) {
cat("\nFinal Estimate of the Negative LLH:\n")
cat(" LLH: ", .llh, " norm LLH: ", .llh/N, "\n")
print(fit$par)
}
# Print Hessian Matrix if we trace:
if(trace) {
cat("\n", titleHessian, " Difference Approximated Hessian Matrix:\n",
sep = "")
print(fit$hessian)
cat("\n--- END OF TRACE ---\n\n")
}
# Return Value:
if (DEBUG) print("Entering Function .garchOptimizeLLH")
fit
}
################################################################################
fGarch/R/dist-sged.R 0000644 0001762 0000144 00000015504 15104730075 013662 0 ustar ligges users
# This library is free software; you can redistribute it and/or
# modify it under the terms of the GNU Library General Public
# License as published by the Free Software Foundation; either
# version 2 of the License, or (at your option) any later version.
#
# This library 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 Library General Public License for more details.
#
# You should have received a copy of the GNU Library General
# Public License along with this library; if not, write to the
# Free Foundation, Inc., 59 Temple Place, Suite 330, Boston,
# MA 02111-1307 USA
################################################################################
# FUNCTION: DESCRIPTION:
# dsged Density for the skewed GED
# psged Probability function for the skewed GED
# qsged Quantile function for the skewed GED
# rsged Random Number Generator for the skewed GED
# FUNCTION: DESCRIPTION:
# .dsged Internal, density for the skewed GED
# .psged Internal, probability function for the skewed GED
# .qsged Internal, quantile function for the skewed GED
# .rsged Internal, random Number Generator for the skewed GED
################################################################################
dsged <-
function(x, mean = 0, sd = 1, nu = 2, xi = 1.5, log = FALSE)
{
# A function implemented by Diethelm Wuertz
# Description:
# Compute the density function of the
# skewed generalized error distribution
# FUNCTION:
# Params:
if (length(mean) == 4) {
xi = mean[4]
nu = mean[3]
sd = mean[2]
mean = mean[1]
}
# Shift and Scale:
result = .dsged(x = (x-mean)/sd, nu = nu, xi = xi) / sd
# Log:
if(log) result = log(result)
# Return Value:
result
}
# ------------------------------------------------------------------------------
psged <-
function(q, mean = 0, sd = 1, nu = 2, xi = 1.5)
{
# A function implemented by Diethelm Wuertz
# Description:
# Compute the distribution function of the
# skewed generalized error distribution
# FUNCTION:
# Shift and Scale:
result = .psged(q = (q-mean)/sd, nu = nu, xi = xi)
# Return Value:
result
}
# ------------------------------------------------------------------------------
qsged <-
function(p, mean = 0, sd = 1, nu = 2, xi = 1.5)
{
# A function implemented by Diethelm Wuertz
# Description:
# Compute the quantile function of the
# skewed generalized error distribution
# FUNCTION:
# Shift and Scale:
result = .qsged(p = p, nu = nu, xi = xi) * sd + mean
# Return Value:
result
}
# ------------------------------------------------------------------------------
rsged <-
function(n, mean = 0, sd = 1, nu = 2, xi = 1.5)
{
# A function implemented by Diethelm Wuertz
# Description:
# Generate random deviates from the
# skewed generalized error distribution
# FUNCTION:
# Shift and Scale:
result = .rsged(n = n, nu = nu, xi = xi) * sd + mean
# Return Value:
result
}
################################################################################
.dsged <-
function(x, nu, xi)
{
# A function implemented by Diethelm Wuertz
# Description:
# Internal Function
# FUNCTION:
# Standardize:
lambda = sqrt ( 2^(-2/nu) * gamma(1/nu) / gamma(3/nu) )
g = nu / ( lambda * (2^(1+1/nu)) * gamma(1/nu) )
m1 = 2^(1/nu) * lambda * gamma(2/nu) / gamma(1/nu)
mu = m1*(xi-1/xi)
sigma = sqrt((1-m1^2)*(xi^2+1/xi^2) + 2*m1^2 - 1)
z = x*sigma + mu
# Compute:
Xi = xi^sign(z)
g = 2 / (xi + 1/xi)
Density = g * dged(x = z/Xi, nu=nu)
# Return Value:
Density * sigma
}
# ------------------------------------------------------------------------------
.psged <-
function(q, nu, xi)
{
# A function implemented by Diethelm Wuertz
##
## fixed by GNB, see section 'CHANGES in fGarch VERSION 4021.87, 2022-08-06', subsection
## 'BUG fixes' in NEWS.Rd.
# Description:
# Internal Function
# FUNCTION:
# Standardize:
lambda = sqrt ( 2^(-2/nu) * gamma(1/nu) / gamma(3/nu) )
g = nu / ( lambda * (2^(1+1/nu)) * gamma(1/nu) )
m1 = 2^(1/nu) * lambda * gamma(2/nu) / gamma(1/nu)
mu = m1*(xi-1/xi)
sigma = sqrt((1-m1^2)*(xi^2+1/xi^2) + 2*m1^2 - 1)
z = q*sigma + mu
# Compute:
sig <- ifelse(z >= 0, 1, -1) # note: 1 for z = 0; was sign(z)
Xi = xi^sig
g = 2 / (xi + 1/xi)
## was Probability = Heaviside(z) - sign(z) * g * Xi * pged(q = -abs(z)/Xi, nu=nu)
Probability = ifelse(z >= 0, 1, 0) - sig * g * Xi * pged(q = -abs(z)/Xi, nu=nu)
# Return Value:
Probability
}
# ------------------------------------------------------------------------------
.qsged <-
function(p, nu, xi)
{
# A function implemented by Diethelm Wuertz
##
## fixed by GNB, see section 'CHANGES in fGarch VERSION 4021.87, 2022-08-06', subsection
## 'BUG fixes' in NEWS.Rd.
# Description:
# Internal Function
# FUNCTION:
# Standardize:
lambda = sqrt ( 2^(-2/nu) * gamma(1/nu) / gamma(3/nu) )
g = nu / ( lambda * (2^(1+1/nu)) * gamma(1/nu) )
m1 = 2^(1/nu) * lambda * gamma(2/nu) / gamma(1/nu)
mu = m1*(xi-1/xi)
sigma = sqrt((1-m1^2)*(xi^2+1/xi^2) + 2*m1^2 - 1)
# Compute:
g = 2 / (xi + 1/xi)
pxi <- p - (1 / (1 + xi^2)) # not p - 1/2
sig <- sign(pxi) # not p - 1/2
Xi = xi^sig
p = (Heaviside(pxi) - sig * p) / (g * Xi) # pxi, not p - 1/2
Quantile = (-sig*qged(p=p, sd=Xi, nu=nu) - mu ) / sigma
# Return Value:
Quantile
}
# ------------------------------------------------------------------------------
.rsged <-
function(n, nu, xi)
{
# A function implemented by Diethelm Wuertz
# Description:
# Internal Function
# FUNCTION:
# Generate Random Deviates:
weight = xi / (xi + 1/xi)
z = runif(n, -weight, 1-weight)
Xi = xi^sign(z)
Random = -abs(rged(n, nu=nu))/Xi * sign(z)
# Scale:
lambda = sqrt ( 2^(-2/nu) * gamma(1/nu) / gamma(3/nu) )
g = nu / ( lambda * (2^(1+1/nu)) * gamma(1/nu) )
m1 = 2^(1/nu) * lambda * gamma(2/nu) / gamma(1/nu)
mu = m1*(xi-1/xi)
sigma = sqrt((1-m1^2)*(xi^2+1/xi^2) + 2*m1^2 - 1)
Random = (Random - mu ) / sigma
# Return value:
Random
}
################################################################################
fGarch/R/dist-sgedFit.R 0000644 0001762 0000144 00000010232 15104730075 014316 0 ustar ligges users
# This library is free software; you can redistribute it and/or
# modify it under the terms of the GNU Library General Public
# License as published by the Free Software Foundation; either
# version 2 of the License, or (at your option) any later version.
#
# This library 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 Library General Public License for more details.
#
# You should have received a copy of the GNU Library General
# Public License along with this library; if not, write to the
# Free Foundation, Inc., 59 Temple Place, Suite 330, Boston,
# MA 02111-1307 USA
################################################################################
# FUNCTION: PARAMETER ESTIMATION:
# sgedFit Fit the parameters for a skew GED distribution
################################################################################
.sgedFit <-
function(x, mean = 0, sd = 1, nu = 2, xi = 1.5,
scale = NA, doplot = TRUE, add = FALSE, span = "auto", trace = TRUE,
title = NULL, description = NULL, ...)
{
# A function implemented by Diethelm Wuertz
# Description:
# Fits parameters of skewed GED using maximum log-likelihood
# Example:
# set.seed(4711); x = rsged(500); .sgedFit(x)@fit$estimate
# FUNCTION:
# Settings:
dist = dsged
model = "SGED Parameter Estimation"
scale = "not used"
x = x.orig = as.vector(x)
# Parameter Estimation:
obj = function(x, y = x, trace) {
f <- tryCatch(-sum(log(dist(y, x[1], x[2], x[3], x[4]))), error=identity)
if (is.na(f) || inherits(f, "error")) return(1e9)
# Print Iteration Path:
if (trace) {
cat("\n Objective Function Value: ", -f)
cat("\n Parameter Estimates: ", x, "\n")
}
f }
r = nlminb(
start = c(mean = 0, sd = 1, nu = 2, xi = 1.5),
objective = obj,
lower = c(-Inf, 0, 0, 0),
upper = c( Inf, Inf, Inf, Inf),
y = x,
trace = trace)
names(r$par) <- c("mean", "sd", "nu", "xi")
# Add Title and Description:
if (is.null(title)) title = model
if (is.null(description)) description = description()
# Result:
fit = list(estimate = r$par, minimum = -r$objective, code = r$convergence)
# Optional Plot:
if (doplot) {
x = as.vector(x.orig)
if (span == "auto") span = seq(min(x), max(x), length = 501)
z = density(x, n = 100, ...)
x = z$x[z$y > 0]
y = z$y[z$y > 0]
y.points = dist(span, r$par[1], r$par[2], r$par[3], r$par[4])
ylim = log(c(min(y.points), max(y.points)))
if (add) {
lines(x = span, y = log(y.points), col = "steelblue")
} else {
plot(x, log(y), xlim = c(span[1], span[length(span)]),
ylim = ylim, type = "p", xlab = "x", ylab = "log f(x)", ...)
title(main = model)
lines(x = span, y = log(y.points), col = "steelblue")
}
}
# Return Value:
new("fDISTFIT",
call = match.call(),
model = model,
data = as.data.frame(x.orig),
fit = fit,
title = title,
description = description() )
}
# ------------------------------------------------------------------------------
sgedFit <-
function(x, ...)
{
# A function implemented by Diethelm Wuertz
# Description:
# Fit the parameters for a skew Normal distribution
# FUNCTION:
# Start Value:
start = c(mean = mean(x), sd = sqrt(var(x)), nu = 2, xi = 1)
# Log-likelihood Function:
loglik = function(x, y = x){
f = -sum(log(dsged(y, x[1], x[2], x[3], x[4])))
f }
# Minimization:
fit = nlminb(
start = start,
objective = loglik,
lower = c(-Inf, 0, 0, 0),
upper = c( Inf, Inf, Inf, Inf), y = x, ...)
# Add Names to $par
names(fit$par) = c("mean", "sd", "nu", "xi")
# Return Value:
fit
}
################################################################################
fGarch/R/garch-Distribution.R 0000644 0001762 0000144 00000013272 15104730075 015540 0 ustar ligges users
# This library is free software; you can redistribute it and/or
# modify it under the terms of the GNU Library General Public
# License as published by the Free Software Foundation; either
# version 2 of the License, or (at your option) any later version.
#
# This library 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 Library General Public License for more details.
#
# You should have received a copy of the GNU Library General
# Public License along with this library; if not, write to the
# Free Foundation, Inc., 59 Temple Place, Suite 330, Boston,
# MA 02111-1307 USA
################################################################################
# FUNCTION: DESCRIPTION:
# .garchSetCondDist Selects conditional density function
# .garchDist Defines conditional density function
# .normCondDist Normal Distribution
# .QMLECondDist QMLE with Normal Distribution
# .snormCondDist Skew Normal Distribution
# .stdCondDist Student-t Distribution
# .sstdCondDist Skew Student-t Distribution
# .gedCondDist Generalized Error Distribution
# .sgedCondDist Skew Generalized Error Distribution
# .snigCondDist Normal Inverse Gaussian Distribution
# .setfGarchEnv Set fGarch environment for conditional distribution
################################################################################
.garchSetCondDist <-
function(cond.dist = "norm")
{
# A function implemented by Diethelm Wuertz
# Description:
# Select Conditional Density Function
# Arguments:
# cond.dist - a character string with the name of the
# conditional distribution function. Valid strings are:
# "norm", "snorm", "std", "sstd", "ged", "sged", "snig".
# Value:
# Returns the selection conditional distribution function
# named uniquely '.garchDist'.
# Details:
# Implemented Distributions:
# norm - Normal Distribution: nothing to estimate
# snorm - Skew Normal Distribution: xi may be estimated
# std - Student-t Distribution: nu may be estimated
# sstd - Skew Student-t Distribution: nu and xi may be estimated
# ged - Generalized Error Distribution: nu may be estimated
# sged - Skew Generalized Error Distribution: nu and xi may be estimated
# FUNCTION:
# Compose Function:
fun = paste(".", cond.dist, "CondDist", sep = "")
.garchDist = match.fun(fun)
# Trace the Result:
if(FALSE) {
cat("\n Distribution: ", cond.dist, "\n .garchDist = ")
print(.garchDist)
}
# Return Value:
.garchDist
}
# ------------------------------------------------------------------------------
.normCondDist <-
function(z, hh, skew, shape)
{
# A function implemented by Diethelm Wuertz
# FUNCTION:
# Normal Distribution:
# Use base::dnorm
dnorm(x = z/hh, mean = 0, sd = 1) / hh
}
# ------------------------------------------------------------------------------
.QMLECondDist <-
function(z, hh, skew, shape)
{
# A function implemented by Diethelm Wuertz
# FUNCTION:
# Normal Distribution:
# Use base::dnorm
dnorm(x = z/hh, mean = 0, sd = 1) / hh
}
# ------------------------------------------------------------------------------
.snormCondDist <-
function(z, hh, skew, shape)
{
# A function implemented by Diethelm Wuertz
# FUNCTION:
# Skew Normal Distribution:
# Use fGarch::dsnorm
dsnorm(x = z/hh, mean = 0, sd = 1, xi = skew) / hh
}
# ------------------------------------------------------------------------------
.stdCondDist <-
function(z, hh, skew, shape)
{
# A function implemented by Diethelm Wuertz
# FUNCTION:
# Standardized Student-t Distribution:
# Use fGarch::dstd
dstd(x = z/hh, mean = 0, sd = 1, nu = shape) / hh
}
# ------------------------------------------------------------------------------
.sstdCondDist <-
function(z, hh, skew, shape)
{
# A function implemented by Diethelm Wuertz
# FUNCTION:
# Skew Standardized Student-t Distribution:
# Use fGarch::dsstd
dsstd(x = z/hh, mean = 0, sd = 1, nu = shape, xi = skew) / hh
}
# ------------------------------------------------------------------------------
.gedCondDist <-
function(z, hh, skew, shape)
{
# A function implemented by Diethelm Wuertz
# FUNCTION:
# Generalized Error Distribution:
# Use fGarch::dged
dged(x = z/hh, mean = 0, sd = 1, nu = shape) / hh
}
# ------------------------------------------------------------------------------
.sgedCondDist <-
function(z, hh, skew, shape)
{
# A function implemented by Diethelm Wuertz
# FUNCTION:
# Skew Generalized Error Distribution:
# Use fGarch::dsged
dsged(x = z/hh, mean = 0, sd = 1, nu = shape, xi = skew) / hh
}
# ------------------------------------------------------------------------------
.snigCondDist <-
function(z, hh, skew, shape)
{
# A function implemented by Diethelm Wuertz
# FUNCTION:
# (Skew) Normal Inverse Gaussian Distribution:
# Use fBasics::dsnig
dsnig(x = z/hh, zeta = shape, rho = skew) / hh
}
# ------------------------------------------------------------------------------
.setfGarchEnv(.garchDist = .garchSetCondDist("norm"))
################################################################################
fGarch/R/dist-snorm.R 0000644 0001762 0000144 00000021362 15104730075 014075 0 ustar ligges users
# This library is free software; you can redistribute it and/or
# modify it under the terms of the GNU Library General Public
# License as published by the Free Software Foundation; either
# version 2 of the License, or (at your option) any later version.
#
# This library 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 Library General Public License for more details.
#
# You should have received a copy of the GNU Library General
# Public License along with this library; if not, write to the
# Free Foundation, Inc., 59 Temple Place, Suite 330, Boston,
# MA 02111-1307 USA
################################################################################
# FUNCTION: DESCRIPTION:
# dsnorm Density for the skew normal Distribution
# psnorm Probability function for the skew NORM
# qsnorm Quantile function for the skew NORM
# rsnorm Random Number Generator for the skew NORM
# FUNCTION: DESCRIPTION:
# .dsnorm Internal, density for the skew normal Distribution
# .psnorm Internal, probability function for the skew NORM
# .qsnorm Internal, quantile function for the skew NORM
# .rsnorm Internal, random Number Generator for the skew NORM
################################################################################
dsnorm <-
function(x, mean = 0, sd = 1, xi = 1.5, log = FALSE)
{
# A function implemented by Diethelm Wuertz
# Description:
# Compute the density function of the skew normal distribution
# Arguments:
# x - a numeric vector of quantiles.
# mean, sd, xi - location parameter, scale parameter, and
# skewness parameter.
# FUNCTION:
# Params:
if (length(mean) == 3) {
xi = mean[3]
sd = mean[2]
mean = mean[1]
}
# Shift and Scale:
result = .dsnorm(x = (x-mean)/sd, xi = xi) / sd
# Log:
if(log) result = log(result)
# Return Value:
result
}
# ------------------------------------------------------------------------------
psnorm <-
function(q, mean = 0, sd = 1, xi = 1.5)
{
# A function implemented by Diethelm Wuertz
# Description:
# Compute the distribution function of the
# skew normal distribution
# Arguments:
# q - a numeric vector of quantiles.
# mean, sd, xi - location parameter, scale parameter, and
# skewness parameter.
# FUNCTION:
# Shift and Scale:
result = .psnorm(q = (q-mean)/sd, xi = xi)
# Return Value:
result
}
# ------------------------------------------------------------------------------
qsnorm <-
function(p, mean = 0, sd = 1, xi = 1.5)
{
# A function implemented by Diethelm Wuertz
# Description:
# Compute the quantile function of the
# skew normal distribution
# Arguments:
# p - a numeric vector of probabilities.
# mean, sd, xi - location parameter, scale parameter, and
# skewness parameter.
# FUNCTION:
# Shift and Scale:
result = .qsnorm(p = p, xi = xi) * sd + mean
# Return Value:
result
}
# ------------------------------------------------------------------------------
rsnorm <-
function(n, mean = 0, sd = 1, xi = 1.5)
{
# A function implemented by Diethelm Wuertz
# Description:
# Generate random deviates from the
# skew normal distribution
# Arguments:
# n - an integer value giving the number of observation.
# mean, sd, xi - location parameter, scale parameter, and
# skewness parameter.
# FUNCTION:
# Shift and Scale:
result = .rsnorm(n = n, xi = xi) * sd + mean
# Return Value:
result
}
################################################################################
.dsnorm <-
function(x, xi)
{
# A function implemented by Diethelm Wuertz
# Description:
# Compute the density function of the "normalized" skew
# normal distribution
# FUNCTION:
# Standardize:
m1 = 2/sqrt(2*pi)
mu = m1 * (xi - 1/xi)
sigma = sqrt((1-m1^2)*(xi^2+1/xi^2) + 2*m1^2 - 1)
z = x*sigma + mu
# Compute:
Xi = xi^sign(z)
g = 2 / (xi + 1/xi)
Density = g * dnorm(x = z/Xi)
# Return Value:
Density * sigma
}
# ------------------------------------------------------------------------------
.psnorm <-
function(q, xi)
{
# A function implemented by Diethelm Wuertz
##
## fixed by GNB, see section 'CHANGES in fGarch VERSION 4021.87, 2022-08-06', subsection
## 'BUG fixes' in NEWS.Rd.
# Description:
# Internal Function
# FUNCTION:
# Standardize:
m1 = 2/sqrt(2*pi)
mu = m1 * (xi - 1/xi)
sigma = sqrt((1-m1^2)*(xi^2+1/xi^2) + 2*m1^2 - 1)
z = q*sigma + mu
# Compute:
sig <- ifelse(z >= 0, 1, -1) # note: 1 for z = 0; was sign(z)
Xi = xi^sig # not sign(z)
g = 2 / (xi + 1/xi)
## was: Probability = Heaviside(z) - sig * g * Xi * pnorm(q = -abs(z)/Xi)
Probability = ifelse(z >= 0, 1, 0) - sig * g * Xi * pnorm(q = -abs(z)/Xi)
# Return Value:
Probability
}
.qsnorm <-
function(p, xi)
{
## A function implemented by Diethelm Wuertz
##
## Corrected at the centre part by Georgi N. Boshnakov on 2022-07-27 to fix
## bug [#6061], see section 'CHANGES in fGarch VERSION 4021.87, 2022-08-06',
## subsection 'BUG fixes' in NEWS.Rd.
##
## The old version of this and similar functions were temporarilly kept with
## suffix '_orig' but removed after the release of 4022.89, due to lack of
## (reported) problems with the fix. The examples below are kept for reference.
##
##
## Compare
## plot(function(p) .qsnorm(p, xi = 1.5), from = 0, to = 1)
## plot(function(p) .qsnorm_orig(p, xi = 1.5), from = 0, to = 1,
## col = "blue", add = TRUE)
##
## Create a quantile function by numerically inverting psnorm:
## f <- function(x, ...){ sapply(x, function(p)
## gbutils::cdf2quantile(p, cdf = psnorm, ...))}
## It agrees with the fixed qsnorm (the 2nd is right over the first, 3rd is the orig.):
## plot(function(p) .qsnorm(p, xi = 1.5), from = 0.49, to = 0.51)
## plot(f, from = 0.49, to = 0.51, add = TRUE, col = "red")
## plot(function(p) .qsnorm_orig(p, xi = 1.5), from = 0.49, to = 0.51, add = TRUE)
##
## plot(function(p) .qsnorm(p, xi = 1.5), from = 0, to = 1)
## plot(f, from = 0, to = 1, add = TRUE, col = "red")
## plot(function(p) .qsnorm_orig(p, xi = 1.5), from = 0, to = 1, add = TRUE)
## Description:
## Internal Function
## FUNCTION:
## Standardize:
m1 = 2/sqrt(2*pi)
mu = m1 * (xi - 1/xi)
sigma = sqrt((1-m1^2)*(xi^2+1/xi^2) + 2*m1^2 - 1)
## Compute:
g = 2 / (xi + 1/xi)
pxi <- p - (1 / (1 + xi^2)) # not p - 1/2
sig <- sign(pxi) # not p - 1/2
Xi = xi^sig
p = (Heaviside(pxi) - sig * p) / (g * Xi) # pxi, not p - 1/2
## GNB:
## Fixed: BUG [#6061] fGarch::qsnorm() incorrect around p=0.5
##
## This has, in general, discontinuity for p = 1/2, since then sig = 0.
## Note that the original p = 1/2 is transformed above to 1/(2*g*Xi),
## so qnorm() doesn't necessarilly give 1/2 when p = 1/2.
##
## Note also that p can be a vector.
##
## Further note: the issue at p = 0.5 is a separate problem. Zooming in
## shows that the quantile is not continuous at p = 0.5 and to the right of
## 0.5 the values are smaller than just to the left of 0.5 up to around 0.51.
##
## SOLUTION(?): The error seems to be that sign() and Heaviside should compare to
## 1/(1+1/xi^2), not 0.5 which is correct only for xi = 1.
##
Quantile = (-sig * qnorm(p = p, sd = Xi) - mu ) / sigma
## Return Value:
Quantile
}
# ------------------------------------------------------------------------------
.rsnorm <-
function(n, xi)
{
# A function implemented by Diethelm Wuertz
# Description:
# Internal Function
# FUNCTION:
# Generate Random Deviates:
weight = xi / (xi + 1/xi)
z = runif(n, -weight, 1-weight)
Xi = xi^sign(z)
Random = -abs(rnorm(n))/Xi * sign(z)
# Scale:
m1 = 2/sqrt(2*pi)
mu = m1 * (xi - 1/xi)
sigma = sqrt((1-m1^2)*(xi^2+1/xi^2) + 2*m1^2 - 1)
Random = (Random - mu ) / sigma
# Return value:
Random
}
################################################################################
fGarch/R/dist-sstdFit.R 0000644 0001762 0000144 00000010436 15104730075 014357 0 ustar ligges users
# This library is free software; you can redistribute it and/or
# modify it under the terms of the GNU Library General Public
# License as published by the Free Software Foundation; either
# version 2 of the License, or (at your option) any later version.
#
# This library 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 Library General Public License for more details.
#
# You should have received a copy of the GNU Library General
# Public License along with this library; if not, write to the
# Free Foundation, Inc., 59 Temple Place, Suite 330, Boston,
# MA 02111-1307 USA
################################################################################
# FUNCTION: PARAMETER ESTIMATION:
# sstdFit Fit the parameters for a skew Sudent-t distribution
################################################################################
.sstdFit <-
function(x, mean = 0, sd = 1, xi = 1.5,
scale = NA, doplot = TRUE, add = FALSE, span = "auto", trace = TRUE,
title = NULL, description = NULL, ...)
{
# A function implemented by Diethelm Wuertz
# Description:
# Fits parameters of a Skew Student-t using maximum log-likelihood
# Example:
# set.seed(4711); x = rsnorm(500); .snormFit(x)@fit$estimate
# FUNCTION:
# Settings:
dist = dsstd
model = "SSTD Parameter Estimation"
scale = "not used"
x = x.orig = as.vector(x)
# Parameter Estimation:
obj = function(x, y = x, trace) {
f <- tryCatch(-sum(log(dist(y, x[1], x[2], x[3], x[4]))), error=identity)
if (is.na(f) || inherits(f, "error")) return(1e9)
# Print Iteration Path:
if (trace) {
cat("\n Objective Function Value: ", -f)
cat("\n Parameter Estimates: ", x, "\n")
}
f }
r = nlminb(
start = c(mean = 0, sd = 1, nu = 5, xi = 1.5),
objective = obj,
lower = c(-Inf, 0, 2, 0),
upper = c( Inf, Inf, Inf, Inf),
y = x,
trace = trace)
names(r$par) <- c("mean", "sd", "nu", "xi")
# Add Title and Description:
if (is.null(title)) title = model
if (is.null(description)) description = description()
# Result:
fit = list(estimate = r$par, minimum = -r$objective, code = r$convergence)
# Optional Plot:
if (doplot) {
x = as.vector(x.orig)
if (span == "auto") span = seq(min(x), max(x), length = 501)
z = density(x, n = 100, ...)
x = z$x[z$y > 0]
y = z$y[z$y > 0]
y.points = dist(span, r$par[1], r$par[2], r$par[3], r$par[4])
ylim = log(c(min(y.points), max(y.points)))
if (add) {
lines(x = span, y = log(y.points), col = "steelblue")
} else {
plot(x, log(y), xlim = c(span[1], span[length(span)]),
ylim = ylim, type = "p", xlab = "x", ylab = "log f(x)", ...)
title(main = model)
lines(x = span, y = log(y.points), col = "steelblue")
}
}
# Return Value:
new("fDISTFIT",
call = match.call(),
model = model,
data = as.data.frame(x.orig),
fit = fit,
title = title,
description = description() )
}
# ------------------------------------------------------------------------------
sstdFit <-
function(x, ...)
{
# A function implemented by Diethelm Wuertz
# Description:
# Fit the parameters for a skew Sudent-t distribution
# with unit variance
# FUNCTION:
# For S-Plus compatibility:
if (!exists("nlm"))
nlm = function (f, p, ...) nlminb(start = p, objective = f, ...)
# Start Value:
p = c(mean = mean(x), sd = sqrt(var(x)), nu = 4, xi = 1)
# Log-likelihood Function:
loglik = function(x, y = x){
f = -sum(log(dsstd(y, x[1], x[2], x[3], x[4])))
f }
# Minimization:
fit = nlm(
f = loglik,
p = p,
y = x, ...)
Names = c("mean", "sd", "nu", "xi")
names(fit$estimate) = Names
names(fit$gradient) = Names
# Return Value:
fit
}
################################################################################# ------------------------------------------------------------------------------
fGarch/R/garch-Sim.R 0000644 0001762 0000144 00000011420 15104730075 013602 0 ustar ligges users
# This library is free software; you can redistribute it and/or
# modify it under the terms of the GNU Library General Public
# License as published by the Free Software Foundation; either
# version 2 of the License, or (at your option) any later version.
#
# This library 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 Library General Public License for more details.
#
# You should have received a copy of the GNU Library General
# Public License along with this library; if not, write to the
# Free Foundation, Inc., 59 Temple Place, Suite 330, Boston,
# MA 02111-1307 USA
################################################################################
# FUNCTION: SIMULATION:
# garchSim Simulates a GARCH/APARCH process
################################################################################
garchSim <-
function(spec = garchSpec(), n = 100, n.start = 100,
extended = FALSE)
{
# A function implemented by Diethelm Wuertz
# Description:
# Simulates a time series process from the GARCH family
# Arguments:
# model - a specification object of class 'fGARCHSPEC' as
# returned by the function \code{garchSpec}:
# ar - a vector of autoregressive coefficients of
# length m for the ARMA specification,
# ma - a vector of moving average coefficients of
# length n for the ARMA specification,
# omega - the variance value for GARCH/APARCH
# specification,
# alpha - a vector of autoregressive coefficients
# of length p for the GARCH/APARCH specification,
# gamma - a vector of leverage coefficients of
# length p for the APARCH specification,
# beta - a vector of moving average coefficients of
# length q for the GARCH/APARCH specification,
# mu - the intercept for ARMA specification (mean=mu/(1-sum(ar))),
# delta - the exponent value used in the variance
# equation.
# skew - a numeric value for the skew parameter.
# shape - a numeric value for the shape parameter.
# n - an integer, the length of the series
# n.start - the length of the warm-up sequence to reduce the
# effect of initial conditions.
# FUNCTION:
# Specification:
stopifnot(inherits(spec, "fGARCHSPEC"))
model = spec@model
# Random Seed:
if (spec@rseed != 0) set.seed(spec@rseed)
# Enlarge Series:
n = n + n.start
# Create Innovations:
if (spec@distribution == "norm")
z = rnorm(n)
if (spec@distribution == "ged")
z = rged(n, nu = model$shape)
if (spec@distribution == "std")
z = rstd(n, nu = model$shape)
if (spec@distribution == "snorm")
z = rsnorm(n, xi = model$skew)
if (spec@distribution == "sged")
z = rsged(n, nu = model$shape, xi = model$skew)
if (spec@distribution == "sstd")
z = rsstd(n, nu = model$shape, xi = model$skew)
# Expand to whole Sample:
delta = model$delta
z = c(rev(spec@presample[, 1]), z)
h = c(rev(spec@presample[, 2]), rep(NA, times = n))
y = c(rev(spec@presample[, 3]), rep(NA, times = n))
m = length(spec@presample[, 1])
names(z) = names(h) = names(y) = NULL
# Determine Coefficients:
mu = model$mu
ar = model$ar
ma = model$ma
omega = model$omega
alpha = model$alpha
gamma = model$gamma
beta = model$beta
deltainv = 1/delta
# Determine Orders:
order.ar = length(ar)
order.ma = length(ma)
order.alpha = length(alpha)
order.beta = length(beta)
# Iterate GARCH / APARCH Model:
eps = h^deltainv*z
for (i in (m+1):(n+m)) {
h[i] = omega +
sum(alpha*(abs(eps[i-(1:order.alpha)]) -
gamma*(eps[i-(1:order.alpha)]))^delta) +
sum(beta*h[i-(1:order.beta)])
eps[i] = h[i]^deltainv * z[i]
y[i] = mu +
sum(ar*y[i-(1:order.ar)]) +
sum(ma*eps[i-(1:order.ma)]) + eps[i]
}
# Sample:
data = cbind(
z = z[(m+1):(n+m)],
sigma = h[(m+1):(n+m)]^deltainv,
y = y[(m+1):(n+m)])
rownames(data) = as.character(1:n)
data = data[-(1:n.start),]
# Return Values:
from <-
timeDate(format(Sys.time(), format = "%Y-%m-%d")) - NROW(data)*24*3600
charvec <- timeSequence(from = from, length.out = NROW(data))
ans <- timeSeries(data = data[, c(3,2,1)], charvec = charvec)
colnames(ans) <- c("garch", "sigma", "eps")
ans <- if (extended) ans else ans[,"garch"]
attr(ans, "control") <- list(garchSpec = spec)
# Return Value:
ans
}
################################################################################
fGarch/R/cvar-VaR.R 0000644 0001762 0000144 00000002531 15104730075 013414 0 ustar ligges users ## GNB TODO: this is to get thing going
qfun_fGarch <- function(dist, parameters){
skew <- parameters["skew"]
shape <- parameters["shape"]
switch(dist,
norm = qnorm,
snorm = function(p, ...) qsnorm(p, xi = skew, ...), # TODO: do we need '...'?
ged = function(p, ...) qged(p, nu = shape, ...),
sged = function(p, ...) qsged(p, nu = shape, xi = skew, ...),
std = function(p, ...) qstd(p, nu = shape, ...),
sstd = function(p, ...) qsstd(p, nu = shape, xi = skew, ...),
snig = function(p, ...) qsnig(p, zeta = shape, rho = skew, ...),
## default
stop("distribution 'dist' not implemented here")
)
}
VaR.fGARCH <- function(dist, p_loss = 0.05, ..., tol = .Machine$double.eps^0.5) {
stopifnot(inherits(dist, "fGARCH"))
mu_t <- dist@fitted
sigma_t <- dist@sigma.t
cond_dist <- dist@fit$params$cond.dist
qf <- qfun_fGarch(cond_dist, coef(dist))
cvar::VaR_qf(qf, p_loss, intercept = mu_t, slope = sigma_t, tol = tol)
}
ES.fGARCH <- function (dist, p_loss = 0.05, ...) {
stopifnot(inherits(dist, "fGARCH"))
mu_t <- dist@fitted
sigma_t <- dist@sigma.t
cond_dist <- dist@fit$params$cond.dist
qf <- qfun_fGarch(cond_dist, coef(dist))
cvar::ES(qf, p_loss, intercept = mu_t, slope = sigma_t)
}
fGarch/R/garch-Hessian.R 0000644 0001762 0000144 00000013347 15116747657 014477 0 ustar ligges users
# This library is free software; you can redistribute it and/or
# modify it under the terms of the GNU Library General Public
# License as published by the Free Software Foundation; either
# version 2 of the License, or (at your option) any later version.
#
# This library 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 Library General Public License for more details.
#
# You should have received a copy of the GNU Library General
# Public License along with this library; if not, write to the
# Free Foundation, Inc., 59 Temple Place, Suite 330, Boston,
# MA 02111-1307 USA
################################################################################
# FUNCTION: PARAMETER ESTIMATION:
# .garchRoptimhess Uses R internal optimhess function
# .garchRCDAHessian Computes R coded CDA Hessian matrix
# .garchRTSHessian Computes R coded Two Sided Hessian matrix
# .hessian2sided Function called from .garchRTSHessian
# REQUIRED:
# Matrix
################################################################################
## These are called from .garchOptimizeLLH() -->> ./loglik.R
.garchRoptimhess <-
function(par, .params, .series, eps = 1.0e-4)
{
# A function implemeted by Diethelm Wuertz
# Description:
# Compute Hessian via R's function optimHess()
# Arguments:
# par -
# .params -
# .series -
# eps -
# FUNCTION:
# Take Time:
.StartHessian <- Sys.time()
# Compute Hessian:
H <- optimHess(par, .garchLLH)
H <- 0.5 * (H + t(H))
nm <- names(par)
dimnames(H) <- list(nm, nm)
# Elapsed Time:
time = Sys.time() - .StartHessian
attr(H, "time") = time
# Return Value:
H
}
# ------------------------------------------------------------------------------
.garchRCDAHessian <-
function(par, .params, .series, eps = 1.0e-4)
{
# A function implemented by Diethelm Wuertz
# Description:
# Compute CDA (central difference approximated) Hessian
# Arguments:
# par -
# .params -
# .series -
# eps -
# Reference:
# http://status.sph.umich.edu/computing/manuals/sas8/stat/chap46/sect26.htm
# FUNCTION:
# Take start time
.StartHessian <- Sys.time()
# Algorithm:
algorithm = .params$control$algorithm[1]
.trace = FALSE
# Compute Hessian:
eps = eps * par
n = length(par)
H = matrix(0, ncol = n, nrow = n)
for (i in 1:n) {
for (j in 1:n) {
x1 = x2 = x3 = x4 = par
x1[i] = x1[i] + eps[i]
x1[j] = x1[j] + eps[j]
x2[i] = x2[i] + eps[i]
x2[j] = x2[j] - eps[j]
x3[i] = x3[i] - eps[i]
x3[j] = x3[j] + eps[j]
x4[i] = x4[i] - eps[i]
x4[j] = x4[j] - eps[j]
H[i, j] = (
.garchLLH(x1, .trace) -
.garchLLH(x2, .trace) -
.garchLLH(x3, .trace) +
.garchLLH(x4, .trace) ) / (4*eps[i]*eps[j])
}
}
colnames(H) = rownames(H) = names(par)
# Attribute execution time:
time = Sys.time() - .StartHessian
attr(H, "time") = time
# Return Value:
H
}
# ------------------------------------------------------------------------------
.garchTSHessian <-
function(par, .params, .series, eps = NA)
{
# A function implemented by Diethelm Wuertz
# Description:
# Compute two sided (TS) approximated Hessian
# Arguments:
# par -
# .params -
# .series -
# eps - not used
# FUNCTION:
# Take start time
.StartHessian <- Sys.time()
# Algorithm:
algorithm = .params$control$algorithm[1]
# Compute Hessian:
H <- .hessian2sided(f = .garchLLH, x = par, trace = FALSE, fGarchEnv = FALSE)
colnames(H) = rownames(H) = names(par)
# Attribute execution time:
time = Sys.time() - .StartHessian
attr(H, "time") = time
# Return Value:
H
}
# ------------------------------------------------------------------------------
.hessian2sided <-
function(f, x, ...)
{
# A function adapted from Kevin Sheppard's Matlab garch toolbox
# ... implemented by Alexios Ghalanos in his rgarch package
# ... R port for Rmetrics' fGarch by Diethelm Wuertz
# Description:
# Computes two sided (TS) approximated Hessian
# Arguments:
# f -
# x -
# Notes:
# requires package Matrix (added as suggestion)
# FUNCTION:
# Settings:
n <- length(x)
fx <- f(x, ...)
eps <- .Machine$double.eps
# Compute the stepsize (h)
h = eps^(1/3) *
apply( as.data.frame(x), 1, FUN = function(z) max(abs(z), 1.0e-2))
xh = x + h
h = xh - x
ee <- Matrix::Matrix(diag(h), sparse = TRUE)
# Compute forward and backward steps:
gm <- gp <- numeric(n)
for(i in 1:n) {
e.i <- ee[,i]
gp[i] <- f(x + e.i, ...)
gm[i] <- f(x - e.i, ...)
}
H = h %*% t(h)
Hm = H
Hp = H
# Compute "double" forward and backward steps:
for(i in 1:n){ ## FIXME (speedup!) -- vectorize or even work with FULL n x n matrices H, Hp, Hm
e.i <- ee[,i]
for(j in i:n){
e.j <- ee[,j]
Hp[j, i] <- Hp[i, j] <- f(x + e.i + e.j, ...)
Hm[j, i] <- Hm[i, j] <- f(x - e.i - e.j, ...)
}
}
# Compute the hessian:
for(i in 1:n) { ## FIXME (speedup!) -- vectorize or even work with FULL n x n matrices H, Hp, Hm
for(j in i:n) { ## 1 <= i <= j <= n
H[j, i] = H[i, j] =
.5* ((Hp[i, j] - gp[i] - gp[j] + fx + fx - gm[i] - gm[j] + Hm[i, j]) / H[i, j])
}
}
# Return the Hessian matrix:
H
}
fGarch/R/garch-GlobalVars.R 0000644 0001762 0000144 00000002741 15104730075 015114 0 ustar ligges users
# This library is free software; you can redistribute it and/or
# modify it under the terms of the GNU Library General Public
# License as published by the Free Software Foundation; either
# version 2 of the License, or (at your option) any later version.
#
# This library 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 Library General Public License for more details.
#
# You should have received a copy of the GNU Library General
# Public License along with this library; if not, write to the
# Free Foundation, Inc., 59 Temple Place, Suite 330, Boston,
# MA 02111-1307 USA
################################################################################
# FUNCTION: DESCRIPTION:
# .setfGarchEnv Set Global Vars
# .garchArgsParser Parses formula and data for garchFit
# .garchOptimizerControl Sets default values for Garch Optimizer
# .garchFit ... old Version, still in use by garchFit()
# .garchNames Slot names, @fit slot, parameters and controls
################################################################################
.setfGarchEnv(.llh = 1e99)
.setfGarchEnv(.garchDist = NA)
.setfGarchEnv(.params = NA)
.setfGarchEnv(.series = NA)
.setfGarchEnv(.trace = NA)
################################################################################
fGarch/R/stats-tsdiag.R 0000644 0001762 0000144 00000022146 15104730075 014406 0 ustar ligges users ## Author: Georgi Boshnakov
## based on tsdiag.Sarima from package 'sarima'
.tsdiag_choices <- c(
## ## "classic (std. residuals, acf, portmanteau p-values)",
## "residuals",
## "acf of residuals",
## "p values for Ljung-Box statistic",
## "p values for Li-McLeod statistic",
## "p values for Box-Pierce statistic",
## "pacf of residuals"
## use 7-13; for consistency with the plot method we would like to keep the same numbers
## but this seems not possible with menu().
##
## .plot.garch.1 Plot Time Series
## .plot.garch.2 Plot Conditional SD
## .plot.garch.3 Plot Series with 2 Conditional SD Superimposed
## .plot.garch.4 Plot ACF of Observations
## .plot.garch.5 Plot ACF of Squared Observations
## .plot.garch.6 Plot Cross Correlation
"Residuals", # .plot.garch.7
"Conditional SDs", # .plot.garch.8
"Standardized Residuals", # .plot.garch.9
"ACF of Standardized Residuals", # .plot.garch.10
"ACF of Squared Standardized Residuals", # .plot.garch.11
"Cross Correlation between r^2 and r", # .plot.garch.12
"QQ-Plot of Standardized Residuals" # .plot.garch.13
## TODO: pacf of r and r^2
)
## tsdiag.Sarima:
##
## { # 1: "residuals",
## plot(stdres, type = "h", main = "Standardized Residuals", ylab = "")
## abline(h = 0)
## #acf(err, main = "ACF of residuals from model", lag.max = lag.max)
## #pacf(err, main = "PACF of residuals from model", lag.max = lag.max)
## },
## { # 2: "ACF of residuals"
## ## acf
## acf(err, plot = TRUE, main = "ACF of Residuals", lag.max = lag.max, na.action = na.pass)
## # acf(cdf, main = "", lag.max = lag.max)
## # title("ACF of" ~U[t])
## # pacf(cdf, main = "", lag.max = lag.max)
## # title("PACF of" ~U[t])
## },
## { # 3: "Ljung-Box p-values"
## acftest <- acfIidTest(sacf, npar = fitdf, nlags = 1:nlag, method = "LjungBox",
## interval = NULL)
## res[["LjungBox"]] <- acftest
## },
## { # 4: "Li-McLeod p-values"
## acftest <- acfIidTest(sacf, npar = fitdf, nlags = 1:nlag, method = "LiMcLeod",
## interval = NULL)
## res[["LiMcLeod"]] <- acftest
## },
## { # 5: "Box-Pierce p-values"
## acftest <- acfIidTest(sacf, npar = fitdf, nlags = 1:nlag, method = "BoxPierce",
## interval = NULL)
## res[["BoxPierce"]] <- acftest
## },
## { # 6: "PACF of residuals"
## ## acf
## pacf(err, plot = TRUE, main = "PACF of Residuals", lag.max = lag.max, na.action = na.pass)
## },
## # { # 4: "ACF/Histogram of tau_residuals"
## # acf(err2, main = "ACF of tau_residuals", lag.max = lag.max)
## # hist(err2, freq = FALSE, main = "Histogram of tau_residuals", xlab = "",
## # ylim = c(0, 0.5))
## # lines(seq(-5, 5, .01), dnorm(seq(-5, 5, .01)), col = "red")
## # }
tsdiag.fGARCH <- function(object, gof.lag = NULL, ask = FALSE, ..., plot = c(4L, 5L, 7L),
layout = NULL)
{
## Georgi Boshnakov
n_per_page <- if(is.null(layout))
3
else
## length(layout[[1]])
do.call("layout", layout)
if(is.null(gof.lag))
gof.lag <- 20 # :TODO: NOTE: arbitrary value
else if(!is.numeric(gof.lag))
stop("'gof.lag' must be numeric and contain positive integers")
lag.max <- max(gof.lag)
sres <- residuals(object, standardize = TRUE)
sres2 <- sres^2
choices <- .tsdiag_choices
chnum <- 1:length(choices)
if(!isTRUE(plot)){ # plot is typically numeric index here;
choices <- choices[plot] # FALSE or NULL give zero length result, so no plots
chnum <- chnum[plot]
if(anyNA(choices)){
warning("'plot' should be TRUE/FALSE or vector of positive integers <= ",
length(.tsdiag_choices), ",\n", "ignoring non-existent values")
chnum <- chnum[!is.na(choices)]
choices <- choices[!is.na(choices)]
}
}
if(length(choices) > 0){
old.par <- par(no.readonly = TRUE)
on.exit(par(old.par)) # restore graphics parameters before exiting.
ask_user <- interactive() && (ask || length(choices) > n_per_page)
## adjust n_per_page if 'layout' is missing
if(is.null(layout)) {
n_per_page <- if(ask_user)
## was: layout(matrix(1:3, ncol = 1))
layout(matrix(1:min(3, length(choices)), ncol = 1))
else
layout(matrix(1:min(3, length(choices)), ncol = 1))
}
choice_title <- "Select a plot number or 0 to exit"
ch_index <- if(length(choices) == 1)
1
else if(ask)
menu(choices, title = choice_title)
else if(!identical(plot, FALSE))
1
else
integer(0)
choice <- chnum[ch_index]
## ## precompute common stuff for portmanteau tests
## nlag <- gof.lag
## pval <- numeric(nlag)
## fitdf <- if(inherits(object, "Sarima"))
## length(object$internal$nonfixed)
## else if(inherits(object, "Arima"))
## sum(object$arma[1:4]) # object$arma is: p, q, p_s. q_s, s, d, d_s
## else
## 0
## # for(i in 1L:nlag)
## # pval[i] <- Box.test(err, i, type="Ljung-Box",
## # fitdf = ifelse(i > fitdf, fitdf, i - 1))$p.value
## sacf <- autocorrelations(err, maxlag = nlag) # deal with NA's?
res <- list(residuals = sres)
while(length(choice) != 0){
switch(choice,
.plot.garch.7 (object), # "Residuals",
.plot.garch.8 (object), # "Conditional SDs",
.plot.garch.9 (object), # "Standardized Residuals",
.plot.garch.10(object), # "ACF of Standardized Residuals",
.plot.garch.11(object), # "ACF of Squared Standardized Residuals",
.plot.garch.12(object), # "Cross Correlation between r^2 and r",
.plot.garch.13(object) # "QQ-Plot of Standardized Residuals"
)
if(length(chnum) == 1) # length(choices) == 1
break
if(ask_user) { # was: interactive() && (ask || length(choices) > n_per_page)
ch_index <- menu(choices, title = choice_title)
choice <- chnum[ch_index]
} else{
## just plot the next one
## Note: this doesn't update ch_index
chnum <- chnum[-1]
choice <- chnum[1]
}
}
}
.f <- function(x)
c(statistic = as.vector(x$statistic), p.value = x$p.value)
if(requireNamespace("goftest", quietly = TRUE)) {
gofargs <- .resid_with_dist(object)
res$gof <- rbind(
"Anderson-Darling" = .f(do.call(goftest::ad.test, gofargs)),
"Cramer-vonMises" = .f(do.call(goftest::cvm.test, gofargs)) )
gofargs$estimated <- FALSE
res$gof_composite <- rbind(
"Anderson-Darling" = .f(do.call(goftest::ad.test, gofargs)),
"Cramer-vonMises" = .f(do.call(goftest::cvm.test, gofargs)) )
} else{
message("Please install package 'goftest' for additional tests")
}
class(res) <- "tsdiag_fGARCH"
invisible(res)
}
print.tsdiag_fGARCH <- function(x, ...){
## for now just drop the values of the residuals
x <- x[names(x) != "residuals"]
for(s in names(x)) {
cat(paste0( "\n", s, ":", "\n"))
print(x[[s]])
}
}
## GNB, based on .plot.garch.13
## for tests in 'goftest'
.resid_with_dist <- function(x) {
sres <- residuals(x, standardize = TRUE)
cond_dist <- x@fit$params$cond.dist
cond_cdf <- paste("p", cond_dist, sep = "")
parNames <- names(x@fit$par)
skew <-
if ("skew" %in% parNames)
x@fit$par["skew"]
else
x@fit$params$skew
shape <-
if ("shape" %in% parNames)
x@fit$par["shape"]
else
x@fit$params$shape
res <- list(x = sres)
res$null <- if (cond_dist == "QMLE")
"pnorm"
else
cond_cdf
if (cond_dist == "std" || cond_dist == "ged")
res$nu <- shape
else if (cond_dist == "snorm")
res$xi <- skew
else if (cond_dist == "sstd" || cond_dist == "sged") {
res$xi <- skew
res$nu <- shape
} else if (cond_dist == "snig") {
res$rho <- skew
res$zeta <- shape
}
res$estimated <- TRUE
res$nullname <- cond_dist
res
}
fGarch/R/loglik-aparch.R 0000644 0001762 0000144 00000041071 15104730075 014512 0 ustar ligges users
# This library is free software; you can redistribute it and/or
# modify it under the terms of the GNU Library General Public
# License as published by the Free Software Foundation; either
# version 2 of the License, or (at your option) any later version.
#
# This library 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 Library General Public License for more details.
#
# You should have received a copy of the GNU Library General
# Public License along with this library; if not, write to the
# Free Foundation, Inc., 59 Temple Place, Suite 330, Boston,
# MA 02111-1307 USA
################################################################################
# FUNCTION: DESCRIPTION:
# .aparchLLH.internal Internal ARMA-APARCH recursion done by Fortran Code
# .aparchLLH.filter Fast approach using the filter function in R
# .aparchLLH.testing Simple double loops over time and order in R
################################################################################
.aparchLLH.internal <-
function(params, trace = TRUE, fGarchEnv = TRUE)
{
# A function implemented by Diethelm Wuertz
# Description:
# Internal ARMA-APARCH recursion done by Fortran Code
# Arguments:
# params - a named numeric vector with the model parameters
# to be optimized
# trace -
# fGarchEnv -
# Value:
# Returns the value of the max log-likelihood function.
# Note:
# The variables '.series' and '.params' must be global available
# FUNCTION:
# DEBUG:
DEBUG = FALSE
if (DEBUG) print("Entering Function .garchLLH.internal")
# Get Global Variables:
.series <- .getfGarchEnv(".series")
.params <- .getfGarchEnv(".params")
.garchDist <- .getfGarchEnv(".garchDist")
.llh <- .getfGarchEnv(".llh")
# How to calculate the LLH Function?
if (DEBUG) print(.params$control$llh)
if(.params$control$llh == "internal") {
INDEX <- .params$index
MDIST <- c(norm = 10, QMLE = 10, snorm = 11, std = 20, sstd = 21,
ged = 30, sged = 31)[.params$cond.dist]
if(.params$control$fscale) NORM <- length(.series$x) else NORM = 1
REC <- 1
if(.series$init.rec == "uev") REC <- 2
MYPAR <- c(
REC = REC, # How to initialize
LEV = as.integer(.params$leverage), # Include Leverage 0|1
MEAN = as.integer(.params$includes["mu"]), # Include Mean 0|1
DELTA = as.integer(.params$includes["delta"]),# Include Delta 0|1
SKEW = as.integer(.params$includes["skew"]), # Include Skew 0|1
SHAPE = as.integer(.params$includes["shape"]),# Include Shape 0|1
ORDER = .series$order, # Order of ARMA-GARCH
NORM = as.integer(NORM))
# Now Estimate Parameters:
MAX <- max(.series$order)
NF <- length(INDEX)
N <- length(.series$x)
DPARM <- c(.params$delta, .params$skew, .params$shape)
fit <- .Fortran(
"garchllh",
N = as.integer(N),
Y = as.double(.series$x),
# Z = as.double(rep(2, times = N)),
# H = as.double(rep(0, times = N)),
Z = as.double(.series$z),
H = as.double(.series$h),
NF = as.integer(NF),
X = as.double(params),
DPARM = as.double(DPARM),
MDIST = as.integer(MDIST),
MYPAR = as.integer(MYPAR),
F = as.double(0),
PACKAGE = "fGarch")
llh <- fit[[10]]
if(is.na(llh)) llh = .llh + 0.1*(abs(.llh))
if(!is.finite(llh)) llh = .llh + 0.1*(abs(.llh))
.setfGarchEnv(.llh = llh)
if (fGarchEnv) {
# Save h and z:
.series$h <- fit[[4]]
.series$z <- fit[[3]]
.setfGarchEnv(.series = .series)
}
} else {
stop("LLH is not internal!")
}
# Return Value:
c(LogLikelihood = llh)
}
# ------------------------------------------------------------------------------
.aparchLLH.filter <-
function(params, trace = TRUE, fGarchEnv = FALSE)
{
# A function implemented by Diethelm Wuertz
# Description:
# Fast approach using the filter function in R for ARMA-APARCH models
# Arguments:
# params - a named numeric vector with the model parameters
# to be optimized
# trace - a logical, should the frunction output be traced ?
# fGarchEnv -
# Value:
# Returns the value of the max log-likelihood function.
# Note:
# The variables '.series' and '.params' must be global available
# FUNCTION:
# DEBUG:
DEBUG = FALSE
if (DEBUG) print("Entering Function .garchLLH.filter")
# Get Global Variables:
.series <- .getfGarchEnv(".series")
.params <- .getfGarchEnv(".params")
.garchDist <- .getfGarchEnv(".garchDist")
.llh <- .getfGarchEnv(".llh")
# Which conditional distribution function should be used ?
if(DEBUG) print(.garchDist)
# How to calculate the LLH Function?
if (DEBUG) print(c("testing ?", .params$control$llh))
if(.params$control$llh == "filter") {
# Retrieve From Initialized Series:
x = .series$x
# Get Order:
u = .series$order[1]
v = .series$order[2]
p = .series$order[3]
q = .series$order[4]
max.order = max(u, v, p, q)
# Get Start Conditions:
h.start = .series$h.start
llh.start = .series$llh.start
# Get the Index Values and Add Names - Just to be Sure:
index = .params$index
names(params) = names(.params$params[index])
Names = names(params)
# Retrieve From Initialized Parameters:
cond.dist = .params$cond.dist
# Extracting the parameters by name ...
alpha <- beta <- NULL
mu = c(mu = .params$mu)
delta = c(delta = .params$delta)
skew = c(skew = .params$skew)
shape = c(shape = .params$shape)
leverage = c(leverage = .params$leverage)
if(.params$includes["mu"]) mu = params["mu"]
if(u > 0) ar = params[substr(Names, 1, 2) == "ar"]
if(v > 0) ma = params[substr(Names, 1, 2) == "ma"]
omega = params[substr(Names, 1, 5) == "omega"]
if(p > 0) alpha = params[substr(Names, 1, 5) == "alpha"]
if(p > 0 & leverage) gamma = params[substr(Names, 1, 5) == "gamma"]
if(p > 0 & !leverage) gamma = rep(0, times = p)
if(q > 0) beta = params[substr(Names, 1, 4) == "beta"]
if(.params$includes["delta"]) delta = params["delta"]
if(.params$includes["skew"]) skew = params["skew"]
if(.params$includes["shape"]) shape = params["shape"]
if(DEBUG) print(params)
# Iterate z:
N = length(x)
z = rep(0, N)
if(u > 0 & v > 0)
for (i in (h.start):N)
z[i] = x[i] - mu - sum(ar*x[i-(1:u)]) - sum(ma*z[i-(1:v)])
if(u > 0 & v == 0)
for (i in (h.start):N)
z[i] = x[i] - mu - sum(ar*x[i-(1:u)])
if(u == 0 & v > 0)
for (i in (h.start):N)
z[i] = x[i] - mu - sum(ma*z[i-(1:v)])
if(u == 0 & v == 0)
z = x - mu
# Initialize Variance Equation:
deltainv = 1/delta
if(.series$model[2] == "garch") {
persistence = sum(alpha) + sum(beta)
} else if(.series$model[2] == "aparch") {
persistence = sum(beta)
for (i in 1:p)
persistence = persistence + alpha[i]*garchKappa(cond.dist,
gamma[i], delta, skew, shape)
}
names(persistence) = "persistence"
attr(persistence, "control") = NULL
attr(persistence, "cond.dist") = NULL
.params$persistence <- persistence
.setfGarchEnv(.params = .params)
mvar = mean(z^2)
h = rep(omega + persistence*mvar, N)
# Iterate Conditional Variances h:
if(p == 0) {
alpha = 0
p = 1
}
if(q == 0) {
beta = 0
q = 1
}
# R Filter Representation:
# Entirely written in S, and very effective ...
# own filter method because as.ts and tsp time consuming...
# Note, sometimes one of the beta's can become undefined
# during optimization.
if(!.params$leverage) gamma = rep(0, p)
pq = max(p, q)
edeltat = 0
for (j in 1:p) {
Filter = rep(0, length = p+1)
Filter[j+1] = alpha[j]
edelta = (abs(z) - gamma[j]*z)^delta
edelta = as.vector(filter(edelta, filter = Filter, sides = 1))
edeltat = edeltat + edelta
}
c.init = omega/(1-sum(beta))
h <- c(h[1:pq], c.init +
as.vector(filter(edeltat[-(1:pq)],
filter = beta, method = "recursive",
init = h[q:1]-c.init)))
### ? remove ? ### DW: May be not .
if( sum(is.na(h)) > 0 ) {
# We use the testing Version ...
warning("Problems in Filter Representation")
if(!.params$leverage) {
for (i in (h.start):N) {
h[i] = omega +
sum(alpha * ( abs(z[i-(1:p)])) ^ delta ) +
sum(beta*h[i-(1:q)])
}
} else {
for (i in (h.start):N) {
h[i] = omega +
sum(alpha * ( abs(z[i-(1:p)]) -
gamma * z[i-(1:p)])^delta ) + sum(beta*h[i-(1:q)])
}
}
}
# Calculate Log Likelihood:
hh = (abs(h[(llh.start):N]))^deltainv
zz = z[(llh.start):N]
llh = -sum(log(.garchDist(z = zz, hh = hh, skew = skew, shape = shape)))
if(DEBUG) cat("DEBUG - LLH: ", llh, "\n")
names(params) = names(.params$params[.params$index])
if(is.na(llh)) llh = .llh + 0.1*(abs(.llh))
if(!is.finite(llh)) llh = .llh + 0.1*(abs(.llh))
# Print if LLH has Improved:
if(llh < .llh) {
diff = (.llh - llh)/llh
if(trace & diff > 1e-2) {
# cat(" LLH: ", llh, " norm LLH: ", llh/N, "\n")
# print(params)
if(persistence > 1)
cat("Warning - Persistence:", persistence, "\n")
}
.setfGarchEnv(.llh = llh)
}
if (fGarchEnv) {
# Save h and z:
.series$h <- h
.series$z <- z
.setfGarchEnv(.series = .series)
}
} else {
stop("LLH is not filter!")
}
# Return Value:
if (DEBUG) print("Entering Function .garchLLH.filter")
c(LogLikelihood = llh)
}
# ------------------------------------------------------------------------------
.aparchLLH.testing <-
function(params, trace = TRUE, fGarchEnv = FALSE)
{
# A function implemented by Diethelm Wuertz
# Description:
# Compute Log-Likelihood Function for ARMA-APARCH models
# Arguments:
# params - a named numeric vector with the model parameters
# to be optimized
# trace -
# fGarchEnv -
# Value:
# Returns the value of the max log-likelihood function.
# Note:
# The variables '.series' and '.params' must be global available
# FUNCTION:
# DEBUG:
DEBUG = FALSE
if (DEBUG) print("Entering Function .garchLLH.testing")
# Get Global Variables:
.series <- .getfGarchEnv(".series")
.params <- .getfGarchEnv(".params")
.garchDist <- .getfGarchEnv(".garchDist")
.llh <- .getfGarchEnv(".llh")
if(DEBUG) print(.garchDist)
# How to calculate the LLH Function?
if (DEBUG) print(.params$control$llh)
if(.params$control$llh == "testing") {
# Retrieve From Initialized Series:
x = .series$x
# Get Order:
u = .series$order[1]
v = .series$order[2]
p = .series$order[3]
q = .series$order[4]
max.order = max(u, v, p, q)
# Get Start Conditions:
h.start = .series$h.start
llh.start = .series$llh.start
# Get the Index Values and Add Names - Just to be Sure:
index = .params$index
names(params) = names(.params$params[index])
Names = names(params)
# Retrieve From Initialized Parameters:
cond.dist = .params$cond.dist
if(DEBUG) print(paste("Conditional Distribution:", cond.dist))
# Extracting the parameters by name ...
alpha <- beta <- NULL
mu = c(mu = .params$mu)
delta = c(delta = .params$delta)
skew = c(skew = .params$skew)
shape = c(shape = .params$shape)
leverage = c(leverage = .params$leverage)
if(.params$includes["mu"]) mu = params["mu"]
if(u > 0) ar = params[substr(Names, 1, 2) == "ar"]
if(v > 0) ma = params[substr(Names, 1, 2) == "ma"]
omega = params[substr(Names, 1, 5) == "omega"]
if(p > 0) alpha = params[substr(Names, 1, 5) == "alpha"]
if(p > 0 & leverage) gamma = params[substr(Names, 1, 5) == "gamma"]
if(p > 0 & !leverage) gamma = rep(0, times = p)
if(q > 0) beta = params[substr(Names, 1, 4) == "beta"]
if(.params$includes["delta"]) delta = params["delta"]
if(.params$includes["skew"]) skew = params["skew"]
if(.params$includes["shape"]) shape = params["shape"]
if(DEBUG) print(params)
# Iterate z:
N = length(x)
z = rep(0, N)
if(u > 0 & v > 0)
for (i in (h.start):N)
z[i] = x[i] - mu - sum(ar*x[i-(1:u)]) - sum(ma*z[i-(1:v)])
if(u > 0 & v == 0)
for (i in (h.start):N)
z[i] = x[i] - mu - sum(ar*x[i-(1:u)])
if(u == 0 & v > 0)
for (i in (h.start):N)
z[i] = x[i] - mu - sum(ma*z[i-(1:v)])
if(u == 0 & v == 0)
z = x - mu
# Initialize Variance Equation:
deltainv = 1/delta
if(.series$model[2] == "garch") {
persistence = sum(alpha) + sum(beta)
} else if(.series$model[2] == "aparch") {
persistence = sum(beta)
for (i in 1:p)
persistence = persistence + alpha[i]*garchKappa(cond.dist,
gamma[i], delta, skew, shape)
}
names(persistence) = "persistence"
attr(persistence, "control") = NULL
attr(persistence, "cond.dist") = NULL
.params$persistence <- persistence
.setfGarchEnv(.params = .params)
mvar = mean(z^2)
h = rep(omega + persistence*mvar, N)
# Initial Values to Iterate Conditional Variances h:
if(p == 0) {
alpha = 0
p = 1
}
if(q == 0) {
beta = 0
q = 1
}
# Test Version Just a Simple Double 'for' Loop:
# As You Can Imagine, Slow Version But Very Useful for Testing:
if(!.params$leverage) {
for (i in (h.start):N) {
h[i] = omega +
sum(alpha * ( abs(z[i-(1:p)])) ^ delta ) +
sum(beta*h[i-(1:q)])
}
} else {
for (i in (h.start):N) {
h[i] = omega +
sum(alpha * ( abs(z[i-(1:p)]) -
gamma * z[i-(1:p)])^delta ) + sum(beta*h[i-(1:q)])
}
}
# Calculate Log Likelihood:
hh = (abs(h[(llh.start):N]))^deltainv
zz = z[(llh.start):N]
llh = -sum(log(.garchDist(z = zz, hh = hh, skew = skew, shape = shape)))
if(DEBUG) cat("DEBUG - LLH: ", llh, "\n")
names(params) = names(.params$params[.params$index])
if(is.na(llh)) llh = .llh + 0.1*(abs(.llh))
if(!is.finite(llh)) llh = .llh + 0.1*(abs(.llh))
# Print if LLH has Improved:
if(llh < .llh) {
diff = (.llh - llh)/llh
if(trace & diff > 1e-2) {
# cat(" LLH: ", llh, " norm LLH: ", llh/N, "\n")
# print(params)
if(persistence > 1)
cat("Warning - Persistence:", persistence, "\n")
}
.setfGarchEnv(.llh = llh)
}
if (fGarchEnv) {
# Save h and z:
.series$h <- h
.series$z <- z
.setfGarchEnv(.series = .series)
}
} else {
stop("LLH is not testing!")
}
# Return Value:
if (DEBUG) print("Leaving Function .garchLLH.testing")
c(LogLikelihood = llh)
}
################################################################################
fGarch/R/zzz.R 0000644 0001762 0000144 00000001754 15104730075 012636 0 ustar ligges users ## 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 .
.onAttach <- function(libname, pkgname)
{
packageStartupMessage(
"NOTE: Packages 'fBasics', 'timeDate', and 'timeSeries' are no longer\n",
"attached to the search() path when 'fGarch' is attached.\n\n",
"If needed attach them yourself in your R script by e.g.,\n",
" require(\"timeSeries\")")
}
fGarch/R/dist-stdFit.R 0000644 0001762 0000144 00000010031 15104730075 014163 0 ustar ligges users
# This library is free software; you can redistribute it and/or
# modify it under the terms of the GNU Library General Public
# License as published by the Free Software Foundation; either
# version 2 of the License, or (at your option) any later version.
#
# This library 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 Library General Public License for more details.
#
# You should have received a copy of the GNU Library General
# Public License along with this library; if not, write to the
# Free Foundation, Inc., 59 Temple Place, Suite 330, Boston,
# MA 02111-1307 USA
################################################################################
# FUNCTION: PARAMETER ESTIMATION:
# stdFit Fit the parameters for a Sudent-t distribution
################################################################################
.stdFit <-
function(x, mean = 0, sd = 1, xi = 1.5,
scale = NA, doplot = TRUE, add = FALSE, span = "auto", trace = TRUE,
title = NULL, description = NULL, ...)
{
# A function implemented by Diethelm Wuertz
# Description:
# Fits parameters of a Student-t using maximum log-likelihood
# Example:
# set.seed(4711); x = rstd(500); .stdFit(x)@fit$estimate
# FUNCTION:
# Settings:
dist = dstd
model = "STD Parameter Estimation"
scale = "not used"
x = x.orig = as.vector(x)
# Parameter Estimation:
obj = function(x, y = x, trace) {
f <- tryCatch(-sum(log(dist(y, x[1], x[2], x[3]))), error=identity)
if (is.na(f) || inherits(f, "error")) return(1e9)
# Print Iteration Path:
if (trace) {
cat("\n Objective Function Value: ", -f)
cat("\n Parameter Estimates: ", x, "\n")
}
f }
r = nlminb(
start = c(mean = 0, sd = 1, nu = 5),
objective = obj,
lower = c(-Inf, 0, 2),
upper = c( Inf, Inf, Inf),
y = x,
trace = trace)
names(r$par) <- c("mean", "sd", "nu")
# Add Title and Description:
if (is.null(title)) title = model
if (is.null(description)) description = description()
# Result:
fit = list(estimate = r$par, minimum = -r$objective, code = r$convergence)
# Optional Plot:
if (doplot) {
x = as.vector(x.orig)
if (span == "auto") span = seq(min(x), max(x), length = 501)
z = density(x, n = 100, ...)
x = z$x[z$y > 0]
y = z$y[z$y > 0]
y.points = dstd(span, r$par[1], r$par[2], r$par[3])
ylim = log(c(min(y.points), max(y.points)))
if (add) {
lines(x = span, y = log(y.points), col = "steelblue")
} else {
plot(x, log(y), xlim = c(span[1], span[length(span)]),
ylim = ylim, type = "p", xlab = "x", ylab = "log f(x)", ...)
title(main = model)
lines(x = span, y = log(y.points), col = "steelblue")
}
}
# Return Value:
new("fDISTFIT",
call = match.call(),
model = model,
data = as.data.frame(x.orig),
fit = fit,
title = title,
description = description() )
}
# ------------------------------------------------------------------------------
stdFit <-
function(x, ...)
{
# A function implemented by Diethelm Wuertz
# Description:
# Fit the parameters for a skew Normal distribution
# FUNCTION:
# Start Value:
start = c(mean = mean(x), sd = sqrt(var(x)), nu = 4)
# Log-likelihood Function:
loglik = function(x, y = x){
f = -sum(log(dstd(y, x[1], x[2], x[3])))
f }
# Minimization:
fit = nlminb(
start = start,
objective = loglik,
lower = c(-Inf, 0, 2),
upper = c(Inf, Inf, Inf),
y = x, ...)
# Add Names to $par
names(fit$par) = c("mean", "sd", "nu")
# Return Value:
fit
}
################################################################################
fGarch/R/methods-show.R 0000644 0001762 0000144 00000015776 15104730075 014433 0 ustar ligges users
# This library is free software; you can redistribute it and/or
# modify it under the terms of the GNU Library General Public
# License as published by the Free Software Foundation; either
# version 2 of the License, or (at your option) any later version.
#
# This library 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 Library General Public License for more details.
#
# You should have received a copy of the GNU Library General
# Public License along with this library; if not, write to the
# Free Foundation, Inc., 59 Temple Place, Suite 330, Boston,
# MA 02111-1307 USA
################################################################################
# FUNCTION: DESCRIPTION:
# show.fGARCH S4 Show method for an object of class 'fGARCH'
# show.fGARCHSPEC S4 Show method for an object of class 'fGARCHSPEC'
################################################################################
.prepare_GARCH_show <- function(object) {
## based on the original body of the show method
common <- list(
title = object@title,
call = object@call,
formula = object@formula,
description = object@description
)
wrk <- if(as.character(object@call[1]) == ".gogarchFit") {
## multivariate
list(
type = "multivariate",
cond_dist = object@fit[[1]]@fit$params$cond.dist,
number_of_margins = length(object@fit)
)
} else {
## univariate
list(
type = "univariate",
cond_dist = object@fit$params$cond.dist,
par = object@fit$par,
se_method = if (object@fit$params$cond.dist == "QMLE")
"robust"
else
"based on Hessian",
matcoef = object@fit$matcoef,
loglik = -object@fit$value,
normalized_loglik = -object@fit$value / NROW(object@data)
)
}
c(common, wrk)
}
.print_title <- function(x) {
cat("\nTitle:\n ")
cat(x, "\n")
invisible(NULL)
}
.print_call <- function(x) {
cat("\nCall:\n ")
cat(paste(deparse(x), sep = "\n", collapse = "\n"), "\n")
}
.print_cond_dist <- function(x) {
cat("\nConditional Distribution:\n ")
cat(x, "\n")
}
.print_coef <- function(x) {
cat("\nCoefficient(s):\n")
digits = max(5, getOption("digits") - 4)
print.default(format(x, digits = digits), print.gap = 2, quote = FALSE)
}
.print_se_method <- function(x) {
cat("\nStd. Errors:\n ")
if (x == "QMLE")
cat("robust", "\n")
else
cat("based on Hessian", "\n")
}
.print_error_analysis <- function(x) {
digits = max(4, getOption("digits") - 5)
signif.stars = getOption("show.signif.stars")
cat("\nError Analysis:\n")
printCoefmat(x, digits = digits, signif.stars = signif.stars)
}
.print_loglik <- function(x, nllh) {
cat("\nLog Likelihood:\n ")
cat(x, " normalized: ", nllh, "\n")
}
.print_description <- function(x) {
cat("\nDescription:\n ")
cat(x, "\n")
cat("\n")
}
.print_mean_var_eq <- function(formula) {
cat("\nMean and Variance Equation:\n ")
Name <- unclass(attr(formula, "data"))
Formula <- formula
attr(Formula, "data") <- NULL
print(Formula) # GNB: TODO: use arg. showEnv?
cat(" [", Name, "]\n", sep = "")
invisible(NULL)
}
.show_orig_body <- function(object, prepare = TRUE) {
## A function implemented by Diethelm Wuertz
## refactored and modified by GNB
# Description:
# Print method for an object of class "fGARCH"
# Arguments:
# object - an object of class 'fGARCH'
# FUNCTION:
res <- if(prepare)
.prepare_GARCH_show(object)
else
object
.print_title(res$title)
.print_call(res$call)
.print_mean_var_eq(res$formula)
# Univariate or Multivariate Modeling ?
if(res$type == "univariate") { # univariate Garch Models
.print_cond_dist(res$cond_dist)
.print_coef(res$par)
.print_se_method(res$se_method)
.print_error_analysis(res$matcoef)
.print_loglik(res$loglik, res$normalized_loglik)
} else {
# For multivariate Garch Models ...
# extract information from first fitted instrument.
object@fit[[1]]@fit$params$cond.dist
# Conditional Distribution:
cat("\nConditional Distribution:\n ")
cat(object@fit[[1]]@fit$params$cond.dist, "\n")
# Number of Margins:
cat("\nNumber of Margins:\n ")
cat(length(object@fit), "\n")
}
.print_description(res$description)
invisible(res)
}
setMethod("show", "fGARCH",
function(object) .show_orig_body(object)
)
# ------------------------------------------------------------------------------
setMethod(f = "show", signature(object = "fGARCHSPEC"), definition =
function(object)
{
# A function implemented by Diethelm Wuertz
# Description:
# S4 Print Method for objects of class 'fGARCHSPEC'
# Arguments:
# object - Object of class 'fGARCHSPEC'
# FUNCTION:
# Formula:
x = object
cat("\nFormula: \n ")
cat(as.character(x@formula))
# Model:
cat("\nModel:")
if (sum(abs(x@model$ar)) != 0)
cat("\n ar: ", x@model$ar)
if (sum(abs(x@model$ma)) != 0)
cat("\n ma: ", x@model$ma)
if (x@model$mu != 0)
cat("\n mu: ", x@model$mu)
if (x@model$omega != 0)
cat("\n omega:", x@model$omega)
if (sum(abs(x@model$alpha)) != 0)
cat("\n alpha:", x@model$alpha)
if (sum(abs(x@model$gamma)) != 0)
cat("\n gamma:", x@model$gamma)
if (sum(abs(x@model$beta)) != 0)
cat("\n beta: ", x@model$beta)
if (x@model$delta != 2)
cat("\n delta:", x@model$delta)
# Distribution:
cat("\nDistribution: \n ")
cat(x@distribution)
if (x@distribution != "norm") {
if (x@distribution == "snorm") {
cat("\nDistributional Parameters: \n")
cat(" xi =", x@model$skew)
}
if (x@distribution == "ged" | x@distribution == "std") {
cat("\nDistributional Parameter: \n")
cat(" nu =", x@model$shape)
}
if (x@distribution == "sged" | x@distribution == "sstd") {
cat("\nDistributional Parameters: \n")
cat(" nu =", x@model$shape, " xi =", x@model$skew)
}
}
# Seed:
if (x@rseed != 0) {
cat("\nRandom Seed: \n ")
cat(x@rseed)
}
# Presample:
cat("\nPresample: \n")
n = -(length(x@presample[, 1])-1)
time = n:0
print(data.frame(cbind(time, x@presample)))
# Return Value:
invisible()
})
################################################################################
fGarch/R/dist-gedFit.R 0000644 0001762 0000144 00000010116 15104730075 014134 0 ustar ligges users
# This library is free software; you can redistribute it and/or
# modify it under the terms of the GNU Library General Public
# License as published by the Free Software Foundation; either
# version 2 of the License, or (at your option) any later version.
#
# This library 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 Library General Public License for more details.
#
# You should have received a copy of the GNU Library General
# Public License along with this library; if not, write to the
# Free Foundation, Inc., 59 Temple Place, Suite 330, Boston,
# MA 02111-1307 USA
################################################################################
# FUNCTION: PARAMETER ESTIMATION:
# .gedFit New: Fit the parameters for a GED distribution
# gedFit Fit the parameters for a GED distribution
################################################################################
.gedFit <-
function(x, mean = 0, sd = 1, nu = 2,
scale = NA, doplot = TRUE, add = FALSE, span = "auto", trace = TRUE,
title = NULL, description = NULL, ...)
{
# A function implemented by Diethelm Wuertz
# Description:
# Fits parameters of a NIG using maximum log-likelihood
# Example:
# set.seed(4711); x = rged(500); .gedFit(x)@fit$estimate
# FUNCTION:
# Settings:
dist = dged
model = "GED Parameter Estimation"
scale = "not used"
x = x.orig = as.vector(x)
# Parameter Estimation:
obj = function(x, y = x, trace) {
f <- tryCatch(-sum(log(dist(y, x[1], x[2], x[3]))), error=identity)
if (is.na(f) || inherits(f, "error")) return(1e9)
# Print Iteration Path:
if (trace) {
cat("\n Objective Function Value: ", -f)
cat("\n Parameter Estimates: ", x, "\n")
}
f }
r = nlminb(
start = c(mean = 0, sd = 1, nu = 2),
objective = obj,
lower = c(-Inf, 0, 0),
upper = c( Inf, Inf, Inf),
y = x,
trace = trace)
names(r$par) <- c("mean", "sd", "nu")
# Add Title and Description:
if (is.null(title)) title = model
if (is.null(description)) description = description()
# Result:
fit = list(estimate = r$par, minimum = -r$objective, code = r$convergence)
# Optional Plot:
if (doplot) {
x = as.vector(x.orig)
if (span == "auto") span = seq(min(x), max(x), length = 501)
z = density(x, n = 100, ...)
x = z$x[z$y > 0]
y = z$y[z$y > 0]
y.points = dist(span, r$par[1], r$par[2], r$par[3])
ylim = log(c(min(y.points), max(y.points)))
if (add) {
lines(x = span, y = log(y.points), col = "steelblue")
} else {
plot(x, log(y), xlim = c(span[1], span[length(span)]),
ylim = ylim, type = "p", xlab = "x", ylab = "log f(x)", ...)
title(main = model)
lines(x = span, y = log(y.points), col = "steelblue")
}
}
# Return Value:
new("fDISTFIT",
call = match.call(),
model = model,
data = as.data.frame(x.orig),
fit = fit,
title = title,
description = description() )
}
# ------------------------------------------------------------------------------
gedFit <-
function(x, ...)
{
# A function implemented by Diethelm Wuertz
# Description:
# Fit the parameters for a generalized error distribution
# FUNCTION:
# Start Value:
start = c(mean = mean(x), sd = sqrt(var(x)), nu = 2)
# Log-likelihood Function:
loglik = function(x, y = x){
f = -sum(log(dged(y, x[1], x[2], x[3])))
f }
# Minimization:
fit = nlminb(
start = start,
objective = loglik,
lower = c(-Inf, 0, 0),
upper = c( Inf, Inf, Inf),
y = x, ...)
# Add Names to $par
names(fit$par) = c("mean", "sd", "nu")
# Return Value:
fit
}
################################################################################
fGarch/R/dist-gedSlider.R 0000644 0001762 0000144 00000006615 15104730075 014645 0 ustar ligges users
# This library is free software; you can redistribute it and/or
# modify it under the terms of the GNU Library General Public
# License as published by the Free Software Foundation; either
# version 2 of the License, or (at your option) any later version.
#
# This library 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 Library General Public License for more details.
#
# You should have received a copy of the GNU Library General
# Public License along with this library; if not, write to the
# Free Foundation, Inc., 59 Temple Place, Suite 330, Boston,
# MA 02111-1307 USA
################################################################################
# FUNCTION: DESCRIPTION:
# gedSlider Displays Generalized Error Distribution and RVS
################################################################################
gedSlider <-
function(type = c("dist", "rand"))
{
# A function implemented by Diethelm Wuertz
# Description:
# Displays interactively skew GED distribution
# Note:
# dged(x, mean = 0, sd = 1, nu = 5)
# FUNCTION:
# Internal Function:
refresh.code = function(...)
{
# Sliders:
N = .sliderMenu(no = 1)
mean = .sliderMenu(no = 2)
sd = .sliderMenu(no = 3)
nu = .sliderMenu(no = 4)
# Compute Data:
xmin = round(qged(0.01, mean, sd, nu), digits = 2)
xmax = round(qged(0.99, mean, sd, nu), digits = 2)
s = seq(xmin, xmax, length = N)
y1 = dged(s, mean, sd, nu)
y2 = pged(s, mean, sd, nu)
main1 = paste("GED Density\n",
"mean = ", as.character(mean), " | ",
"sd = ", as.character(sd), " | ",
"nu = ", as.character(nu) )
main2 = paste("GED Probability\n",
"xmin [0.01] = ", as.character(xmin), " | ",
"xmax [0.99] = ", as.character(xmax) )
# Random Numbers:
if (type[1] == "rand") {
x = rged(N, mean, sd, nu)
}
# Frame:
par(mfrow = c(2, 1), cex = 0.7)
# Density:
if (type[1] == "rand") {
hist(x, probability = TRUE, col = "steelblue", border = "white",
breaks = "FD",
xlim = c(xmin, xmax), ylim = c(0, 1.1*max(y1)), main = main1 )
lines(s, y1, col = "orange")
} else {
plot(s, y1, type = "l", xlim = c(xmin, xmax), col = "steelblue")
abline (h = 0, lty = 3)
title(main = main1)
grid()
}
# Probability:
plot(s, y2, type = "l", xlim = c(xmin, xmax), ylim = c(0, 1),
col = "steelblue" )
abline (h = 0, lty = 3)
title(main = main2)
grid()
# Frame:
par(mfrow = c(1, 1), cex = 0.7)
}
# Open Slider Menu:
.sliderMenu(refresh.code,
names = c( "N", "mean", "sd", "nu"),
minima = c( 10, -5.0, 0.1, 2.1),
maxima = c( 1000, +5.0, 5.0, 10.0),
resolutions = c( 10, 0.1, 0.1, 0.1),
starts = c( 100, 0.0, 1.0, 5.0)
)
}
################################################################################
fGarch/R/garch-FitFromSpec.R 0000644 0001762 0000144 00000020117 15104730075 015236 0 ustar ligges users
# This library is free software; you can redistribute it and/or
# modify it under the terms of the GNU Library General Public
# License as published by the Free Software Foundation; either
# version 2 of the License, or (at your option) any later version.
#
# This library 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 Library General Public License for more details.
#
# You should have received a copy of the GNU Library General
# Public License along with this library; if not, write to the
# Free Foundation, Inc., 59 Temple Place, Suite 330, Boston,
# MA 02111-1307 USA
################################################################################
# FUNCTION: DESCRIPTION:
# fUGARCHSPEC Fits the parameters of GARCH process
# .ugarchSpec Specifies a univariate GARCH model
# .ugarchFit Fits a univariate GARCH model
################################################################################
## MM: FIXME .ugarchFit() & .ugarchSpec() are entirely
## ===== *un*documented and *un*tested
.setfGarchEnv(.llh = 1e99)
.setfGarchEnv(.garchDist = NA)
.setfGarchEnv(.params = NA)
.setfGarchEnv(.series = NA)
.setfGarchEnv(.trace = NA)
# ------------------------------------------------------------------------------
setClass("fUGARCHSPEC",
representation(
model = "list",
distribution = "list",
optimization = "list",
documentation = "list")
)
# ------------------------------------------------------------------------------
.ugarchSpec <-
function(
model = list(
formula = ~ garch(1,1),
mean = 0,
include.mean = TRUE,
delta = 2,
include.delta = NULL,
leverage = NULL,
recursion = c("internal", "filter", "testing")[1],
init.rec = c("mci", "uev")[1]),
distribution = list(
cond.dist = c("norm", "snorm", "ged", "sged", "std", "sstd",
"snig", "QMLE")[1],
skew = 1,
include.skew = NULL,
shape = 4,
include.shape = NULL),
optimization = list(
algorithm = c("nlminb", "lbfgsb", "nlminb+nm", "lbfgsb+nm")[1],
hessian = c("ropt", "rcd", "rts")[1],
trace = TRUE,
control = list(),
status = NA),
documentation = list(
call = match.call(),
title = NULL,
description = NULL )
)
{
# Description:
# Specifies a garch model to be fitted
# Example:
# .garchSpec())
# FUNCTION:
# Model Slot:
Model = list(
formula = ~ garch(1,1),
mean = 0,
include.mean = TRUE,
delta = 2,
include.delta = NULL,
leverage = NULL,
recursion = c("internal", "filter", "testing")[1],
init.rec = c("mci", "uev")[1])
Model[(Names <- names(model))] <- model
# Distribution Slot:
Distribution = list(
cond.dist = c("norm", "snorm", "ged", "sged", "std", "sstd",
"snig", "QMLE")[1],
skew = 1,
include.skew = NULL,
shape = 4,
include.shape = NULL)
Distribution[(Names <- names(distribution))] <- distribution
# Optimization Slot:
Optimization = list(
algorithm = c("nlminb", "lbfgsb", "nlminb+nm", "lbfgsb+nm")[1],
hessian = c("ropt", "rcd", "rst")[1],
trace = TRUE,
control = list(),
status = NA)
Optimization[(Names <- names(optimization))] <- optimization
# Documentation Slot:
Documentation = list(
call = match.call(),
title = NULL,
description = NULL )
Documentation[(Names <- names(documentation))] <- documentation
# Return Value:
new("fUGARCHSPEC",
model = Model,
distribution = Distribution,
optimization = Optimization,
documentation = Documentation)
}
# ------------------------------------------------------------------------------
.ugarchFit <-
function(data, spec = .ugarchSpec())
{
# Description:
# Fit parameters to a ARMA-GARCH model by GARCH Specification
# Arguments:
# data - time series or vector of data
# spec - garch specification object
# Example:
# .ugarchFit(dem2gbp[, 1])
# FUNCTION:
DEBUG = FALSE
# Set Call:
CALL <- spec@documentation$call <- match.call()
# Parse Data:
Name = capture.output(substitute(data))
if(is.character(data)) {
eval(parse(text = paste("data(", data, ")")))
data = eval(parse(text = data))
}
data <- as.data.frame(data)
# Column Names:
if (isUnivariate(data)) {
colnames(data) <- "data"
} else {
# Check unique column Names:
uniqueNames = unique(sort(colnames(data)))
if (is.null(colnames(data))) {
stop("Column names of data are missing.")
}
if (length(colnames(data)) != length(uniqueNames)) {
stop("Column names of data are not unique.")
}
}
# Handle if we have no left-hand-side for the formula ...
formula <- spec@model$formula
# Note in this case the length of the formula is 2 (else 3):
if (length(formula) == 3 && isUnivariate(data) ) formula[2] <- NULL
if (length(formula) == 2) {
if (isUnivariate(data)) {
# Missing lhs -- we substitute the data file name as lhs ...
formula = as.formula(paste("data", paste(formula, collapse = " ")))
} else {
stop("Multivariate data inputs require lhs for the formula.")
}
}
# Robust Formula ?
robust.cvar <- (spec@distribution$cond.dist == "QMLE")
# Parse Arguments:
args = .garchArgsParser(formula = formula, data = data, trace = FALSE)
# DEBUG - Print Arguments:
if(DEBUG) print(list(
formula.mean = args$formula.mean,
formula.var = args$formula.var,
series = args$series,
init.rec = spec@model$init.rec,
delta = spec@model$delta,
skew = spec@distribution$skew,
shape = spec@distribution$shape,
cond.dist = spec@distribution$cond.dist,
include.mean = spec@model$include.mean,
include.delta = spec@model$include.delta,
include.skew = spec@distribution$include.skew,
include.shape = spec@distribution$include.shape,
leverage = spec@model$leverage,
trace = spec@optimization$trace,
## recursion = spec@model$recursion,
algorithm = spec@optimization$algorithm,
hessian = spec@optimization$hessian,
robust.cvar = robust.cvar,
control = spec@optimization$control,
title = spec@documentation$title,
description = spec@documentation$description))
# Fit:
ans = .garchFit(
formula.mean = args$formula.mean,
formula.var = args$formula.var,
series = args$series,
init.rec = spec@model$init.rec,
delta = spec@model$delta,
skew = spec@distribution$skew,
shape = spec@distribution$shape,
cond.dist = spec@distribution$cond.dist,
include.mean = spec@model$include.mean,
include.delta = spec@model$include.delta,
include.skew = spec@distribution$include.skew,
include.shape = spec@distribution$include.shape,
leverage = spec@model$leverage,
trace = spec@optimization$trace,
## recursion = spec@model$recursion,
algorithm = spec@optimization$algorithm,
hessian = spec@optimization$hessian,
robust.cvar = robust.cvar,
control = spec@optimization$control,
title = spec@documentation$title,
description = spec@documentation$description)
ans@call = CALL
attr(formula, "data") <- paste("data = ", Name, sep = "")
ans@formula = formula
# Return Value:
ans
}
################################################################################
fGarch/R/methods-update.R 0000644 0001762 0000144 00000004316 15104730075 014721 0 ustar ligges users
# This library is free software; you can redistribute it and/or
# modify it under the terms of the GNU Library General Public
# License as published by the Free Software Foundation; either
# version 2 of the License, or (at your option) any later version.
#
# This library 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 Library General Public License for more details.
#
# You should have received a copy of the GNU Library General
# Public License along with this library; if not, write to the
# Free Foundation, Inc., 59 Temple Place, Suite 330, Boston,
# MA 02111-1307 USA
################################################################################
# METHOD: EXTRACTORS:
# update,fGARCHSPEC Update Methods
# update,fGARCH Update Methods
################################################################################
setMethod("update", "fGARCHSPEC", function(object, ... )
{
# A function implemented by Yohan Chalabi
# Description:
#
# Example:
#
#
# FUNCTION:
call <- object@call
extras <- match.call(expand.dots = FALSE)$...
if (length(extras)) {
existing <- !is.na(match(names(extras), names(call)))
for (a in names(extras)[existing]) call[[a]] <- extras[[a]]
if (any(!existing)) {
call <- c(as.list(call), extras[!existing])
call <- as.call(call)
}
}
eval(call, parent.frame())
})
# -----------------------------------------------------------------------------
setMethod("update", "fGARCH", function(object, ... )
{
# A function implemented by Yohan Chalabi
# Description:
#
# Example:
#
#
# FUNCTION:
call <- object@call
extras <- match.call(expand.dots = FALSE)$...
if (length(extras)) {
existing <- !is.na(match(names(extras), names(call)))
for (a in names(extras)[existing]) call[[a]] <- extras[[a]]
if (any(!existing)) {
call <- c(as.list(call), extras[!existing])
call <- as.call(call)
}
}
eval(call, parent.frame())
})
fGarch/R/dist-sgedSlider.R 0000644 0001762 0000144 00000007274 15104730075 015032 0 ustar ligges users
# This library is free software; you can redistribute it and/or
# modify it under the terms of the GNU Library General Public
# License as published by the Free Software Foundation; either
# version 2 of the License, or (at your option) any later version.
#
# This library 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 Library General Public License for more details.
#
# You should have received a copy of the GNU Library General
# Public License along with this library; if not, write to the
# Free Foundation, Inc., 59 Temple Place, Suite 330, Boston,
# MA 02111-1307 USA
################################################################################
# FUNCTION: DESCRIPTION:
# sgedSlider Displays Generalized Error Distribution and RVS
################################################################################
sgedSlider <-
function(type = c("dist", "rand"))
{
# A function implemented by Diethelm Wuertz
# Description:
# Displays interactively skew GED distribution
# Note:
# dsged(x, mean = 0, sd = 1, nu = 5, xi = 1.5)
# FUNCTION:
# Internal Function:
refresh.code = function(...)
{
# Sliders:
N = .sliderMenu(no = 1)
mean = .sliderMenu(no = 2)
sd = .sliderMenu(no = 3)
nu = .sliderMenu(no = 4)
xi = .sliderMenu(no = 5)
invert = .sliderMenu(no = 6)
# Compute Data:
if (invert == 1) xi = round(1/xi, digits = 4)
xmin = round(qsged(0.01, mean, sd, nu, xi), digits = 2)
xmax = round(qsged(0.99, mean, sd, nu, xi), digits = 2)
s = seq(xmin, xmax, length = N)
y1 = dsged(s, mean, sd, nu, xi)
y2 = psged(s, mean, sd, nu, xi)
main1 = paste("Skew GED Density\n",
"mean = ", as.character(mean), " | ",
"sd = ", as.character(sd), " | ",
"nu = ", as.character(nu), " | ",
"xi = ", as.character(xi) )
main2 = paste("Skew GED Probability\n",
"xmin [0.01] = ", as.character(xmin), " | ",
"xmax [0.99] = ", as.character(xmax) )
# Random Numbers:
if (type[1] == "rand") {
x = rsged(N, mean, sd, nu, xi)
}
# Frame:
par(mfrow = c(2, 1), cex = 0.7)
# Density:
if (type[1] == "rand") {
hist(x, probability = TRUE, col = "steelblue", border = "white",
breaks = "FD",
xlim = c(xmin, xmax), ylim = c(0, 1.1*max(y1)), main = main1 )
lines(s, y1, col = "orange")
} else {
plot(s, y1, type = "l", xlim = c(xmin, xmax), col = "steelblue")
abline (h = 0, lty = 3)
title(main = main1)
grid()
}
# Probability:
plot(s, y2, type = "l", xlim = c(xmin, xmax), ylim = c(0, 1),
col = "steelblue" )
abline (h = 0, lty = 3)
title(main = main2)
grid()
# Frame:
par(mfrow = c(1, 1), cex = 0.7)
}
# Open Slider Menu:
.sliderMenu(refresh.code,
names = c( "N", "mean", "sd", "nu", "xi", "xi.inv"),
minima = c( 10, -5.0, 0.1, 2.1, 1.0, 0 ),
maxima = c( 1000, +5.0, 5.0, 10.0, 10.0, 1 ),
resolutions = c( 10, 0.1, 0.1, 0.1, 0.1, 1 ),
starts = c( 100, 0.0, 1.0, 5.0, 1.0, 0 )
)
}
################################################################################
fGarch/R/dist-snormFit.R 0000644 0001762 0000144 00000010231 15104730075 014531 0 ustar ligges users
# This library is free software; you can redistribute it and/or
# modify it under the terms of the GNU Library General Public
# License as published by the Free Software Foundation; either
# version 2 of the License, or (at your option) any later version.
#
# This library 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 Library General Public License for more details.
#
# You should have received a copy of the GNU Library General
# Public License along with this library; if not, write to the
# Free Foundation, Inc., 59 Temple Place, Suite 330, Boston,
# MA 02111-1307 USA
################################################################################
# FUNCTION: DESCRIPTION:
# .snormFit Fit the parameters for a skew Normal distribution
# snormFit Fit the parameters for a skew Normal distribution
################################################################################
.snormFit <-
function(x, mean = 0, sd = 1, xi = 1.5,
scale = NA, doplot = TRUE, add = FALSE, span = "auto", trace = TRUE,
title = NULL, description = NULL, ...)
{
# A function implemented by Diethelm Wuertz
# Description:
# Fits parameters of a NIG using maximum log-likelihood
# Example:
# set.seed(4711); x = rsnorm(500); .snormFit(x)@fit$estimate
# FUNCTION:
# Settings:
dist = dsnorm
model = "SNORM Parameter Estimation"
scale = "not used"
x = x.orig = as.vector(x)
# Parameter Estimation:
obj = function(x, y = x, trace) {
f <- tryCatch(-sum(log(dist(y, x[1], x[2], x[3]))), error=identity)
if (is.na(f) || inherits(f, "error")) return(1e9)
# Print Iteration Path:
if (trace) {
cat("\n Objective Function Value: ", -f)
cat("\n Parameter Estimates: ", x, "\n")
}
f }
r = nlminb(
start = c(mean = 0, sd = 1, xi = 1.5),
objective = obj,
lower = c(-Inf, 0, 0),
upper = c( Inf, Inf, Inf),
y = x,
trace = trace)
names(r$par) <- c("mean", "sd", "xi")
# Add Title and Description:
if (is.null(title)) title = model
if (is.null(description)) description = description()
# Result:
fit = list(estimate = r$par, minimum = -r$objective, code = r$convergence)
# Optional Plot:
if (doplot) {
x = as.vector(x.orig)
if (span == "auto") span = seq(min(x), max(x), length = 501)
z = density(x, n = 100, ...)
x = z$x[z$y > 0]
y = z$y[z$y > 0]
y.points = dist(span, r$par[1], r$par[2], r$par[3])
ylim = log(c(min(y.points), max(y.points)))
if (add) {
lines(x = span, y = log(y.points), col = "steelblue")
} else {
plot(x, log(y), xlim = c(span[1], span[length(span)]),
ylim = ylim, type = "p", xlab = "x", ylab = "log f(x)", ...)
title(main = model)
lines(x = span, y = log(y.points), col = "steelblue")
}
}
# Return Value:
new("fDISTFIT",
call = match.call(),
model = model,
data = as.data.frame(x.orig),
fit = fit,
title = title,
description = description() )
}
# ------------------------------------------------------------------------------
snormFit <-
function(x, ...)
{
# A function implemented by Diethelm Wuertz
# Description:
# Fit the parameters for a skew Normal distribution
# FUNCTION:
# Start Value:
start = c(mean = mean(x), sd = sqrt(var(x)), xi = 1)
# Log-likelihood Function:
loglik = function(x, y = x){
f = -sum(log(dsnorm(y, x[1], x[2], x[3])))
f }
# Minimization:
fit = nlminb(
start = start,
objective = loglik,
lower = c(-Inf, 0, 0),
upper = c( Inf, Inf, Inf),
y = x, ...)
# Add Names to $par
names(fit$par) = c("mean", "sd", "xi")
# Return Value:
fit
}
################################################################################
fGarch/R/class-fGARCH.R 0000644 0001762 0000144 00000002636 15104730075 014076 0 ustar ligges users
# This library is free software; you can redistribute it and/or
# modify it under the terms of the GNU Library General Public
# License as published by the Free Software Foundation; either
# version 2 of the License, or (at your option) any later version.
#
# This library 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 Library General Public License for more details.
#
# You should have received a copy of the GNU Library General
# Public License along with this library; if not, write to the
# Free Foundation, Inc., 59 Temple Place, Suite 330, Boston,
# MA 02111-1307 USA
################################################################################
# FUNCTION: DESCRIPTION:
# 'fGARCH' fGARCH Class representation
################################################################################
# Class Representation:
setClass("fGARCH",
representation(
call = "call",
formula = "formula",
method = "character",
data = "numeric",
fit = "list",
residuals = "numeric",
fitted = "numeric",
h.t = "numeric",
sigma.t = "numeric",
title = "character",
description = "character")
)
################################################################################
fGarch/R/methods-plot.R 0000644 0001762 0000144 00000041246 15104730075 014420 0 ustar ligges users
# This library is free software; you can redistribute it and/or
# modify it under the terms of the GNU Library General Public
# License as published by the Free Software Foundation; either
# version 2 of the License, or (at your option) any later version.
#
# This library 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 Library General Public License for more details.
#
# You should have received a copy of the GNU Library General
# Public License along with this library; if not, write to the
# Free Foundation, Inc., 59 Temple Place, Suite 330, Boston,
# MA 02111-1307 USA
################################################################################
# FUNCTION: DESCRIPTION:
# plot Plot method for an object of class 'fGARCH'
# .interactiveGarchPlot Plot interactively
# .multGarchPlot Arrange multivariate Plots
# .plot.garch.1 Plot Time Series
# .plot.garch.2 Plot Conditional SD
# .plot.garch.3 Plot Series with 2 Conditional SD Superimposed
# .plot.garch.4 Plot ACF of Observations
# .plot.garch.5 Plot ACF of Squared Observations
# .plot.garch.6 Plot Cross Correlation
# .plot.garch.7 Plot Residuals
# .plot.garch.8 Plot Conditional SDs
# .plot.garch.9 Plot Standardized Residuals
# .plot.garch.10 Plot ACF of Standardized Residuals
# .plot.garch.11 Plot ACF of Squared Standardized Residuals
# .plot.garch.12 Plot Cross Correlation between r^2 and r
# .plot.garch.13 Plot QQ-Plot of Standardized Residuals"
# .qqDist Quantile-Quantile Points
# .qqLine Quantile-Quantile Line
################################################################################
setMethod(f = "plot", signature(x = "fGARCH", y = "missing"), definition =
function(x, which = "ask", ...)
{
# A function implemented by Diethelm Wuertz
# Description:
# Plot method for an object of class 'fGARCH'
# Note:
# This method can also be used for plotting graphs fitted by
# the function 'garch' from the contributed R package 'tseries'.
# FUNCTION:
if (as.character(x@call[1]) == ".gogarchFit")
{
# Plot multivariate GO-Garch model:
print("GO-Garch Plot Not Yet Implemented")
} else {
## Plot univariate Models:
choices <- c(
"Time Series",
"Conditional SD",
"Series with 2 Conditional SD Superimposed",
"ACF of Observations",
"ACF of Squared Observations",
"Cross Correlation",
"Residuals",
"Conditional SDs",
"Standardized Residuals",
"ACF of Standardized Residuals",
"ACF of Squared Standardized Residuals",
"Cross Correlation between r^2 and r",
"QQ-Plot of Standardized Residuals",
## added by GNB
"Series with -VaR Superimposed",
"Series with -ES Superimposed",
"Series with -VaR & -ES Superimposed"
)
.interactiveGarchPlot(
x,
choices = choices,
plotFUN = paste(".plot.garch", 1:length(choices), sep = "."),
which = which, ...)
}
# Return Value:
invisible(x)
})
# ------------------------------------------------------------------------------
.interactiveGarchPlot <-
function(x, choices, plotFUN, which, ...)
{
# A function implemented by Diethelm Wuertz
# Description:
# Internal plot function
# Arguments:
# x - an object to be plotted
# choices - the character string for the choice menu
# plotFUN - the names of the plot functions
# which - plot selection, which graph should be
# displayed. If a character string named "ask" the
# user is interactively asked which to plot, if
# a logical vector of length N, those plots which
# are set "TRUE" are displayed, if a character string
# named "all" all plots are displayed.
# FUNCTION:
# Some checks:
if (length(choices) != length(plotFUN))
stop("Arguments choices and plotFUN must be of same length.")
if (length(which) > length(choices))
stop("Arguments which has incorrect length.")
if (length(which) > length(plotFUN))
stop("Arguments which has incorrect length.")
# Plot:
if (is.numeric(which)) {
Which = rep(FALSE, times = length(choices))
Which[which] = TRUE
}
if (which[1] == "all") {
Which = rep(TRUE, times = length(choices))
}
if (which[1] == "ask") {
.multGarchPlot(x, choices, plotFUN, ...)
} else {
for ( i in 1:length(choices) ) {
FUN = match.fun(plotFUN[i])
if (Which[i]) FUN(x)
}
}
# Return Value:
invisible(x)
}
# ------------------------------------------------------------------------------
.multGarchPlot <-
function (x, choices, ...)
{
# A function implemented by Diethelm Wuertz
# Description:
# Internal plot function
pick = 1
while (pick > 0) {
pick = menu (
### choices = paste("plot:", choices),
choices = paste(" ", choices),
title = "\nMake a plot selection (or 0 to exit):")
# up to 19 plot functions ...
switch (pick,
.plot.garch.1(x), .plot.garch.2(x), .plot.garch.3(x),
.plot.garch.4(x), .plot.garch.5(x), .plot.garch.6(x),
.plot.garch.7(x), .plot.garch.8(x), .plot.garch.9(x),
.plot.garch.10(x), .plot.garch.11(x), .plot.garch.12(x),
.plot.garch.13(x))
}
}
# ------------------------------------------------------------------------------
.plot.garch.1 <-
function(x, ...)
{
# A function implemented by Diethelm Wuertz
# Description:
# Internal plot function
# 1. Time Series:
xseries = x@data
plot(xseries, type = "l", col = "steelblue", ylab = "x",
main = "Time Series")
abline(h = 0, col = "grey", lty = 3)
grid()
}
# ------------------------------------------------------------------------------
.plot.garch.2 <-
function(x, ...)
{
# A function implemented by Diethelm Wuertz
# Description:
# Internal plot function
# 2. Conditional SD:
xcsd = volatility(x, "sigma")
plot(xcsd, type = "l", col = "steelblue", ylab = "x",
main = "Conditional SD")
abline(h = 0, col = "grey", lty = 3)
grid()
}
# ------------------------------------------------------------------------------
.plot.garch.3 <-
function(x, ...)
{
# A function implemented by Diethelm Wuertz
# Description:
# Internal plot function
# 3. Series with 2 Conditional SD Superimposed:
xseries = x@data
xcsd = volatility(x, "sigma")
ci = 2
plot(xseries, type = "l", col = "steelblue", ylab = "x",
main = "Series with 2 Conditional SD Superimposed")
lines(mean(xseries) + ci * xcsd, col = "grey") # or simply xseries ?
lines(mean(xseries) - ci * xcsd, col = "grey")
abline(h = 0, col = "grey", lty = 3)
grid()
}
# ------------------------------------------------------------------------------
.plot.garch.4 <-
function(x, ...)
{
# A function implemented by Diethelm Wuertz
# Description:
# Internal plot function
# 4. ACF of the Observations:
xseries = as.vector(x@data)
n = length(xseries)
lag.max = as.integer(10*log10(n))
acf(xseries, lag.max = lag.max, xlab = "Lags", col = "steelblue",
main = "ACF of Observations", plot = TRUE)
}
# ------------------------------------------------------------------------------
.plot.garch.5 <-
function(x, ...)
{
# A function implemented by Diethelm Wuertz
# Description:
# Internal plot function
# 5. ACF of the Squared Observations:
xseries = as.vector(x@data)
xseries2 = xseries^2
n = length(xseries)
lag.max = as.integer(10*log10(n))
acf(xseries2, lag.max = lag.max, xlab = "Lags", col = "steelblue",
main = "ACF of Squared Observations", plot = TRUE)
}
# ------------------------------------------------------------------------------
.plot.garch.6 <-
function(x, ...)
{
# A function implemented by Diethelm Wuertz
# Description:
# Internal plot function
# 6. Cross Correlation between x^2 and x:
xseries = as.vector(x@data)
xseries2 = xseries^2
n = length(xseries)
lag.max = as.integer(10*log10(n))
ccf(xseries2, xseries, lag.max = lag.max, xlab = "Lags",
main = "Cross Correlation", plot = TRUE, col = "steelblue")
}
# ------------------------------------------------------------------------------
.plot.garch.7 <-
function(x, ...)
{
# A function implemented by Diethelm Wuertz
# Description:
# Internal plot function
# 7. Residuals:
res = residuals(x, standardize = FALSE)
plot(res, type = "l", main = "Residuals", col = "steelblue", ...)
abline(h = 0, lty = 3)
grid()
}
# ------------------------------------------------------------------------------
.plot.garch.8 <-
function(x, ...)
{
# A function implemented by Diethelm Wuertz
# Description:
# Internal plot function
# 8. Conditional SDs:
xcsd = volatility(x, "sigma")
plot(xcsd, type = "l", main = "Conditional SD's",
col = "steelblue", ...)
abline(h = 0, lty = 3)
grid()
}
# ------------------------------------------------------------------------------
.plot.garch.9 <-
function(x, ...)
{
# A function implemented by Diethelm Wuertz
# Description:
# Internal plot function
# 9. Standardized Residuals:
sres = residuals(x, standardize = TRUE)
plot(sres, type = "l", main = "Standardized Residuals",
col = "steelblue", ...)
abline(h = 0, lty = 3)
grid()
}
# ------------------------------------------------------------------------------
.plot.garch.10 <-
function(x, ...)
{
# A function implemented by Diethelm Wuertz
# Description:
# Internal plot function
# 10. ACF of Standardized Residuals:
sres = as.matrix(residuals(x, standardize = TRUE))
n = length(sres)
lag.max = as.integer(10*log10(n))
acf(sres, lag.max = lag.max, xlab = "Lags", col = "steelblue",
main = "ACF of Standardized Residuals", plot = TRUE)
}
# ------------------------------------------------------------------------------
.plot.garch.11 <-
function(x, ...)
{
# A function implemented by Diethelm Wuertz
# Description:
# Internal plot function
# 11. ACF of Squared Standardized Residuals:
sres2 = as.matrix(residuals(x, standardize = TRUE)^2)
n = length(sres2)
lag.max = as.integer(10*log10(n))
acf(sres2, lag.max = lag.max, xlab = "Lags", col = "steelblue",
main = "ACF of Squared Standardized Residuals", plot = TRUE)
}
# ------------------------------------------------------------------------------
.plot.garch.12 <-
function(x, ...)
{
# A function implemented by Diethelm Wuertz
# Description:
# Internal plot function
# 12. Cross Correlation between r^2 and r:
sres = residuals(x, standardize = FALSE)
sres2 = sres^2
n = length(sres)
lag.max = as.integer(10*log10(n))
ccf(sres2, sres, lag.max = lag.max, xlab = "Lags",
main = "Cross Correlation", plot = TRUE, col = "steelblue")
}
# ------------------------------------------------------------------------------
.plot.garch.13 <-
function(x, ...)
{
# A function implemented by Diethelm Wuertz
# Description:
# Internal plot function
# 13. QQ-Plot of Standardized Residuals:
sres = residuals(x, standardize = TRUE)
cond.dist = x@fit$params$cond.dist
cond.dist = paste("q", cond.dist, sep = "")
nc = nchar(x@fit$params$cond.dist)
parNames <- names(x@fit$par)
skew <-
if ("skew" %in% parNames)
x@fit$par["skew"]
else
x@fit$params$skew
shape <-
if ("shape" %in% parNames)
x@fit$par["shape"]
else
x@fit$params$shape
if (cond.dist == "qnorm" || cond.dist == "qQMLE")
.qqDist(sres, dist = "qnorm")
if (cond.dist == "qstd" | cond.dist == "qged")
.qqDist(sres, dist = cond.dist, nu = shape)
if (cond.dist == "qsnorm")
.qqDist(sres, dist = cond.dist, xi = skew)
if (cond.dist == "qsstd" | cond.dist == "qsged")
.qqDist(sres, dist = cond.dist, xi = skew, nu = shape)
if (cond.dist == "qsnig")
.qqDist(sres, dist = ".qsnigC", rho = skew, zeta = shape)
}
# ------------------------------------------------------------------------------
.qqDist <-
function (y, dist = "qnorm", ylim = NULL, main = paste(dist, "- QQ Plot"),
xlab = "Theoretical Quantiles", ylab = "Sample Quantiles", doplot = TRUE,
datax = FALSE, ...)
{
# A function implemented by Diethelm Wuertz
# Description
# QQ Plot for arbitray distribution
# FUNCTION:
# print(dist)
# Match Function :
qDist = match.fun(dist)
# Check Arguments:
# if (substr(dist, 1, 1) != "q") stop("dist is misspecified")
# test = class(test = try(qDist(0.5, ...), silent = TRUE))
# if (test == "try-error") stop("dist does not exist")
# Transform to Vector Mode:
y = as.vector(y)
# Compute Data:
if (has.na <- any(ina <- is.na(y))) {
yN = y
y = y[!ina]
}
if (0 == (n <- length(y))) stop("y is empty or has only NAs")
x <- qDist(ppoints(n,), ...)[order(order(y))]
if (has.na) {
y = x
x = yN
x[!ina] = y
y = yN
}
# Create QQ Plot:
if (doplot) {
if (is.null(ylim)) ylim = range(y)
if (datax) {
plot(y, x, main = main, xlab = ylab, ylab = xlab, xlim = ylim,
col = "steelblue", cex = 0.7)
} else {
plot(x, y, main = main, xlab = xlab, ylab = ylab, ylim = ylim,
col = "steelblue", cex = 0.7)
}
.qqLine(y = y, dist = dist, datax = datax, ...)
grid()
}
# Return Value:
invisible(if (datax) list(x = y, y = x) else list(x = x, y = y))
}
# ------------------------------------------------------------------------------
.qqLine <-
function (y, dist = "qnorm", datax = FALSE, ...)
{ # A function implemented by Diethelm Wuertz
# Description
# Add slope to QQ Plot for arbitray distribution
# FUNCTION:
# Match Function :
qDist = match.fun(dist)
# Check Arguments:
# if (substr(dist, 1, 1) != "q") stop("dist is misspecified")
# test = class(test = try(qDist(0.5, ...), silent = TRUE))
# if (test == "try-error") stop("dist does not exist")
# Transform to Vector Mode:
y = as.vector(y)
# Compute Data:
y = quantile(y[!is.na(y)], c(0.25, 0.75))
x = qDist(c(0.25, 0.75), ...)
# Add Slope:
if (datax) {
slope <- diff(x)/diff(y)
int <- x[1] - slope * y[1]
} else {
slope <- diff(y)/diff(x)
int <- y[1] - slope * x[1]
}
# Return Value:
abline(int, slope)
}
################################################################################
.plot.garch.14 <- function(x, ...) {
## A function implemented by Georgi N. Boshnakov
## Description:
## Internal plot function
#= 14. Series with -VaR Superimposed:
xseries = x@data
plot(xseries, type = "l", col = "steelblue", ylab = "x",
main = "Series with -VaR Superimposed")
## xseries is numeric here, so don't convert VaR to timeSeries
lines(-VaR(x), col = "red")
abline(h = 0, col = "grey", lty = 3)
grid()
}
.plot.garch.15 <- function(x, ...) {
## A function implemented by Georgi N. Boshnakov
## Description:
## Internal plot function
#= 14. Series with -ES Superimposed:
xseries = x@data
plot(xseries, type = "l", col = "steelblue", ylab = "x",
main = "Series with -ES Superimposed")
## xseries is numeric here, so don't convert ES to timeSeries
lines(-ES(x), col = "blue")
abline(h = 0, col = "grey", lty = 3)
grid()
}
.plot.garch.16 <- function(x, ...) {
## A function implemented by Georgi N. Boshnakov
## Description:
## Internal plot function
#= 14. Series with -VaR & -ES Superimposed:
xseries = x@data
plot(xseries, type = "l", col = "steelblue", ylab = "x",
main = "Series with -VaR & -ES Superimposed")
## xseries is numeric here, so don't convert VaR & ES to timeSeries
lines(-VaR(x), col = "red")
lines(-ES(x), col = "blue")
abline(h = 0, col = "grey", lty = 3)
grid()
}
fGarch/R/garch-FitFromFormula.R 0000644 0001762 0000144 00000014451 15104730075 015755 0 ustar ligges users
# This library is free software; you can redistribute it and/or
# modify it under the terms of the GNU Library General Public
# License as published by the Free Software Foundation; either
# version 2 of the License, or (at your option) any later version.
#
# This library 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 Library General Public License for more details.
#
# You should have received a copy of the GNU Library General
# Public License along with this library; if not, write to the
# Free Foundation, Inc., 59 Temple Place, Suite 330, Boston,
# MA 02111-1307 USA
################################################################################
# FUNCTION: PARAMETER ESTIMATION:
# garchFit Fits the parameters of GARCH process
# .garchArgsParser Parses formula and data for garchFit
# .garchOptimizerControl Sets default values for Garch Optimizer
# .garchFit ... old Version, still in use by garchFit()
# .garchNames Slot names, @fit slot, parameters and controls
################################################################################
garchFit <-
function(formula = ~ garch(1,1), data,
init.rec = c("mci", "uev"),
delta = 2,
skew = 1,
shape = 4,
cond.dist = c("norm", "snorm", "ged", "sged", "std", "sstd", "snig", "QMLE"),
include.mean = TRUE,
include.delta = NULL,
include.skew = NULL,
include.shape = NULL,
leverage = NULL,
trace = TRUE,
algorithm = c("nlminb", "lbfgsb", "nlminb+nm", "lbfgsb+nm"),
hessian = c("ropt", "rcd"),
control = list(),
title = NULL,
description = NULL,
...)
{
# A function implemented by Diethelm Wuertz
# Description:
# Fit parameters to a ARMA-GARCH model by Formula Specification
# Arguments:
# formula - ARMA(m,n) + GARCH/APARCH(p,q) mean and variance
# specification
# data - any univariate time series which can be converted
# into a timeSeries using the generic function as.timeSeries
# init.rec - names type of initialization of recurrence
# mci = mu-current-iteration, or
# uev = unconditional-expected-variances
# delta - numeric value of the exponent delta
# skew - optional skewness or skewness related parameter
# shape - optional shape parameter
# cond.dist - name of the conditional distribution, one of
# norm, snorm, ged, sged, std, sstd, snig, QMLE
# include.mean - a logical, should the mean value be estimated ?
# include.delta - should the exponent be estimated ?
# leverage - should the leverage factors be estimated ?
# trace - should the optimization be traced ?
# control - list of additional control parameters for the solver
# title - an optional title string
# description - an optional project description string
# Example:
# garchFit()
# FUNCTION:
# DEBUG:
DEBUG = FALSE
# Match arguments:
init.rec = match.arg(init.rec)
cond.dist = match.arg(cond.dist)
hessian = match.arg(hessian)
algorithm = match.arg(algorithm)
# Call:
CALL = match.call()
# Parse formula and data for garchFit ...
# Note in the new version we are working with timeSeries ...
Name = capture.output(substitute(data))
if(is.character(data)) {
eval(parse(text = paste("data(", data, ")")))
data = eval(parse(text = data))
}
# data <- if (inherits(data, "timeSeries") data else as.timeSeries(data)
data <- as.data.frame(data)
# Column Names:
if (isUnivariate(data)) {
colnames(data) <- "data"
} else {
# Check unique column Names:
uniqueNames = unique(sort(colnames(data)))
if (is.null(colnames(data))) {
stop("Column names of data are missing.")
}
if (length(colnames(data)) != length(uniqueNames)) {
stop("Column names of data are not unique.")
}
}
# Handle if we have no left-hand-side for the formula ...
# Note in this case the length of the formula is 2 (else 3):
if (length(formula) == 3 && isUnivariate(data) ) formula[2] <- NULL
if (length(formula) == 2) {
if (isUnivariate(data)) {
# Missing lhs -- we substitute the data file name as lhs ...
formula = as.formula(paste("data", paste(formula, collapse = " ")))
} else {
stop("Multivariate data inputs require lhs for the formula.")
}
}
# Robust Covariance ?
robust.cvar <- (cond.dist == "QMLE")
# Parse Arguments:
args = .garchArgsParser(formula = formula, data = data, trace = FALSE)
# DEBUG - Print Arguments:
if (DEBUG) print(list(
formula.mean = args$formula.mean,
formula.var = args$formula.var,
series = args$series,
init.rec = init.rec,
delta = delta,
skew = skew,
shape = shape,
cond.dist = cond.dist,
include.mean = include.mean,
include.delta = include.delta,
include.skew = include.skew,
include.shape = include.shape,
leverage = leverage,
trace = trace,
algorithm = algorithm,
hessian = hessian,
robust.cvar = robust.cvar,
control = control,
title = title,
description = description))
# Fit:
ans = .garchFit(
formula.mean = args$formula.mean,
formula.var = args$formula.var,
series = args$series,
init.rec,
delta,
skew,
shape,
cond.dist,
include.mean,
include.delta,
include.skew,
include.shape,
leverage,
trace,
algorithm,
hessian,
robust.cvar,
control,
title,
description,
...)
ans@call = CALL
attr(formula, "data") <- paste("data = ", Name, sep = "")
ans@formula = formula
# Return Value:
ans
}
################################################################################
fGarch/R/dist-absMoments.R 0000644 0001762 0000144 00000007064 15104730075 015052 0 ustar ligges users
# This library is free software; you can redistribute it and/or
# modify it under the terms of the GNU Library General Public
# License as published by the Free Software Foundation; either
# version 2 of the License, or (at your option) any later version.
#
# This library 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 Library General Public License for more details.
#
# You should have received a copy of the GNU Library General
# Public License along with this library; if not, write to the
# Free Foundation, Inc., 59 Temple Place, Suite 330, Boston,
# MA 02111-1307 USA
################################################################################
# FUNCTION: MOMENTS:
# absMoments Compute absolute moments of a symmetric distribution
################################################################################
absMoments <-
function(n, density = c("dnorm", "dged", "dstd"), ...)
{
# A function implemented by Diethelm Wuertz
##
## Georgi N. Boshnakov corrected the computation for std
# Description:
# Compute the absolute moments of a standardized
# symmetric distribution function.
# Arguments:
# n - a vector of integers i, to compute M_i
# density - a character denoting the density
# "norm", "ged", "std" or any other
# ... - parameters passed to the standardized
# symmetric density function
# Value:
# Returns a numeric vector of moments M_i.
# Stores globally errors in the variable absMoment.error
# if the moments were computed numerically.
# FUNCTION:
# norm - Normal Distribution:
if (density == "dnorm" | density == "norm") {
return (sqrt(2)^n * gamma((n+1)/2) / sqrt(pi)) }
# ged - Generalized Error Distribution:
if (density == "dged" | density == "ged") {
parm = function(n, nu) {
lambda = sqrt ( 2^(-2/nu) * gamma(1/nu) / gamma(3/nu) )
return ((2^(1/nu)*lambda)^n * gamma((n+1)/nu) / gamma(1/nu)) }
return(parm(n, ...))
}
# std - Standardized Student-t Distribution:
# Note: nu > 2*n
if (density == "dstd" | density == "std") {
parm = function(n, nu) {
## GNB: this is wrong, gives NaN's when it shouldn't:
## beta(1/2 + 2*n, nu/2 - 2*n) / beta(1/2, nu/2) * sqrt(nu-2)
##
## This is from the paper Wuertz at all (draft for JSS), eq. (14):
##
## r <- n / 2
## beta(1/2 + r/2, nu/2 - r/2) / beta(1/2, nu/2) * (nu-2)^(r/2)
##
## but the results are not right. It looks like a typo/error in the
## formula and changing r/2 to n/2 gives a consistent result with
## the usual t-distribution
##
beta(1/2 + n/2, nu/2 - n/2) / beta(1/2, nu/2) * (nu-2)^(n/2)
}
return(parm(n, ...))
}
# Any other standardized symmetric Distribution ...
fun = match.fun(density)
moments = function(x, n, ...) { 2 * x^n * fun(x, ...) }
M = .absMoments.error <- NULL
for (i in n) {
I = integrate(moments, 0, Inf, n = i, ...)
M = c(M, I$value)
.absMoments.error <- c(.absMoments.error, I$abs.error)
}
attr(M, "control") <- .absMoments.error
return(M)
# Return Value:
invisible()
}
################################################################################
fGarch/R/methods-fitted.R 0000644 0001762 0000144 00000006252 15104730075 014717 0 ustar ligges users
# This library is free software; you can redistribute it and/or
# modify it under the terms of the GNU Library General Public
# License as published by the Free Software Foundation; either
# version 2 of the License, or (at your option) any later version.
#
# This library 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 Library General Public License for more details.
#
# You should have received a copy of the GNU Library General
# Public License along with this library; if not, write to the
# Free Foundation, Inc., 59 Temple Place, Suite 330, Boston,
# MA 02111-1307 USA
################################################################################
# METHOD: EXTRACTORS:
# fitted.fGARCH S3 fitted values for an object of class 'fGARCH'
################################################################################
setMethod(f = "fitted", signature(object = "fGARCH"), definition =
function(object)
{
# A function implemented by Diethelm Wuertz
# Description:
# S3 Fitted values method for an object of class fGARCH
# Arguments:
# object - an object of class fGarch as returned by the function
# garchFit
# FUNCTION:
## GNB: this was the previous code (before v4022.90). Clearly, it assumes
## that 'data' is from class \code{"timeSeries"} and, to return an
## object from the same class, gets 'data' and replaces the data values
## with the fitted ones. ... Except that it doesn't do the latter, so
## returns the data!
##
## # Get numeric vector of fitted, optionally standardized
## fitted = object@fitted
## ## Get original time series class: (!! GNB: Nope, slot 'data' is numeric!)
## ans = slot(object, "data")
## Name = as.character(object@formula[2])
## attr(ans, "Name") <- Name
## # Return Value:
## ans
##
## GNB: the following code is in the spirit of the above, assuming that
## 'ans' is indeed the original time series. For example (todo?) this
## could be achieved if garchFit sets object@fit$data to the original
## time series, using 'ans <- object@fit$data'. Changing the class of
## slot 'data' instead doesn't seem practical.
##
## fitted <- object@fitted
## if(is(ans, "timeSeries")){
## Name <- as.character(object@formula[2])
## attr(ans, "Name") <- Name
## ans@.Data <- if(is.matrix(fitted)) fitted else matrix(fitted, ncol = 1)
## } else if(inherits(ans, "ts") || is.numeric(ans)) {
## ans[] <- fitted
## } else {
## message(paste0("conversion to class '", class(ans), "' not supported yet,\n",
## "returning slot fitted asis."))
## ans <- fitted
## }
ans <- object@fitted
# Return Value:
ans
})
################################################################################
fGarch/R/garch-Stats.R 0000644 0001762 0000144 00000010704 15104730075 014154 0 ustar ligges users
# This library is free software; you can redistribute it and/or
# modify it under the terms of the GNU Library General Public
# License as published by the Free Software Foundation; either
# version 2 of the License, or (at your option) any later version.
#
# This library 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 Library General Public License for more details.
#
# You should have received a copy of the GNU Library General
# Public License along with this library; if not, write to the
# Free Foundation, Inc., 59 Temple Place, Suite 330, Boston,
# MA 02111-1307 USA
################################################################################
# FUNCTION: DESCRIPTION:
# garchKappa Computes Expection for APARCH Models
# .garchKappaFun Internal function used by garchKappa()
# FUNCTION: DESCRIPTION:
# .truePersistence Computes true persistence
################################################################################
garchKappa <-
function(cond.dist = c("norm", "ged", "std", "snorm", "sged", "sstd",
"snig"), gamma = 0, delta = 2, skew = NA, shape = NA)
{
# A function implemented by Diethelm Wuertz
# Description:
# Computes Expection for APARCH Models
# FUNCTION:
# Compute kappa:
kappa = integrate(.garchKappaFun, lower = -Inf, upper = Inf, cond.dist =
cond.dist[1], gamma = gamma, delta = delta, skew = skew, shape =
shape)[[1]]
names(kappa) = "kappa"
attr(kappa, "control") =
c(gamma = gamma, delta = delta, skew = skew, shape = shape)
attr(kappa, "cond.dist") = cond.dist[1]
# Return Value:
kappa
}
# ------------------------------------------------------------------------------
.garchKappaFun <-
function(x,
cond.dist = c("norm", "ged", "std", "snorm", "sged", "sstd", "snig"),
gamma = 0, delta = 2, skew = NA, shape = NA)
{
# A function implemented by Diethelm Wuertz
# Description:
# Internal function used by kappa()
# FUNCTION:
# Compute Expectation Value for ...
funcE = (abs(x) - gamma*x)^delta
# Select Appropriate Conditional Density:
cond.dist = cond.dist[1]
if (cond.dist == "norm") {
fun = funcE * dnorm(x)
}
if (cond.dist == "ged") {
fun = funcE * dged(x, nu = shape)
}
if (cond.dist == "std") {
fun = funcE * dstd(x, nu = shape)
}
if (cond.dist == "snorm") {
fun = funcE * dsnorm(x, xi = skew)
}
if (cond.dist == "sged") {
fun = funcE * dsged(x, nu = shape, xi = skew)
}
if (cond.dist == "sstd") {
fun = funcE * dsstd(x, nu = shape, xi = skew)
}
if (cond.dist == "snig") {
fun = funcE * dsnig(x, zeta = shape, rho = skew)
}
# Return Value:
fun
}
################################################################################
.truePersistence <-
function(fun = "norm", alpha = 1, gamma = 0, beta = 0, delta = 1, ...)
{
# A function implemented by Diethelm Wuertz
# Description:
# Computes persistence for an APARCH process
# Arguments:
# fun - name of density functions of APARCH innovations
# alpha, gamma - numeric value or vector of APARCH coefficients,
# must be of same length
# beta - numeric value or vector of APARCH coefficients
# delta - numeric value of APARCH exponent
# Note:
# fun is one of: norm, snorn, std, sstd, ged, sged, snig
# FUNCTION:
# Match Density Function:
fun = match.fun(fun)
# Persisgtence Function: E(|z|-gamma z)^delta
e = function(x, gamma, delta, ...) {
(abs(x)-gamma*x)^delta * fun(x, ...)
}
# Compute Persistence by Integration:
persistence = sum(beta)
for (i in 1:length(alpha)) {
I = integrate(e, -Inf, Inf, subdivisions = 1000,
rel.tol = .Machine$double.eps^0.5,
gamma = gamma[i], delta = delta, ...)
persistence = persistence + alpha[i] * I[[1]]
}
# Warning:
if (persistence >= 1) {
p = as.character(round(persistence, digits = 3))
warning(paste("Divergent persistence p =", p))
}
# Return Value:
persistence
}
################################################################################
fGarch/R/dist-stdSlider.R 0000644 0001762 0000144 00000006466 15104730075 014704 0 ustar ligges users
# This library is free software; you can redistribute it and/or
# modify it under the terms of the GNU Library General Public
# License as published by the Free Software Foundation; either
# version 2 of the License, or (at your option) any later version.
#
# This library 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 Library General Public License for more details.
#
# You should have received a copy of the GNU Library General
# Public License along with this library; if not, write to the
# Free Foundation, Inc., 59 Temple Place, Suite 330, Boston,
# MA 02111-1307 USA
################################################################################
# FUNCTION: DESCRIPTION:
# stdSlider Displays Variance-1 Student-t Distribution and RVS
################################################################################
stdSlider <-
function(type = c("dist", "rand"))
{
# A function implemented by Diethelm Wuertz
# Description:
# Displays interactively Student-t distribution
# Note:
# dstd(x, mean = 0, sd = 1, nu = 5)
# FUNCTION:
# Internal Function:
refresh.code = function(...)
{
# Sliders:
N = .sliderMenu(no = 1)
mean = .sliderMenu(no = 2)
sd = .sliderMenu(no = 3)
nu = .sliderMenu(no = 4)
# Compute Data:
xmin = round(qstd(0.01, mean, sd, nu), digits = 2)
xmax = round(qstd(0.99, mean, sd, nu), digits = 2)
s = seq(xmin, xmax, length = N)
y1 = dstd(s, mean, sd, nu)
y2 = pstd(s, mean, sd, nu)
main1 = paste("Student-t Density\n",
"mean = ", as.character(mean), " | ",
"sd = ", as.character(sd), " | ",
"nu = ", as.character(nu))
main2 = paste("Student-t Probability\n",
"xmin [0.01] = ", as.character(xmin), " | ",
"xmax [0.99] = ", as.character(xmax) )
# Random Numbers:
if (type[1] == "rand") {
x = rstd(N, mean, sd, nu)
}
# Frame:
par(mfrow = c(2, 1), cex = 0.7)
# Density:
if (type[1] == "rand") {
hist(x, probability = TRUE, col = "steelblue", border = "white",
breaks = "FD",
xlim = c(xmin, xmax), ylim = c(0, 1.1*max(y1)), main = main1 )
lines(s, y1, col = "orange")
} else {
plot(s, y1, type = "l", xlim = c(xmin, xmax), col = "steelblue")
abline (h = 0, lty = 3)
title(main = main1)
grid()
}
# Probability:
plot(s, y2, type = "l", xlim = c(xmin, xmax), ylim = c(0, 1),
col = "steelblue" )
abline (h = 0, lty = 3)
title(main = main2)
grid()
# Frame:
par(mfrow = c(1, 1), cex = 0.7)
}
# Open Slider Menu:
.sliderMenu(refresh.code,
names = c( "N", "mean", "sd", "nu"),
minima = c( 10, -5.0, 0.1, 2.1),
maxima = c( 500, +5.0, 5.0, 10.0),
resolutions = c( 10, 0.1, 0.1, 0.1),
starts = c( 100, 0.0, 1.0, 5.0)
)
}
################################################################################
fGarch/R/garch-SolverControl.R 0000644 0001762 0000144 00000007457 15104730075 015704 0 ustar ligges users
# This library is free software; you can redistribute it and/or
# modify it under the terms of the GNU Library General Public
# License as published by the Free Software Foundation; either
# version 2 of the License, or (at your option) any later version.
#
# This library 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 Library General Public License for more details.
#
# You should have received a copy of the GNU Library General
# Public License along with this library; if not, write to the
# Free Foundation, Inc., 59 Temple Place, Suite 330, Boston,
# MA 02111-1307 USA
##############################################################################
# FUNCTION: DESCRIPTION:
# garchFitControl Sets default values for Garch Optimizer
##############################################################################
garchFitControl <-
function(
llh = c("filter", "internal", "testing"),
nlminb.eval.max = 2000,
nlminb.iter.max = 1500,
nlminb.abs.tol = 1.0e-20,
nlminb.rel.tol = 1.0e-14,
nlminb.x.tol = 1.0e-14,
nlminb.step.min = 2.2e-14,
nlminb.scale = 1,
nlminb.fscale = FALSE,
nlminb.xscale = FALSE,
sqp.mit = 200,
sqp.mfv = 500,
sqp.met = 2,
sqp.mec = 2,
sqp.mer = 1,
sqp.mes = 4,
sqp.xmax = 1.0e3,
sqp.tolx = 1.0e-16,
sqp.tolc = 1.0e-6,
sqp.tolg = 1.0e-6,
sqp.told = 1.0e-6,
sqp.tols = 1.0e-4,
sqp.rpf = 1.0e-4,
lbfgsb.REPORT = 10,
lbfgsb.lmm = 20,
lbfgsb.pgtol = 1e-14,
lbfgsb.factr = 1,
lbfgsb.fnscale = FALSE,
lbfgsb.parscale = FALSE,
nm.ndeps = 1e-14,
nm.maxit = 10000,
nm.abstol = 1e-14,
nm.reltol = 1e-14,
nm.alpha = 1.0,
nm.beta = 0.5,
nm.gamma = 2.0,
nm.fnscale = FALSE,
nm.parscale = FALSE)
{
# A function implemented by Diethelm Wuertz
# Description:
# Sets default values for Garch Optimizer
# FUNCTION:
# Generate Control List with Default Settings:
control <- list(
llh = llh,
nlminb.eval.max = nlminb.eval.max,
nlminb.iter.max = nlminb.iter.max,
nlminb.abs.tol = nlminb.abs.tol,
nlminb.rel.tol = nlminb.rel.tol,
nlminb.x.tol = nlminb.x.tol,
nlminb.step.min = nlminb.step.min,
nlminb.scale = nlminb.scale,
nlminb.fscale = nlminb.fscale,
nlminb.xscale = nlminb.xscale,
sqp.mit = sqp.mit,
sqp.mfv = sqp.mfv,
sqp.met = sqp.met,
sqp.mec = sqp.mec,
sqp.mer = sqp.mer,
sqp.mes = sqp.mes,
sqp.xmax = sqp.xmax,
sqp.tolx = sqp.tolx,
sqp.tolc = sqp.tolc,
sqp.tolg = sqp.tolg,
sqp.told = sqp.told,
sqp.tols = sqp.tols,
sqp.rpf = sqp.rpf,
lbfgsb.REPORT = lbfgsb.REPORT,
lbfgsb.lmm = lbfgsb.lmm,
lbfgsb.pgtol = lbfgsb.pgtol,
lbfgsb.factr = lbfgsb.factr,
lbfgsb.fnscale = lbfgsb.fnscale,
lbfgsb.parscale = lbfgsb.parscale,
nm.ndeps = nm.ndeps,
nm.maxit = nm.maxit,
nm.abstol = nm.abstol,
nm.reltol = nm.reltol,
nm.alpha = nm.alpha,
nm.beta = nm.beta,
nm.gamma = nm.gamma,
nm.fnscale = nm.fnscale,
nm.parscale = nm.parscale
)
# Return Value:
control
}
################################################################################
fGarch/R/garch-Spec.R 0000644 0001762 0000144 00000017257 15104730075 013762 0 ustar ligges users
# This library is free software; you can redistribute it and/or
# modify it under the terms of the GNU Library General Public
# License as published by the Free Software Foundation; either
# version 2 of the License, or (at your option) any later version.
#
# This library 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 Library General Public License for more details.
#
# You should have received a copy of the GNU Library General
# Public License along with this library; if not, write to the
# Free Foundation, Inc., 59 Temple Place, Suite 330, Boston,
# MA 02111-1307 USA
################################################################################
# FUNCTION: SPECIFICATION:
# garchSpec Creates a 'garchSpec' object from scratch
###############################################################################
garchSpec <-
function (model = list(), presample = NULL,
cond.dist = c("norm", "ged", "std", "snorm", "sged", "sstd"),
rseed = NULL)
{
# A function implemented by Diethelm Wuertz
# Description:
# Creates a "garchSpec" object from scratch.
# Arguments:
# model - a list with the model parameters as entries
# omega - the variance value for GARCH/APARCH
# specification,
# alpha - a vector of autoregressive coefficients
# of length p for the GARCH/APARCH specification,
# gamma - a vector of leverage coefficients of
# length p for the APARCH specification,
# beta - a vector of moving average coefficients of
# length q for the GARCH/APARCH specification,
# mu - the mean value for ARMA specification,
# ar - a vector of autoregressive coefficients of
# length m for the ARMA specification,
# ma - a vector of moving average coefficients of
# length n for the ARMA specification,
# delta - the exponent value used in the variance equation.
# skew - a numeric value listing the distributional
# skewness parameter.
# shape - a numeric value listing the distributional
# shape parameter.
# presample - either a multivariate "timeSeries", a
# multivariate "ts", a "data.frame" object or a numeric
# "matrix" with 3 columns and at least max(m,n,p,q)
# rows. The first culumn are the innovations, the second
# the conditional variances, and the last the time series.
# condd.dist - a character string naming the distribution
# function.
# rseed - optional random seed.
# Slots:
# call - the function call.
# formula - a formula object describing the model, e.g.
# ARMA(m,n) + GARCH(p,q). ARMA can be missing or
# specified as AR(m) or MA(n) in the case of pure
# autoregressive or moving average models. GARCH may
# alternatively specified as ARCH(p) or APARCH(p,q).
# If formula is set to "NA", the formula is constructed
# from the "model" list.
# model - as declared in the input.
# FUNCTION:
# Match Arguments:
cond.dist = match.arg(cond.dist)
# Skewness Parameter Settings:
skew = list(
"norm" = NULL,
"ged" = NULL,
"std" = NULL,
"snorm" = 0.9,
"sged" = 0.9,
"sstd" = 0.9)
# Shape Parameter Settings:
shape = list(
"norm" = NULL,
"ged" = 2,
"std" = 4,
"snorm" = NULL,
"sged" = 2,
"sstd" = 4)
# Default Model:
control = list(
omega = 1.0e-6,
alpha = 0.1,
gamma = NULL,
beta = 0.8,
mu = NULL,
ar = NULL,
ma = NULL,
delta = 2,
skew = skew[[cond.dist]],
shape = shape[[cond.dist]]
)
# Update Control:
control[names(model)] <- model
model <- control
# check if alpha and beta are well defined
if (sum(c(model$alpha, model$beta))>1)
warning("sum(alpha)+sum(beta)>1")
# Model Orders:
order.ar = length(model$ar)
order.ma = length(model$ma)
order.alpha = length(model$alpha)
if (sum(model$beta) == 0) {
order.beta = 0
} else {
order.beta = length(model$beta)
}
# Compose Mean Formula Object:
if (order.ar == 0 && order.ma == 0) {
formula.mean = ""
}
if (order.ar > 0 && order.ma == 0) {
formula.mean = paste ("ar(", as.character(order.ar), ")", sep = "")
}
if (order.ar == 0 && order.ma > 0) {
formula.mean = paste ("ma(", as.character(order.ma), ")", sep = "")
}
if (order.ar > 0 && order.ma > 0) {
formula.mean = paste ("arma(", as.character(order.ar), ", ",
as.character(order.ma), ")", sep = "")
}
# Compose Variance Formula Object:
formula.var = "garch"
if (order.beta == 0) formula.var = "arch"
if (!is.null(model$gamma) != 0) formula.var = "aparch"
if (model$delta != 2) formula.var = "aparch"
if (order.beta == 0) {
formula.var = paste(formula.var, "(", as.character(order.alpha), ")",
sep = "")
} else {
formula.var = paste(formula.var, "(", as.character(order.alpha),
", ", as.character(order.beta), ")", sep = "")
}
# Compose Mean-Variance Formula Object:
if (formula.mean == "") {
formula = as.formula(paste("~", formula.var))
} else {
formula = as.formula(paste("~", formula.mean, "+", formula.var))
}
# Add NULL default entries:
if (is.null(model$mu)) model$mu = 0
if (is.null(model$ar)) model$ar = 0
if (is.null(model$ma)) model$ma = 0
if (is.null(model$gamma)) model$gamma = rep(0, times = order.alpha)
# print(unlist(model))
# Seed:
if (is.null(rseed)) {
rseed = 0
} else {
set.seed(rseed)
}
# Define Missing Presample:
order.max = max(order.ar, order.ma, order.alpha, order.beta)
iterate = TRUE
if (!is.matrix(presample)) {
if (is.null(presample)) {
iterate = FALSE
n.start = order.max
} else {
n.start = presample
}
z = rnorm(n = n.start)
# GARCH(p, q):
h = rep(model$omega/(1-sum(model$alpha)-sum(model$beta)),
times = n.start)
y = rep(model$mu/(1-sum(model$ar)), times = n.start)
# APARCH(p,q):
# ... we initialize all models with norm-GARCH(p,q) processes
} else {
z = presample[, 1]
h = presample[, 2]
y = presample[, 3]
}
presample = cbind(z, h, y)
# Presample Iteration:
if (iterate) {
n.iterate = length(z) - order.max
deltainv = 1/model$delta
for (i in n.iterate:1) {
h[i] = model$omega +
sum(model$alpha*(abs(abs(y[i+(1:order.alpha)]) -
model$gamma*y[i+(1:order.alpha)])^model$delta)) +
sum(model$beta*h[i+(1:order.beta)])
y[i] = model$mu +
sum(model$ar*y[i+(1:order.ar)]) +
sum(model$ma*(h[i+(1:order.ma)]**deltainv)) +
h[i]^deltainv * z[i]
}
}
# Result:
new("fGARCHSPEC",
call = match.call(),
formula = formula,
model = list(omega = model$omega, alpha = model$alpha,
gamma = model$gamma, beta = model$beta, mu = model$mu,
ar = model$ar, ma = model$ma, delta = model$delta,
skew = model$skew, shape = model$shape),
presample = as.matrix(presample),
distribution = as.character(cond.dist),
rseed = as.numeric(rseed)
)
}
################################################################################
fGarch/R/loglik-egarch.R 0000644 0001762 0000144 00000001707 15104730075 014507 0 ustar ligges users
# This library is free software; you can redistribute it and/or
# modify it under the terms of the GNU Library General Public
# License as published by the Free Software Foundation; either
# version 2 of the License, or (at your option) any later version.
#
# This library 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 Library General Public License for more details.
#
# You should have received a copy of the GNU Library General
# Public License along with this library; if not, write to the
# Free Foundation, Inc., 59 Temple Place, Suite 330, Boston,
# MA 02111-1307 USA
################################################################################
# FUNCTION: DESCRIPTION:
# .egarchLLH ARMA-EGARCH model
################################################################################
fGarch/R/methods-predict.R 0000644 0001762 0000144 00000027265 15104730075 015101 0 ustar ligges users
# This library is free software; you can redistribute it and/or
# modify it under the terms of the GNU Library General Public
# License as published by the Free Software Foundation; either
# version 2 of the License, or (at your option) any later version.
#
# This library 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 Library General Public License for more details.
#
# You should have received a copy of the GNU Library General
# Public License along with this library; if not, write to the
# Free Foundation, Inc., 59 Temple Place, Suite 330, Boston,
# MA 02111-1307 USA
################################################################################
# METHOD: PREDICTION:
# predict.fGARCH Forecasts from an object of class 'fGARCH'
################################################################################
setMethod(f = "predict", signature(object = "fGARCH"), definition =
function(object, n.ahead = 10, trace = FALSE,
mse = c("cond","uncond"),
plot=FALSE, nx=NULL, crit_val=NULL, conf=NULL, ...,
p_loss = NULL # GNB: for ES and VaR
)
{
# A function implemented by Diethelm Wuertz
# Description:
# Prediction method for an object of class fGARCH
# Arguments:
# object an object of class fGARCH as returned by the
# function garchFit().
# n.ahead number of steps to be forecasted, an integer
# value, by default 10)
# trace should the prediction be traced? A logical value,
# by default FALSE)
# mse should the mean squared errors be conditional or unconditional
# plot should the predictions be plotted
# nx The number of observations to be plotted with the predictions
# (If plot is TRUE, the default value of nx is the sample
# size times 0.25.)
# crit_va If you want to set manually the critical values for
# the confidence intervals
# conf The confidence level for computing the critical values
# of the confidence intervals
# FUNCTION:
mse <- match.arg(mse)
# Retrieve "fit" from Parameter Estimation:
fit = object@fit
# Get ARMA(u,v)-GARCH(p,q) Order:
u = fit$series$order[1]
v = fit$series$order[2]
p = fit$series$order[3]
q = fit$series$order[4]
max.order = max(u, v, p, q)
# Get Start Conditions:
h.start = fit$series$h.start
llh.start = fit$series$llh.start
index = fit$params$index
params = fit$params$params
par = fit$par
Names = names(index)
for (Name in Names) params[Name] = par[Name]
Names = names(params)
# Retrieve From Initialized Parameters:
cond.dist = fit$params$cond.dist
# Extract the Parameters by Name:
leverage = fit$params$leverage
mu = params["mu"]
if (u > 0) {
ar = params[substr(Names, 1, 2) == "ar"]
} else {
ar = c(ar1 = 0)
}
if (v > 0) {
ma = params[substr(Names, 1, 2) == "ma"]
} else {
ma = c(ma1 = 0)
}
omega = params["omega"]
if (p > 0) {
alpha = params[substr(Names, 1, 5) == "alpha"]
} else {
alpha = c(alpha1 = 0)
}
if (p > 0 & leverage) {
gamma = params[substr(Names, 1, 5) == "gamma"]
} else {
gamma = c(gamma1 = 0)
}
if (q > 0) {
beta = params[substr(Names, 1, 4) == "beta"]
} else {
beta = c(beta1 = 0)
}
delta = params["delta"]
skew = params["skew"]
shape = params["shape"]
# Trace Parameters:
if (trace) {
cat("\nModel Parameters:\n")
print(c(mu, ar, ma, omega, alpha, gamma, beta, delta, skew, shape))
}
# Retrieve Series Lengths:
M = n.ahead
N = length(object@data)
# Get and Extend Series:
x = c(object@data, rep(mu, M))
h = c(object@h.t, rep(0, M))
z = c(fit$series$z, rep(mu, M))
# Forecast and Optionally Trace Variance Model:
var.model = fit$series$model[2]
# Forecast GARCH Variance:
if (var.model == "garch") {
if (trace) cat("\nForecast GARCH Variance:\n")
for (i in 1:M) {
h[N+i] = omega + sum(beta*h[N+i-(1:q)])
for (j in 1:p) {
if (i-j > 0) {
s = h[N + i - j]
} else {
s = z[N + i - j]^2
}
h[N+i] = h[N+i] + alpha[j] * s
}
}
}
# Forecast APARCH Variance:
if (var.model == "aparch") {
if (trace) cat("\nForecast APARCH Variance:\n")
for (i in 1:M) {
h[N+i] = omega + sum(beta*h[N+i-(1:q)])
for (j in 1:p) {
## 2024-01-30 GNB: TODO:
## it seems that kappa doesn't depend on i;
## so, kappa[1], ..., kappa[p] can be computed outside the i-loop
## and the formulas below use kappa[j]
kappa = garchKappa(cond.dist = cond.dist, gamma = gamma[j],
delta = delta, skew = skew, shape = shape)
if (i-j > 0) {
s = kappa * h[N + i - j]
} else {
s = (abs(z[N + i - j]) - gamma[j]*z[N + i - j])^delta
}
h[N+i] = h[N+i] + alpha[j] * s
}
}
}
# Forecast and Optionally Trace Mean Model:
# Note we set maxit=0 to get an object of class Arima with fixed
# init parameters ...
mu <- mu/(1-sum(ar))
ARMA <- arima(x = object@data, order = c(max(u, 1), 0, max(v, 1)),
init = c(ar, ma, mu), transform.pars = FALSE,
optim.control = list(maxit = 0))
prediction = predict(ARMA, n.ahead)
meanForecast = as.vector(prediction$pred)
if(mse=="uncond") {
meanError = as.vector(prediction$se)
} else {
# coefficients of h(t+1)
a_vec <- rep(0,(n.ahead))
hhat <- h[-(1:N)]^(2/delta[[1]]) #-> [[1]] to omit name of delta
u2 <- length(ar)
meanError <- hhat[1]
a_vec[1] = ar[1] + ma[1]
meanError <- na.omit(c(meanError,sum(hhat[1:2]*c(a_vec[1]^2,1))))
if ((n.ahead - 1) > 1) {
for( i in 2:(n.ahead - 1)) {
a_vec[i] <- ar[1:min(u2,i-1)]*a_vec[(i-1):(i-u2)] +
ifelse(i>u,0,ar[i]) + ifelse(i>v,0,ma[i])
meanError <- na.omit(c(meanError,
sum(hhat[1:(i+1)]*c(a_vec[i:1]^2,1))))
}
}
meanError <- sqrt(meanError)
}
if (trace) {
cat("\nForecast ARMA Mean:\n")
print(ARMA)
cat("\n")
print(prediction)
}
# Standard Deviations:
standardDeviation = h^(1/delta)
# Plotting the predictions
if (plot) {
if(is.null(nx))
nx <- round(length(object@data)*.25)
t <- length(object@data)
x <- c(object@data[(t-nx+1):t],meanForecast)
# Computing the appropriate critical values
if (is.null(conf))
conf <- 0.95
if (is.null(crit_val)) {
if (object@fit$params$cond.dist=="norm") {
crit_valu <- qnorm(1-(1-conf)/2)
crit_vald <- qnorm((1-conf)/2)
}
if (object@fit$params$cond.dist=="snorm") {
crit_valu <- qsnorm(1-(1-conf)/2,xi=coef(object)["skew"])
crit_vald <- qsnorm((1-conf)/2,xi=coef(object)["skew"])
}
if (object@fit$params$cond.dist=="ged") {
crit_valu <- qged(1-(1-conf)/2,nu=coef(object)["shape"])
crit_vald <- qged((1-conf)/2,nu=coef(object)["shape"])
}
if (object@fit$params$cond.dist=="sged") {
crit_valu <- qsged(1-(1-conf)/2,nu=coef(object)["shape"],
xi=coef(object)["skew"])
crit_vald <- qsged((1-conf)/2,nu=coef(object)["shape"],
xi=coef(object)["skew"])
}
if (object@fit$params$cond.dist=="std") {
crit_valu <- qstd(1-(1-conf)/2,nu=coef(object)["shape"])
crit_vald <- qstd((1-conf)/2,nu=coef(object)["shape"])
}
if (object@fit$params$cond.dist=="sstd") {
crit_valu <- qsstd(1-(1-conf)/2,nu=coef(object)["shape"],
xi=coef(object)["skew"])
crit_vald <- qsstd((1-conf)/2,nu=coef(object)["shape"],
xi=coef(object)["skew"])
}
if (object@fit$params$cond.dist=="snig") {
crit_valu <- qsnig(1-(1-conf)/2,zeta=coef(object)["shape"],
rho=coef(object)["skew"])
crit_vald <- qsnig((1-conf)/2,zeta=coef(object)["shape"],
rho=coef(object)["skew"])
}
if (object@fit$params$cond.dist=="QMLE") {
e <- sort(object@residuals/object@sigma.t)
crit_valu <- e[round(t*(1-(1-conf)/2))]
crit_vald <- e[round(t*(1-conf)/2)]
}
} else {
if (length(crit_val)==2) {
crit_valu <- crit_val[2]
crit_vald <- crit_val[1]
}
if (length(crit_val)==1) {
crit_valu <- abs(crit_val)
crit_vald <- -abs(crit_val)
}
}
int_l <- meanForecast+crit_vald*meanError
int_u <- meanForecast+crit_valu*meanError
ylim_l <- min(c(x,int_l)*(.95))
ylim_u <- max(c(x,int_u)*(1.05))
plot(x,type='l',ylim=c(ylim_l,ylim_u))
title("Prediction with confidence intervals")
lines((nx+1):(nx+n.ahead), meanForecast, col = 2, lwd = 2)
lines((nx+1):(nx+n.ahead), int_l, col = 3, lwd = 2)
lines((nx+1):(nx+n.ahead), int_u, col = 4, lwd = 2)
polygon(c((nx+1):(nx+n.ahead),(nx+n.ahead):(nx+1)),
c(int_l, int_u[n.ahead:1]),
border = NA, density = 20, col = 5, angle = 90)
es1 <- as.expression(substitute(hat(X)[t+h] + crit_valu*sqrt(MSE),
list(crit_valu=round(crit_valu,3))))
es2 <- as.expression(substitute(hat(X)[t+h] - crit_vald*sqrt(MSE),
list(crit_vald=abs(round(crit_vald,3)))))
es3 <- expression(hat(X)[t+h])
legend("bottomleft",c(es3,es2,es1),col=2:4,lty=rep(1,3),lwd=rep(2,3))
grid()
}
## Result:
forecast <- data.frame(
meanForecast = meanForecast,
meanError = meanError,
standardDeviation = standardDeviation[-(1:N)])
if(plot)
forecast = data.frame(
forecast,
lowerInterval = int_l,
upperInterval = int_u)
## if(plot) {
## forecast = data.frame(
## meanForecast = meanForecast,
## meanError = meanError,
## standardDeviation = standardDeviation[-(1:N)],
## lowerInterval = int_l,
## upperInterval = int_u)
## } else {
## forecast = data.frame(
## meanForecast = meanForecast,
## meanError = meanError,
## standardDeviation = standardDeviation[-(1:N)])
## }
## 2024-01-31 GNB: VaR and ES - experimental
if(!is.null(p_loss)) {
cond_dist <- object@fit$params$cond.dist
mu_t <- meanForecast
sigma_t <- standardDeviation[-(1:N)]
qf <- qfun_fGarch(cond_dist, coef(object))
predVaR <- cvar::VaR_qf(qf, p_loss, intercept = mu_t, slope = sigma_t)
predES <- cvar::ES(qf, p_loss, intercept = mu_t, slope = sigma_t)
forecast <- data.frame(forecast, VaR = predVaR, ES = predES)
attr(forecast, "p_loss") <- p_loss
}
# Return Value:
forecast
})
################################################################################
fGarch/R/methods-coef.R 0000644 0001762 0000144 00000004146 15104730075 014354 0 ustar ligges users
# This library is free software; you can redistribute it and/or
# modify it under the terms of the GNU Library General Public
# License as published by the Free Software Foundation; either
# version 2 of the License, or (at your option) any later version.
#
# This library 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 Library General Public License for more details.
#
# You should have received a copy of the GNU Library General
# Public License along with this library; if not, write to the
# Free Foundation, Inc., 59 Temple Place, Suite 330, Boston,
# MA 02111-1307 USA
################################################################################
# METHOD: EXTRACTORS:
# coef.fGARCH Extracts 'fGarch' Model Coefficients
################################################################################
setMethod(f = "coef", signature(object = "fGARCH"), definition =
function(object)
{
# A function implemented by Diethelm Wuertz
# Description:
# Extracts 'fGarch' Model Coefficients
# Arguments:
# object - an object of class fGarch as returned by the function
# garchFit
# FUNCTION:
# Numeric vector of fitted values:
ans = slot(object, "fit")$coef
# Return Value:
ans
})
# ------------------------------------------------------------------------------
setMethod(f = "coef", signature(object = "fGARCHSPEC"), definition =
function(object)
{
# A function implemented by Diethelm Wuertz
# Description:
# Extracts 'fGarch' Model Coefficients
# Arguments:
# object - an object of class fGarch as returned by the function
# garchFit
# FUNCTION:
# Numeric vector of fitted values:
ans = unlist(slot(object, "model"))
attr(ans, "distribution") <- slot(object, "distribution")
# Return Value:
ans
})
################################################################################
fGarch/R/dist-snormSlider.R 0000644 0001762 0000144 00000007051 15104730075 015237 0 ustar ligges users
# This library is free software; you can redistribute it and/or
# modify it under the terms of the GNU Library General Public
# License as published by the Free Software Foundation; either
# version 2 of the License, or (at your option) any later version.
#
# This library 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 Library General Public License for more details.
#
# You should have received a copy of the GNU Library General
# Public License along with this library; if not, write to the
# Free Foundation, Inc., 59 Temple Place, Suite 330, Boston,
# MA 02111-1307 USA
################################################################################
# FUNCTION: DESCRIPTION:
# snormSlider Displays Normal Distribution and RVS
################################################################################
snormSlider <-
function(type = c("dist", "rand"))
{
# A function implemented by Diethelm Wuertz
# Description:
# Displays interactively skew Normal distribution
# Note:
# dsnorm(x, mean = 0, sd = 1, xi = 1.5)
# FUNCTION:
# Internal Function:
refresh.code = function(...)
{
# Sliders:
N = .sliderMenu(no = 1)
mean = .sliderMenu(no = 2)
sd = .sliderMenu(no = 3)
xi = .sliderMenu(no = 4)
invert = .sliderMenu(no = 5)
# Compute Data:
if (invert == 1) xi = 1/xi
xmin = round(qsnorm(0.001, mean, sd, xi), digits = 2)
xmax = round(qsnorm(0.999, mean, sd, xi), digits = 2)
s = seq(xmin, xmax, length = N)
y1 = dsnorm(s, mean, sd, xi)
y2 = psnorm(s, mean, sd, xi)
main1 = paste("Skew Normal Density\n",
"mean = ", as.character(mean), " | ",
"sd = ", as.character(sd), " | ",
"xi = ", as.character(xi) )
main2 = paste("Skew Normal Probability\n",
"xmin [0.001] = ", as.character(xmin), " | ",
"xmax [0.999] = ", as.character(xmax) )
# Random Numbers:
if (type[1] == "rand") {
x = rsnorm(N, mean, sd, xi)
}
# Frame:
par(mfrow = c(2, 1), cex = 0.7)
# Density:
if (type[1] == "rand") {
hist(x, probability = TRUE, col = "steelblue", border = "white",
breaks = "FD",
xlim = c(xmin, xmax), ylim = c(0, 1.1*max(y1)), main = main1 )
lines(s, y1, col = "orange")
} else {
plot(s, y1, type = "l", xlim = c(xmin, xmax), col = "steelblue")
abline (h = 0, lty = 3)
title(main = main1)
grid()
}
# Probability:
plot(s, y2, type = "l", xlim = c(xmin, xmax), ylim = c(0, 1),
col = "steelblue" )
abline (h = 0, lty = 3)
title(main = main2)
grid()
# Frame:
par(mfrow = c(1, 1), cex = 0.7)
}
# Open Slider Menu:
.sliderMenu(refresh.code,
names = c( "N", "mean", "sd", "xi", "xi.inv"),
minima = c( 10, -5.0, 0.1, 1.0, 0 ),
maxima = c( 500, +5.0, 5.0, 10.0, 1 ),
resolutions = c( 10, 0.1, 0.1, 0.1, 1 ),
starts = c( 100, 0.0, 1.0, 1.0, 0 )
)
}
################################################################################
fGarch/R/dist-sstd.R 0000644 0001762 0000144 00000015233 15104730075 013714 0 ustar ligges users
# This library is free software; you can redistribute it and/or
# modify it under the terms of the GNU Library General Public
# License as published by the Free Software Foundation; either
# version 2 of the License, or (at your option) any later version.
#
# This library 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 Library General Public License for more details.
#
# You should have received a copy of the GNU Library General
# Public License along with this library; if not, write to the
# Free Foundation, Inc., 59 Temple Place, Suite 330, Boston,
# MA 02111-1307 USA
################################################################################
# FUNCTION: DESCRIPTION:
# dsstd Density for the skewed Student-t Distribution
# psstd Probability function for the skewed STD
# qsstd Quantile function for the skewed STD
# rsstd Random Number Generator for the skewed STD
# FUNCTION: DESCRIPTION:
# .dsstd Internal, density for the skewed Student-t Distribution
# .psstd Internal, probability function for the skewed STD
# .qsstd Internal, quantile function for the skewed STD
# .rsstd Internal, random Number Generator for the skewed STD
################################################################################
dsstd <-
function(x, mean = 0, sd = 1, nu = 5, xi = 1.5, log = FALSE)
{
# A function implemented by Diethelm Wuertz
# Description:
# Compute the density function of the
# skewed Student-t distribution
# FUNCTION:
# Params:
if (length(mean) == 4) {
xi = mean[4]
nu = mean[3]
sd = mean[2]
mean = mean[1]
}
# Shift and Scale:
result = .dsstd(x = (x-mean)/sd, nu = nu, xi = xi) / sd
# Log:
if(log) result = log(result)
# Return Value:
result
}
# ------------------------------------------------------------------------------
psstd <-
function(q, mean = 0, sd = 1, nu = 5, xi = 1.5)
{
# A function implemented by Diethelm Wuertz
# Description:
# Compute the distribution function of the
# skewed Student-t distribution
# FUNCTION:
# Shift and Scale:
result = .psstd(q = (q-mean)/sd, nu = nu, xi = xi)
# Return Value:
result
}
# ------------------------------------------------------------------------------
qsstd <-
function(p, mean = 0, sd = 1, nu = 5, xi = 1.5)
{
# A function implemented by Diethelm Wuertz
# Description:
# Compute the quantile function of the
# skewed Student-t distribution
# FUNCTION:
# Shift and Scale:
result = .qsstd(p = p, nu = nu, xi = xi) * sd + mean
# Return Value:
result
}
# ------------------------------------------------------------------------------
rsstd <-
function(n, mean = 0, sd = 1, nu = 5, xi = 1.5)
{
# A function implemented by Diethelm Wuertz
# Description:
# Generate random deviates from the
# skewed Student-t distribution
# FUNCTION:
# Shift and Scale:
result = .rsstd(n = n, nu = nu, xi = xi) * sd + mean
# Return Value:
result
}
################################################################################
.dsstd <-
function(x, nu, xi)
{
# A function implemented by Diethelm Wuertz
# Description:
# Internal Function
# FUNCTION:
# For SPlus compatibility:
if (!exists("beta"))
beta <- function (a, b) exp( lgamma(a) + lgamma(b) -lgamma(a+b) )
# Standardize:
m1 = 2 * sqrt(nu-2) / (nu-1) / beta(1/2, nu/2)
mu = m1*(xi-1/xi)
sigma = sqrt((1-m1^2)*(xi^2+1/xi^2) + 2*m1^2 - 1)
z = x*sigma + mu
# Compute:
Xi = xi^sign(z)
g = 2 / (xi + 1/xi)
Density = g * dstd(x = z/Xi, nu = nu)
# Return Value:
Density * sigma
}
# ------------------------------------------------------------------------------
.psstd <-
function(q, nu, xi)
{
# A function implemented by Diethelm Wuertz
##
## fixed by GNB, see section 'CHANGES in fGarch VERSION 4021.87, 2022-08-06', subsection
## 'BUG fixes' in NEWS.Rd.
# Description:
# Internal Function
# FUNCTION:
# For SPlus compatibility:
if (!exists("beta"))
beta <- function (a, b) exp( lgamma(a) + lgamma(b) -lgamma(a+b) )
# Standardize:
m1 = 2 * sqrt(nu-2) / (nu-1) / beta(1/2, nu/2)
mu = m1*(xi-1/xi)
sigma = sqrt((1-m1^2)*(xi^2+1/xi^2) + 2*m1^2 - 1)
z = q*sigma + mu
# Compute:
sig <- ifelse(z >= 0, 1, -1) # note: 1 for z = 0; was sign(z)
Xi = xi^sig # not sign(z)
g = 2 / (xi + 1/xi)
# was: Probability = Heaviside(z) - sign(z) * g * Xi * pstd(q = -abs(z)/Xi, nu = nu)
Probability = ifelse(z >= 0, 1, 0) - sig * g * Xi * pstd(q = -abs(z)/Xi, nu = nu)
# Return Value:
Probability
}
# ------------------------------------------------------------------------------
.qsstd <-
function(p, nu, xi)
{
# A function implemented by Diethelm Wuertz
##
## fixed by GNB, see section 'CHANGES in fGarch VERSION 4021.87, 2022-08-06', subsection
## 'BUG fixes' in NEWS.Rd.
# Description:
# Internal Function
# FUNCTION:
# For SPlus compatibility:
if (!exists("beta"))
beta <- function (a, b) exp( lgamma(a) + lgamma(b) -lgamma(a+b) )
# Standardize:
m1 = 2 * sqrt(nu-2) / (nu-1) / beta(1/2, nu/2)
mu = m1*(xi-1/xi)
sigma = sqrt((1-m1^2)*(xi^2+1/xi^2) + 2*m1^2 - 1)
# Compute:
g = 2 / (xi + 1/xi)
pxi <- p - (1 / (1 + xi^2)) # not p - 1/2
sig <- sign(pxi) # not p - 1/2
Xi = xi^sig
p = (Heaviside(pxi) - sig * p) / (g * Xi) # pxi, not p - 1/2
Quantile = (-sig*qstd(p = p, sd = Xi, nu = nu) - mu ) / sigma
# Return Value:
Quantile
}
# ------------------------------------------------------------------------------
.rsstd <-
function(n, nu, xi)
{
# A function implemented by Diethelm Wuertz
# Description:
# Internal Function
# FUNCTION:
# For SPlus compatibility:
if (!exists("beta"))
beta <- function (a, b) exp( lgamma(a) + lgamma(b) -lgamma(a+b) )
# Generate Random Deviates:
weight = xi / (xi + 1/xi)
z = runif(n, -weight, 1-weight)
Xi = xi^sign(z)
Random = -abs(rstd(n, nu = nu))/Xi * sign(z)
# Scale:
m1 = 2 * sqrt(nu-2) / (nu-1) / beta(1/2, nu/2)
mu = m1*(xi-1/xi)
sigma = sqrt((1-m1^2)*(xi^2+1/xi^2) + 2*m1^2 - 1)
Random = (Random - mu ) / sigma
# Return value:
Random
}
################################################################################
fGarch/R/mgarch-FitFromFormula.R 0000644 0001762 0000144 00000011263 15104730075 016130 0 ustar ligges users
# This library is free software; you can redistribute it and/or
# modify it under the terms of the GNU Library General Public
# License as published by the Free Software Foundation; either
# version 2 of the License, or (at your option) any later version.
#
# This library 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 Library General Public License for more details.
#
# You should have received a copy of the GNU Library General
# Public License along with this library; if not, write to the
# Free Foundation, Inc., 59 Temple Place, Suite 330, Boston,
# MA 02111-1307 USA
################################################################################
# FUNCTION: PARAMETER ESTIMATION:
# .gogarchFit Fits the parameters of a GO-GARCH process
################################################################################
.gogarchFit <-
function(formula = ~ garch(1, 1), data,
init.rec = c("mci", "uev"),
delta = 2,
skew = 1,
shape = 4,
cond.dist = c("norm", "snorm", "ged", "sged", "std", "sstd", "snig", "QMLE"),
include.mean = TRUE,
include.delta = NULL,
include.skew = NULL,
include.shape = NULL,
leverage = NULL,
trace = TRUE,
algorithm = c("nlminb", "lbfgsb", "nlminb+nm", "lbfgsb+nm"),
hessian = c("ropt", "rcd"),
control = list(),
title = NULL,
description = NULL,
...)
{
# A function implemented by Diethelm Wuertz
# Description:
# Fits a GO-Garch Model using Independent Component Analysis
# Arguments:
# The arguments are the same as for the univariate case.
# formula - formula for all marginal models
# data - multivariate timeSeries object
# ...
# Value:
# S4 Object of class (univariate) fGARCH ...
# Notes:
# This function has still a preliminary status ...
# This function was inspired from the contributed gogarch
# package of Bernhard Pfaff.
# Example:
# require(fEcofin); data(DowJones30)
# X = returns(as.timeSeries(DowJones30)); head(X)
# N = 5; ans = .gogarchFit(data = X[, 1:N], trace = FALSE); ans
# ans@h.t
# FUNCTION:
# Multivariate ?
stopifnot(isMultivariate(data))
# Data:
X = data
# Marginal Garch Models:
garchControl = list(
init.rec = init.rec, delta = delta, skew = skew, shape = shape,
cond.dist = cond.dist, include.mean = include.mean,
include.delta = include.delta, include.skew = include.skew,
include.shape = include.shape, leverage = leverage,
trace = trace, algorithm = algorithm, hessian = hessian,
control = control, title = title, description = description)
# Compute fastICA:
# ... the following lines of code were borrowed from
# Bernhard Pfaff's contributed package gogarch
V <- t(X) %*% X / nrow(X)
svd <- svd(V)
P <- svd$u
Dsqr <- diag(sqrt(svd$d))
# set.seed(4711)
ica <- fastICA::fastICA(X, n.comp = ncol(X))
Z <- P %*% Dsqr %*% t(P) %*% ica$W
colnames(Z) = rownames(Z) = colnames(data)
Y <- X %*% solve(Z)
# Fit Marginal Garch Models:
fit <- apply(Y, 2, function(x) do.call("garchFit",
c(list(formula = formula, data = x), garchControl)))
# Compute Conditional Variances:
# ... the following lines of code were borrowed from
# Bernhard Pfaff's contributed package gogarch
H <- matrix(unlist(lapply(fit, function(x) x@h.t)),
ncol = ncol(X), nrow = nrow(X))
Hdf <- data.frame(t(H))
rownames(Hdf) <- colnames(data)
colnames(Hdf) <- rownames(data)
H.t <- lapply(Hdf, function(x) Z %*% diag(x) %*% t(Z))
# Add Title and Description:
if(is.null(title)) title = "ICA GO-GARCH Modelling"
if(is.null(description)) description = description()
# Result:
ans <- new("fGARCH",
call = as.call(match.call()),
formula = formula,
method = "ICA go-Garch Parmeter Estimation",
data = c(Records = nrow(data), Instruments = ncol(data)),
fit = fit,
residuals = numeric(),
fitted = numeric(),
h.t = c(Records = length(H.t), Dimension =dim(H.t[[1]])),
sigma.t = numeric(),
title = title,
description = description
)
# Multivariate Series:
attr(ans@data, "data") <- data
attr(ans@h.t, "H.t") <- H.t
# Return Value:
ans
}
################################################################################
fGarch/R/methods-residuals.R 0000644 0001762 0000144 00000003447 15104730075 015436 0 ustar ligges users
# This library is free software; you can redistribute it and/or
# modify it under the terms of the GNU Library General Public
# License as published by the Free Software Foundation; either
# version 2 of the License, or (at your option) any later version.
#
# This library 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 Library General Public License for more details.
#
# You should have received a copy of the GNU Library General
# Public License along with this library; if not, write to the
# Free Foundation, Inc., 59 Temple Place, Suite 330, Boston,
# MA 02111-1307 USA
################################################################################
# METHOD: EXTRACTORS:
# residuals.fGARCH S4 residuals method for an object of class 'fGARCH'
################################################################################
setMethod(f = "residuals", signature(object = "fGARCH"), definition =
function(object, standardize = FALSE)
{
# A function implemented by Diethelm Wuertz
# Description:
# S4 Residuals method for an object of class fGARCH
# Arguments:
# object - an object of class fGarch as returned by the
# function garchFit
# ... - optional argument to be passed, this may be standardize=FALSE
# to return the -non-standardized values of the residuals.
# By default standardized residuals will be returned.
# FUNCTION:
# Residuals:
if (standardize) {
ans = object@residuals/object@sigma.t
} else {
ans = object@residuals
}
# Return Value:
ans
})
# ------------------------------------------------------------------------------
fGarch/R/methods-formula.R 0000644 0001762 0000144 00000002755 15104730075 015111 0 ustar ligges users
# This library is free software; you can redistribute it and/or
# modify it under the terms of the GNU Library General Public
# License as published by the Free Software Foundation; either
# version 2 of the License, or (at your option) any later version.
#
# This library 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 Library General Public License for more details.
#
# You should have received a copy of the GNU Library General
# Public License along with this library; if not, write to the
# Free Foundation, Inc., 59 Temple Place, Suite 330, Boston,
# MA 02111-1307 USA
################################################################################
# FUNCTION: DESCRIPTION:
# formula.fGARCH Extracts 'fGarch' Model formulaficients
################################################################################
setMethod(f = "formula", signature(x = "fGARCH"), definition =
function(x)
{
# A function implemented by Diethelm Wuertz
# Description:
# Extracts 'fGarch' Model formula
# Arguments:
# x - an object of class fGarch as returned by the function
# garchFit
# FUNCTION:
# Numeric vector of fitted values:
ans = slot(x, "formula")
# Return Value:
ans
})
################################################################################
fGarch/R/methods-volatility.R 0000644 0001762 0000144 00000004243 15104730075 015636 0 ustar ligges users
# This library is free software; you can redistribute it and/or
# modify it under the terms of the GNU Library General Public
# License as published by the Free Software Foundation; either
# version 2 of the License, or (at your option) any later version.
#
# This library 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 Library General Public License for more details.
#
# You should have received a copy of the GNU Library General
# Public License along with this library; if not, write to the
# Free Foundation, Inc., 59 Temple Place, Suite 330, Boston,
# MA 02111-1307 USA
################################################################################
# METHOD: EXTRACTORS:
# volatility.fGARCH Returns conditional volatilities for 'fGARCH' objects
################################################################################
volatility.fGARCH <-
## better to use S3 style because volatility is defined as a S3 generic
## setMethod(f = "volatility", signature(object = "fGARCH"), definition =
function(object, type = c("sigma", "h"), ...)
{
# A function implemented by Diethelm Wuertz
# Description:
# Returns conditional volatilities for 'fGARCH' objects
# Arguments:
# object - an object of class 'fGarch' as returned by the function
# garchFit
# type - a character string denoting if the conditional standard
# deviations "sigma" or the variances "h" should be returned.
# ... - optional argument to be passed, not used.
# Note:
# "volatility" is a generic function. It's default method calculates
# (x-mean(x))^2.
# FUNCTION:
# Match Arguments:
type = match.arg(type)
# Numeric vectors of conditional values:
if (type == "sigma") {
volatility = slot(object, "sigma.t")
} else if (type == "h") {
volatility = slot(object, "h.t")
}
attr(volatility, "type") <- type
# Return Value:
volatility
}
##)
################################################################################
fGarch/R/garch-Initialization.R 0000644 0001762 0000144 00000025755 15104730075 016061 0 ustar ligges users
# This library is free software; you can redistribute it and/or
# modify it under the terms of the GNU Library General Public
# License as published by the Free Software Foundation; either
# version 2 of the License, or (at your option) any later version.
#
# This library 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 Library General Public License for more details.
#
# You should have received a copy of the GNU Library General
# Public License along with this library; if not, write to the
# Free Foundation, Inc., 59 Temple Place, Suite 330, Boston,
# MA 02111-1307 USA
################################################################################
# FUNCTION: DESCRIPTION:
# .garchInitSeries Initializes Series
# .garchInitParameters Initializes Parameters
################################################################################
.garchInitSeries <-
function(formula.mean, formula.var, cond.dist, series, scale, init.rec,
h.start, llh.start, trace)
{
# A function implemented by Diethelm Wuertz
# Description:
# Initialize time series
# Arguments:
# see function garchFit()
# FUNCTION:
# Check Mean Formula ARMA - Is it Valid ?
mm = length(formula.mean)
if(mm != 2) stop("Mean Formula misspecified")
end = regexpr("\\(", as.character(formula.mean[mm])) - 1
model.mean = substr(as.character(formula.mean[mm]), 1, end)
if(!any( c("ar", "ma", "arma") == model.mean))
stop("formula.mean must be one of: ar, ma, arma")
# Check Variance Formula GARCH - Is it Valid ?
mv = length(formula.var)
if(mv != 2) stop("Variance Formula misspecified")
end = regexpr("\\(", as.character(formula.var[mv])) - 1
model.var = substr(as.character(formula.var[mv]), 1, end)
if(!any( c("garch", "aparch") == model.var))
stop("formula.var must be one of: garch, aparch")
# Determine Mean Order from ARMA Formula:
model.order = as.numeric(strsplit(strsplit(strsplit(as.character(
formula.mean), "\\(")[[2]][2], "\\)")[[1]], ",")[[1]])
u = model.order[1]
v = 0
if(length(model.order) == 2) v = model.order[2]
maxuv = max(u, v)
if(u < 0 | v < 0) stop("*** ARMA orders must be positive.")
# Determine Variance Order from GARCH Formula:
model.order = as.numeric(strsplit(strsplit(strsplit(as.character(
formula.var), "\\(")[[2]][2], "\\)")[[1]], ",")[[1]])
p = model.order[1]
q = 0
if(length(model.order) == 2) q = model.order[2]
if(p+q == 0)
stop("Misspecified GARCH Model: Both Orders are zero!")
maxpq = max(p, q)
if(p < 0 | q < 0) stop("*** GARCH orders must be positive.")
# Fix Start Position of Series "h" and for Likelihood Calculation:
max.order = max(maxuv, maxpq)
if(is.null(h.start)) h.start = max.order + 1
if(is.null(llh.start)) llh.start = 1
# Check for Recursion Initialization:
if(init.rec != "mci" & model.var != "garch") {
stop("Algorithm only supported for mci Recursion")
}
# Trace the Result:
if(trace) {
cat("\nSeries Initialization:")
cat("\n ARMA Model: ", model.mean)
cat("\n Formula Mean: ", as.character(formula.mean))
cat("\n GARCH Model: ", model.var)
cat("\n Formula Variance: ", as.character(formula.var))
cat("\n ARMA Order: ", u, v)
cat("\n Max ARMA Order: ", maxuv)
cat("\n GARCH Order: ", p, q)
cat("\n Max GARCH Order: ", maxpq)
cat("\n Maximum Order: ", max.order)
cat("\n Conditional Dist: ", cond.dist)
cat("\n h.start: ", h.start)
cat("\n llh.start: ", llh.start)
cat("\n Length of Series: ", length(series))
cat("\n Recursion Init: ", init.rec)
cat("\n Series Scale: ", scale)
cat("\n\n")
}
# Result:
ans = list(
model = c(model.mean, model.var),
order = c(u = u, v = v, p = p, q = q),
max.order = max.order,
z = rep(0, times = length(series)),
h = rep(var(series), times = length(series)),
x = series,
scale = scale,
init.rec = init.rec,
h.start = h.start,
llh.start = llh.start)
# Return Value:
ans
}
# ------------------------------------------------------------------------------
.garchInitParameters <-
function(formula.mean, formula.var, delta, skew, shape, cond.dist,
include.mean, include.delta, include.skew, include.shape, leverage,
algorithm, control, trace)
{
# A function implemented by Diethelm Wuertz
# Description:
# Initialize model parameters
# Arguments:
# see function garchFit()
# FUNCTION:
# DEBUG:
.DEBUG = FALSE
# global variables
.series <- .getfGarchEnv(".series")
# Determine Mean Order from ARMA Formula:
model.order = as.numeric(strsplit(strsplit(strsplit(as.character(
formula.mean), "\\(")[[2]][2], "\\)")[[1]], ",")[[1]])
u = model.order[1]
v = 0
if(length(model.order) == 2) v = model.order[2]
# Determine Variance Order from GARCH Formula:
model.order = as.numeric(strsplit(strsplit(strsplit(as.character(
formula.var), "\\(")[[2]][2], "\\)")[[1]], ",")[[1]])
p = model.order[1]
if (p == 0) stop("The order p must be > 0 in GARCH/APARCH(p,q)")
q = 0
if(length(model.order) == 2) q = model.order[2]
# Includes:
model.var = .series$model[2]
if(is.null(include.delta)) {
if(model.var == "garch") {
include.delta = FALSE
} else {
include.delta = TRUE
}
}
if(is.null(leverage)) {
if(model.var == "garch") {
leverage = FALSE
} else {
leverage = TRUE
}
}
# Distributional Includes:
if(cond.dist == "t") cond.dist = "std"
skewed.dists = c("snorm", "sged", "sstd", "snig")
if(is.null(include.skew)) {
if(any(skewed.dists == cond.dist)) {
include.skew = TRUE
} else {
include.skew = FALSE
}
}
shaped.dists = c("ged", "sged", "std", "sstd", "snig")
if(is.null(include.shape)) {
if(any(shaped.dists == cond.dist)) {
include.shape = TRUE
} else {
include.shape = FALSE
}
}
# Set Names for Parameters:
Names = c(
"mu",
if(u > 0) paste("ar", 1:u, sep = ""),
if(v > 0) paste("ma", 1:v, sep = ""),
"omega",
if(p > 0) paste("alpha", 1:p, sep = ""),
if(p > 0) paste("gamma", 1:p, sep = ""),
if(q > 0) paste("beta", 1:q, sep = ""),
"delta",
"skew",
"shape")
if(.DEBUG) { cat("\nDEBUG - Names: \n"); print(Names) }
# Initialize Model Parameters to be Estimated:
fit.mean = arima(.series$x, order = c(u, 0, v),
include.mean = include.mean)$coef
alpha.start = 0.1
beta.start = 0.8
## if(include.delta) delta = 1.5
params = c(
if(include.mean) fit.mean[length(fit.mean)] else 0,
if(u > 0) fit.mean[1:u],
if(v > 0) fit.mean[(u+1):(length(fit.mean)-as.integer(include.mean))],
var(.series$x, na.rm = TRUE)*(1-alpha.start-beta.start),
if(p > 0) rep(alpha.start/p, times = p),
if(p > 0) rep(0.1, times = p),
if(q > 0) rep(beta.start/q, times = q),
delta,
skew,
shape)
names(params) = Names
if(.DEBUG) { cat("\nDEBUG - params: \n"); print(params) }
# Set Lower Limits of Parameters to be Estimated:
TINY = 1.0e-8
USKEW = 1/10; USHAPE = 1
if (cond.dist == "snig") USKEW = -0.99
U = c(
-10*abs(mean(.series$x)),
if(u > 0) rep(-1+TINY, times = u),
if(v > 0) rep(-1+TINY, times = v),
1.0e-6*var(.series$x),
if(p > 0) rep( 0+TINY, times = p),
if(p > 0) rep(-1+TINY, times = p),
if(q > 0) rep( 0+TINY, times = q),
0, # delta
USKEW, # skew
USHAPE) # shape
names(U) = Names
if(.DEBUG) { cat("\nDEBUG - U: \n"); print(U) }
# Set Upper Limits of Parameters to be Estimated:
VSKEW = 10; VSHAPE = 10
if (cond.dist == "snig") VSKEW = 0.99
V = c(
10*abs(mean(.series$x)),
if(u > 0) rep(1-TINY, times = u),
if(v > 0) rep(1-TINY, times = v),
100*var(.series$x),
if(p > 0) rep(1-TINY, times = p),
if(p > 0) rep(1-TINY, times = p),
if(q > 0) rep(1-TINY, times = q),
2, # delta
VSKEW, # skew
VSHAPE) # shape
names(V) = Names
if(.DEBUG) { cat("\nDEBUG - V: \n"); print(V) }
# Includes:
includes = c(
include.mean,
if(u > 0) rep(TRUE, times = u),
if(v > 0) rep(TRUE, times = v),
TRUE,
if(p > 0) rep(TRUE, times = p),
if(p > 0) rep(leverage, times = p),
if(q > 0) rep(TRUE, times = q),
include.delta,
include.skew,
include.shape)
names(includes) = Names
if(.DEBUG) { cat("\nDEBUG - V: \n"); print(includes) }
# Index List of Parameters to be Optimized:
index = (1:length(params))[includes == TRUE]
names(index) = names(params)[includes == TRUE]
if(.DEBUG) { cat("\nDEBUG - fixed: \n"); print(index) }
# Persistence:
alpha <- beta <- NULL
if(p > 0) alpha = params[substr(Names, 1, 5) == "alpha"]
if(p > 0 & leverage) gamma = params[substr(Names, 1, 5) == "gamma"]
if(p > 0 & !leverage) gamma = rep(0, times = p)
if(q > 0) beta = params[substr(Names, 1, 4) == "beta"]
if(.series$model[2] == "garch") {
persistence = sum(alpha) + sum(beta)
} else if(.series$model[2] == "aparch") {
persistence = sum(beta)
for (i in 1:p)
persistence = persistence + alpha[i]*garchKappa(cond.dist,
gamma[i], params["delta"], params["skew"], params["shape"])
}
names(persistence) = "persistence"
# Trace the Result:
if(trace) {
cat("Parameter Initialization:")
cat("\n Initial Parameters: $params")
cat("\n Limits of Transformations: $U, $V")
cat("\n Which Parameters are Fixed? $includes")
cat("\n Parameter Matrix:\n")
ans = data.frame(U, V, params, includes)
rownames(ans) = paste(" ", names(params))
print(ans)
cat(" Index List of Parameters to be Optimized:\n")
print(index)
cat(" Persistence: ", persistence, "\n")
}
# Return Value:
list(params = params,
U = U,
V = V,
includes = includes,
index = index,
mu = params[1],
delta = delta,
skew = skew,
shape = shape,
cond.dist = cond.dist,
leverage = leverage,
persistence = persistence,
control = control)
}
################################################################################
fGarch/R/class-fGARCHSPEC.R 0000644 0001762 0000144 00000002422 15104730075 014542 0 ustar ligges users
# This library is free software; you can redistribute it and/or
# modify it under the terms of the GNU Library General Public
# License as published by the Free Software Foundation; either
# version 2 of the License, or (at your option) any later version.
#
# This library 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 Library General Public License for more details.
#
# You should have received a copy of the GNU Library General
# Public License along with this library; if not, write to the
# Free Foundation, Inc., 59 Temple Place, Suite 330, Boston,
# MA 02111-1307 USA
################################################################################
# FUNCTION: SPECIFICATION:
# fGARCHSPEC S4 fGARCHSPEC Class representation
################################################################################
setClass("fGARCHSPEC",
representation(
call = "call",
formula = "formula",
model = "list",
presample = "matrix",
distribution = "character",
rseed = "numeric")
)
################################################################################
fGarch/R/dist-std.R 0000644 0001762 0000144 00000006047 15104730075 013534 0 ustar ligges users
# This library is free software; you can redistribute it and/or
# modify it under the terms of the GNU Library General Public
# License as published by the Free Software Foundation; either
# version 2 of the License, or (at your option) any later version.
#
# This library 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 Library General Public License for more details.
#
# You should have received a copy of the GNU Library General
# Public License along with this library; if not, write to the
# Free Foundation, Inc., 59 Temple Place, Suite 330, Boston,
# MA 02111-1307 USA
################################################################################
# FUNCTION: DESCRIPTION:
# dstd Density for the Student-t Distribution
# pstd Probability function for the Student-t Distribution
# qstd Quantile function for the Student-t Distribution
# rstd Random Number Generator for the Student-t
################################################################################
dstd <-
function(x, mean = 0, sd = 1, nu = 5, log = FALSE)
{
# A function implemented by Diethelm Wuertz
# Description:
# Compute the density for the
# Student-t distribution.
# FUNCTION:
# Params:
if (length(mean) == 3) {
nu = mean[3]
sd = mean[2]
mean = mean[1]
}
# Compute Density:
s = sqrt(nu/(nu-2))
z = (x - mean) / sd
result = dt(x = z*s, df = nu) * s / sd
# Log:
if(log) result = log(result)
# Return Value:
result
}
# ------------------------------------------------------------------------------
pstd <-
function (q, mean = 0, sd = 1, nu = 5)
{
# A function implemented by Diethelm Wuertz
# Description:
# Compute the probability for the
# Student-t distribution.
# FUNCTION:
# Compute Probability:
s = sqrt(nu/(nu-2))
z = (q - mean) / sd
result = pt(q = z*s, df = nu)
# Return Value:
result
}
# ------------------------------------------------------------------------------
qstd <-
function (p, mean = 0, sd = 1, nu = 5)
{
# A function implemented by Diethelm Wuertz
# Description:
# Compute the quantiles for the
# Student-t distribution.
# FUNCTION:
# Compute Quantiles:
s = sqrt(nu/(nu-2))
result = qt(p = p, df = nu) * sd / s + mean
# Return Value:
result
}
# ------------------------------------------------------------------------------
rstd <-
function(n, mean = 0, sd = 1, nu = 5)
{
# A function implemented by Diethelm Wuertz
# Description:
# Generate random deviates from the
# Student-t distribution.
# FUNCTION:
# Generate Random Deviates:
s = sqrt(nu/(nu-2))
result = rt(n = n, df = nu) * sd / s + mean
# Return Value:
result
}
################################################################################
fGarch/R/fGarch-package.R 0000644 0001762 0000144 00000001443 15104730075 014557 0 ustar ligges users
# This library is free software; you can redistribute it and/or
# modify it under the terms of the GNU Library General Public
# License as published by the Free Software Foundation; either
# version 2 of the License, or (at your option) any later version.
#
# This library 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 Library General Public License for more details.
#
# You should have received a copy of the GNU Library General
# Public License along with this library; if not, write to the
# Free Foundation, Inc., 59 Temple Place, Suite 330, Boston,
# MA 02111-1307 USA
################################################################################
fGarch/R/garch-Gradient.R 0000644 0001762 0000144 00000006020 15104730075 014607 0 ustar ligges users
# This library is free software; you can redistribute it and/or
# modify it under the terms of the GNU Library General Public
# License as published by the Free Software Foundation; either
# version 2 of the License, or (at your option) any later version.
#
# This library 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 Library General Public License for more details.
#
# You should have received a copy of the GNU Library General
# Public License along with this library; if not, write to the
# Free Foundation, Inc., 59 Temple Place, Suite 330, Boston,
# MA 02111-1307 USA
################################################################################
# FUNCTION: PARAMETER ESTIMATION:
# .garchRCDAGradient Computes R coded CDA matrix of contributions
# to the Gradient
################################################################################
.garchRCDAGradient <-
function(par, .params, .series, eps = 1.0e-4)
{
# A function implemented by Michal Miklovic & Yohan Chalabi
# Description:
# Compute R coded CDA (central difference approximated) Gradient
# Reference:
# http://status.sph.umich.edu/computing/manuals/sas8/stat/chap46/sect26.htm
# FUNCTION:
# Starttime
.StartGradient <- Sys.time()
# Algorithm
algorithm = .params$control$algorithm[1]
.trace = FALSE
# LLH for the computation of matrix of contributions to the Gradient
skew <- .params$skew
shape <- .params$shape
delta <- .params$delta
deltainv = 1/delta
llh.start = .series$llh.start
N <- length(.series$x)
.garchDist <- .getfGarchEnv(".garchDist")
# Compute matrix of contributions to the Gradient:
eps = eps * par
n = N - llh.start + 1
K = length(par)
G = matrix(0, nrow = n, ncol = K)
for (i in 1:K) {
x1 = x2 = par
x1[i] = x1[i] + eps[i]
x2[i] = x2[i] - eps[i]
#
.garchLLH(x1, .trace, TRUE)
h1 <- .getfGarchEnv(".series")$h
z1 <- .getfGarchEnv(".series")$z
hh1 = (abs(h1[(llh.start):N]))^deltainv
zz1 = z1[(llh.start):N]
llh.grad1 <-
log(.garchDist(z = zz1, hh = hh1, skew = skew, shape = shape))
#
.garchLLH(x2, .trace, TRUE)
h2 <- .getfGarchEnv(".series")$h
z2 <- .getfGarchEnv(".series")$z
hh2 = (abs(h2[(llh.start):N]))^deltainv
zz2 = z2[(llh.start):N]
llh.grad2 <-
log(.garchDist(z = zz2, hh = hh2, skew = skew, shape = shape))
#
G[,i] = (llh.grad1 - llh.grad2) / (2*eps[i])
}
rownames(G) = c(1:n)
colnames(G) = names(par)
# make sure that h and z are ok
.setfGarchEnv(.series = .series)
time = Sys.time() - .StartGradient
# Attribute Exdecution time
attr(G, "time") = time
# Return Value:
G
}
################################################################################
fGarch/R/methods-summary.R 0000644 0001762 0000144 00000020440 15104730075 015130 0 ustar ligges users
# This library is free software; you can redistribute it and/or
# modify it under the terms of the GNU Library General Public
# License as published by the Free Software Foundation; either
# version 2 of the License, or (at your option) any later version.
#
# This library 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 Library General Public License for more details.
#
# You should have received a copy of the GNU Library General
# Public License along with this library; if not, write to the
# Free Foundation, Inc., 59 Temple Place, Suite 330, Boston,
# MA 02111-1307 USA
################################################################################
# FUNCTION: DESCRIPTION:
# summary Summary method for an object of class 'fGARCH'
################################################################################
.fGARCH_summary_body_orig <- function(object) {
## A function implemented by Diethelm Wuertz
## modified by GNB: replaced [] indices with [[]] indices.
##
## With the [] indices the extracted elements remain lists, resulting in
## a matrix with list elements. The only change in the printed output
## though is that while formerly the numbers were aligned on the left,
## now they are aligned as numbers (on the decimal point).
# Description:
# Summary method for an object of class "fGARCH"
# Arguments:
# object - an object of class 'fGARCH'
# FUNCTION:
# same output as show method
show(object)
# Lagged Series:
.tslagGarch = function (x, k = 1) {
ans = NULL
for (i in k) ans = cbind(ans, .tslag1Garch(x, i))
indexes = (1:length(ans[, 1]))[!is.na(apply(ans, 1, sum))]
ans = ans[indexes, ]
if (length(k) == 1) ans = as.vector(ans)
ans }
.tslag1Garch = function (x, k) {
c(rep(NA, times = k), x[1:(length(x) - k)]) }
# Statistical Tests:
cat("\nStandardised Residuals Tests:\n")
r.s = object@residuals/object@sigma.t
ans = NULL
# Normality Tests:
jbtest = jarqueberaTest(r.s)@test
ans = rbind(ans, c(jbtest[[1]], jbtest[[2]]))
if (length(r.s) < 5000) {
swtest = shapiro.test(r.s)
if (swtest[[2]] < 2.6e-16) swtest[[2]] = 0
ans = rbind(ans, c(swtest[[1]], swtest[[2]]))
} else {
ans = rbind(ans, c(NA, NA))
}
# Ljung-Box Tests:
box10 = Box.test(r.s, lag = 10, type = "Ljung-Box")
box15 = Box.test(r.s, lag = 15, type = "Ljung-Box")
box20 = Box.test(r.s, lag = 20, type = "Ljung-Box")
ans = rbind(ans, c(box10[[1]], box10[[3]]))
ans = rbind(ans, c(box15[[1]], box15[[3]]))
ans = rbind(ans, c(box20[[1]], box20[[3]]))
box10 = Box.test(r.s^2, lag = 10, type = "Ljung-Box")
box15 = Box.test(r.s^2, lag = 15, type = "Ljung-Box")
box20 = Box.test(r.s^2, lag = 20, type = "Ljung-Box")
ans = rbind(ans, c(box10[[1]], box10[[3]]))
ans = rbind(ans, c(box15[[1]], box15[[3]]))
ans = rbind(ans, c(box20[[1]], box20[[3]]))
# Ljung-Box Tests - tslag required
lag.n = 12
x.s = as.matrix(r.s)^2
n = nrow(x.s)
tmp.x = .tslagGarch(x.s[, 1], 1:lag.n)
tmp.y = x.s[(lag.n + 1):n, 1]
fit = lm(tmp.y ~ tmp.x)
stat = (n-lag.n) * summary.lm(fit)$r.squared
ans = rbind(ans, c(stat, p.value = 1 - pchisq(stat, lag.n)) )
# Add Names:
rownames(ans) = c(
" Jarque-Bera Test R Chi^2 ",
" Shapiro-Wilk Test R W ",
" Ljung-Box Test R Q(10) ",
" Ljung-Box Test R Q(15) ",
" Ljung-Box Test R Q(20) ",
" Ljung-Box Test R^2 Q(10) ",
" Ljung-Box Test R^2 Q(15) ",
" Ljung-Box Test R^2 Q(20) ",
" LM Arch Test R TR^2 ")
colnames(ans) = c("Statistic", "p-Value")
print(ans)
# Information Criterion Statistics:
cat("\nInformation Criterion Statistics:\n")
print(object@fit$ics)
# Return Value:
cat("\n")
invisible()
}
.lm_arch_test <- function(r.s) {
## Lagged Series:
.tslagGarch <- function (x, k = 1) {
ans <- NULL
for (i in k)
ans <- cbind(ans, .tslag1Garch(x, i))
indexes <- (1:length(ans[, 1]))[!is.na(apply(ans, 1, sum))]
ans <- ans[indexes, ]
if (length(k) == 1)
ans <- as.vector(ans)
ans
}
.tslag1Garch <- function (x, k)
c(rep(NA, times = k), x[1:(length(x) - k)])
## LM Arch test - tslag required
lag.n <- 12
x.s <- as.matrix(r.s)^2
n <- nrow(x.s)
tmp.x <- .tslagGarch(x.s[, 1], 1:lag.n)
tmp.y <- x.s[(lag.n + 1):n, 1]
fit <- lm(tmp.y ~ tmp.x)
stat <- (n-lag.n) * summary.lm(fit)$r.squared
c(stat, p.value = 1 - pchisq(stat, lag.n))
}
.fGARCH_show_stat_test <- function(object) {
r.s <- object@residuals/object@sigma.t
ans <- NULL
## Normality Tests:
jbtest <- jarqueberaTest(r.s)@test
ans <- rbind(ans, c(jbtest[[1]], jbtest[[2]]))
if (length(r.s) < 5000) {
swtest <- shapiro.test(r.s)
if (swtest[[2]] < 2.6e-16) swtest[[2]] = 0
ans <- rbind(ans, c(swtest[[1]], swtest[[2]]))
} else {
ans <- rbind(ans, c(NA, NA))
}
## Ljung-Box Tests:
## residuals
box10 <- Box.test(r.s, lag = 10, type = "Ljung-Box")
box15 <- Box.test(r.s, lag = 15, type = "Ljung-Box")
box20 <- Box.test(r.s, lag = 20, type = "Ljung-Box")
ans <- rbind(ans, c(box10[[1]], box10[[3]]))
ans <- rbind(ans, c(box15[[1]], box15[[3]]))
ans <- rbind(ans, c(box20[[1]], box20[[3]]))
## squared residuals
box10 <- Box.test(r.s^2, lag = 10, type = "Ljung-Box")
box15 <- Box.test(r.s^2, lag = 15, type = "Ljung-Box")
box20 <- Box.test(r.s^2, lag = 20, type = "Ljung-Box")
ans <- rbind(ans, c(box10[[1]], box10[[3]]))
ans <- rbind(ans, c(box15[[1]], box15[[3]]))
ans <- rbind(ans, c(box20[[1]], box20[[3]]))
## LM Arch test - tslag required
archtest <- .lm_arch_test(r.s)
ans <- rbind(ans, archtest)
## Add Names:
rownames(ans) <- c(
" Jarque-Bera Test R Chi^2 ",
" Shapiro-Wilk Test R W ",
" Ljung-Box Test R Q(10) ",
" Ljung-Box Test R Q(15) ",
" Ljung-Box Test R Q(20) ",
" Ljung-Box Test R^2 Q(10) ",
" Ljung-Box Test R^2 Q(15) ",
" Ljung-Box Test R^2 Q(20) ",
" LM Arch Test R TR^2 ")
colnames(ans) <- c("Statistic", "p-Value")
ans
}
summary.fGARCH <- function(object) {
res <- list(
show = .prepare_GARCH_show(object),
stat_tests = .fGARCH_show_stat_test(object),
ics = object@fit$ics )
class(res) <- "summary_fGARCH"
res
}
print.summary_fGARCH <- function(x, ..., classic = FALSE) {
# cat(x$show, sep = "\n")
.show_orig_body(x$show, prepare = FALSE)
cat("\n")
cat("\nStandardised Residuals Tests:\n")
if(classic)
print(x$stat_tests[1:9, ]) # cat() doesn't work, it's an odd matrix
else
## TODO: at least put tests for the fitted distribution,
## rather than always giving the normality tests;
## see the qq-plot function .plot.garch.13 for a way to extract
## cond. dist. package 'goftest' seems suitable
##
## for now, same as for classic = TRUE
print(x$stat_tests)
cat("\nInformation Criterion Statistics:\n")
print(x$ics)
cat("\n")
invisible(x)
}
setMethod(f = "summary", signature(object = "fGARCH"),
function(object, ...) {
## original code by by Diethelm Wuertz,
## see .fGARCH_summary_body_orig()
## completely refactored and modified by Georgi Boshnakov (GNB)
res <- summary.fGARCH(object, ...)
## For compatibility, show the old summary when computing the
## object Note that the print method has 'classic = FALSE'
## default, so if the object is assigned and then printed, the
## result will be with the new default.
print(res, classic = TRUE)
invisible(res)
})
################################################################################
fGarch/data/ 0000755 0001762 0000144 00000000000 15116751403 012360 5 ustar ligges users fGarch/data/dem2gbp.csv.gz 0000644 0001762 0000144 00000027625 15116751403 015050 0 ustar ligges users ‹ uKŽ$AŒ\÷sо@
üÿÙ
´ ûŸFfôa:øº½è@fz¸ÓI#i$ÿçÿú?íÿÿûâ¯ügm³÷vÖŸÿúûߥ³G['?Y}¬ºwû<Ñ£ÖÖ®·}ŸüèIÕw;á3ú¥Ù×ÎOêêe—ò}¢Œ1·~©æß锡¥ço›eÔYk‡µõ¾ÏZŸUëA¹§ÔÝwÍOÎðâ:ìNëŒRáÛúåÖyó“UJ½{Á)Ìs†V=òªõ*§îñÝ}FSO[>sÆg~W{P—¾žx׎6œVP–F¿3ÏnçÂ^ëËô$É›Wp$#'í¨Ÿ´r%pŸÏü„ŒÞ{梵5wiß}³T±g/7f è=¸ê~|¬ùÛúžõ’Þ6Ç^£ÏGOnÙ»×üm?õ?»d·¸%óŽ»GIOô™Rô‰·qì=ô[ðm]bµç"©ÚU+èß÷ñ)¬v‡^ŠV°ÆœiÕþ¶v$Wß“ó“]}QÒ·éÉѽÚã>8Ï}I»èx´pë%í³œöù6ËN½ºW÷{·CN]ï
+¸m÷5áI¯¥ÕS@Bælþ·Þ–$'I¯G_²ãµ•®
J§ío[e®†šb©ª§ÐDk-ð>wHHSèb-áï-–ÂÖ¥ájå1êèÉ–ø–\m¡½nëêÖµrØŸÚtvôõ>Òt¢.ãí
ßt4«Ñ‘¿ÕîD;*s!)ÈZl}ì»×>SÝ·[;iÝÑu’eŠÏœrõVð¤.éñ
O¶ìß8_ö§ª[VæJïõ[á´-’DØ·&
"Åó•ëø)e1àI]E7¸Â
´e]¸Þç^iù•dçÇ:Qj¯OØ7É›4Ü-&¹‘„|Ù“iÅE°í%{Ÿô¨qÈÍö@›}ê$¼3u…×äÐÊè»ÐªÏ‘N¾4¬^tΞn}œöºú§äϬ=dÏ*Þ2ï÷M½;³X¬à¬[GÒ‰¾õGF«$;g©ºKƱ‘æ»2sç€ì´}¥G“$Zè*´EXLÊ¥ÙýýÄÊJêM*á{>qƒ…açLZÌ+ûtx¢#0\ÎOd1…"hÿV–ÐI|5x*„:%RÒVó»>…&˜8’¦\Õõÿé´cgè~¿-0’ÔA¶sÞë&°6üNmºÛ3!¡ÐoúÐ"»]eL¥ªÀbÌQ¼×´jkIóä'Úœ.‰[2o•ð$ÌHhëæ“†Õ†nÙ@Ò×2rk‘-¹ÍZ>ießýŠüÒUIƒ„)F—"OÈ;|&™’sè3ºÂ{÷-´ÿÃë†÷Ñi˪£—±I®§hÕ$½q¦ºõ'éÃHSvžÔ^{Égc[äànwÚ+¦ LÞ¤vŽÐ`ëB/›|¦.áJ"l)£µ²¼ùÛ„4ŠÔoþ6™Eð5Ÿ¶ÔºoBÏÏêù}âM¥‘gûz,qÚåN¹èà;O{Y²µùwnÑí9ä}T]ùŽ{ /XÆ6ýNÜSãTº²§R ô›^Sx+íNèÄ;ÏMþODdèÑfùxtFd´ ù‡de¦Lpí U²?ƪ°;[ Ò÷$¯öYdÎJþŒ¤PBJwN—Êñº§²š-Ûz{`M7¡$øç|3©Þ/óæh]SÐ’Êð Áï5È£¼Ó¤BŒ>O|礔k%èoú‡\wÝ’žõ›}M™Úñ¨ßTïs‹û³·\Ç¿w'ö`émóªÛžMb5Òr]Ó›†Ï´¯Ü6x"9yøŒ,}m¨‘té®Ü‚üD~}×ÅÙÙ~5Â|R,Kz$Ù¹ŸÉ)yâC ö&o*ÞGú²QdAß$›AÚE^š'¡ ë¢Û]?º7ÎgJê]?oxtI[WŒyÙ£E_×>+x¿#¡’
!û#õ&ƒ´Øñ9tÈ6gG2¾Æ(¨|9Aòø«ý•Œ{ŸTÉÙ#¯ºÊšü}ÚïÖGì4ùÛá¹^aoò»üSýì›ô«´%á*Y¦SfŽâXWiqã+ÏfId «)ÕÒÑ–•FVsÉ5ìä›I
åñoV<‘X/°oS ä&|¸J0d&¿1dTÖ§'[âÝÒ"gÂÝ^mKH;yÕ²²’ø6I»6"´] âÞïòÁuÒHX„uáKƒR-ùÈ„jÚYB¸pìSëàJ^ÁÙ‚ø9JíóYrÚzŠ9D„I>]£×eî9Jï#E~)†bì^ŒWI»ÊÒ~W8±Ûg‚µÕc\S(þ&$·žbò@k²?¿1bÇêaßäPE£¿½¤+*eldÉš¤‡V=„inÂþ#ŽD~‰4¢„¬æ,‚ד¢8£wéµîÉzº·Ø- ©ºˆ)´1ÇpöM—Án[~"ýá
é·}„("#ŸvH(š·d~yF:y»”EK=´6²šÇé,òO·C±s,mЇònŠ=…E·g”Pt`X¡ÁAqK‡P-WIܵDÄóHÁ‘¾–Žw¬‘Ðz1jhG…ØFè*yS;i¾89=ØiÕqëçu.fJ<6Æ:›\׎÷tLŸå³dš
Þ.s‘ò!!gëY:ŸðŒ–|©Ypöòx Ù_ˆx|³ƒ'ò}NIZìɵ4EBøŽ‡HÁUÀñBëöó:ÅT{öÇX€Àº=’DçàìÜÓªkæ£øŽDQWn–6§9ýo:ÙÝ$ñûz ¿é"–óE\uJ¦JŠN>]m‘X·8†ž§JëøÚÿޤCp‘÷p8œä@ÛyÖ¢»=ëKqŠX›îÔ”UÏHCÖ|Öþú&]ÎZyK ïH•ënÁÚ†~®¯Í
û3egg~ÙÓ+ÉÉQ‚¸?Bø9¯iéíÞ̈Œ+ÙEw[òFˆkvé–‘4…w§ÚE'm)!”ÕNw;l½`üN±õнGðòõU«„Áˆµ:Ø29[’ÿºJJ´“ìÈ‘ºR0蛕9r\,üm®RŬM»#TÓ*ùV‰]/”?#sAø-b\c9t
Ÿqic¼Jޏ\ °2ËNSÿF¿ÂnK[ÛÍßæÛ(ÈN8DCpùñx]BvÕÐ…â|ÃùÛ$½!æÕàûèe´s”/Yç,ÝßOÂÓ“K[’_ÿÎôN!O¼Û¾ä!7Dê7êaÍ×·½gZ›d€7v
Ž!ÞÞ“\~çi$‡=(î"ojÈ—¸vtܘýßUJÖÖœt®÷©é|¬«–TÒZÿð$dO(«(u°ŸÂ''-¡"YlèUI‡Üsõ„¼Ã®*”sàiíKñóÕ:ßz©ñûÎ@ YZÝ`i*ÂUíV‰1-†…í¦×Ÿ—•—ò#+#¯uîŒjôd‡9¥¨® ±Cþ‰ræ´Köt>éb9ÛÆ™XT²€ë6Š÷ÚuŸ“NAöO`•V`¶‰,E=äÊ· î3ÐmCÞnŠW?DÒØ0êqÍ ¨a•´Ì] /u€,*)‰Ýþ‘Ÿó+aät«ûH–i‰e´÷gšGçÓG¹…2PS¾™´jÍK,cûüù‰Ž´9è
»së_3ä@ç#¿#à¯ÃK·DºªÙ3Šq™¢›Jžk_ÅŠ'¯@Gãf"÷Z‡PÍ(S€â†A²?”Û•ª¸Ù“ˆ¨”´Ù§ÕݶJ*Ȧ»ö¥ˆ;9dµ6(')X˜;
9í|ß'òºò²Ï„¯¥Êý) 1Ì|Š?Aþó3W.CŠ‚'Îf•HR¥7-)ßøó¢Z6²&œb"Ÿ4EØ'Ôˆ5!í*óC¿3p>¨ùtMW¾õ!;º#)Þûî°Æ¼
Tå¼R”àQnHâåXö×A›-õ¹ÛÙ^ÃŽ#ìÁ’‹~rt?âHÂU'±ÂšŒ,ƒ=‹„„¸ò\oG_¦X)¦LÊŸ°Á„oJÛ9/c
;œV$´>tp:ÕϪ_Ü_Á—o*MÎQw9+N&7æ,)N;êo£»m¶åeNÉh33¢BB“š”ê«;éJvÁ¼EÈ{ÛÖoäAáe‹x•@Ÿœ ºsBÕ}·d
}ÛJFÏ?+ØÏµ&>ßï
–ê!M¾LMg‹îÀvKqòŸ‡æ%ϵ_sçÓmü1“yF8"ïN¤½î¾‰5éÛ‚å¶êÉHõÝGÃI‡ ÁEn¸¤pvŒ»nèÞ“V6æD¾Ü*EÃw›zSŠV:EGñ7g¦+…xeë(“bÆgûæ>^lC7µ&Ö^H|äC‹®ÿ/Y¨N
!ÏN‡}OɨF2:ûÑ¢Û(+|s4¼‚jÆÀw?pˆ4GóŒ¬G³§÷§¹Èf¥:–ÿò>ÌÎÎoº¢´}ç.`52×]ß¶ÌïBâ{u2/Ú¼
ÙçAÜ"m€.>VÉ—’µ¥Ûت”â'Bþ©óÑ3WjøþHÜ/æ\Í”¤¹©»fæAÆû\ˆFüê‰6ÙŸàCá
ÖÝî#quÿm,´²€º\x…OCfÏ}ÊŸ1eAê§™Ú#éõuÖ¸;òÏ{²´¿>“I¤ÉefwöümM7¡knÉîÌ2êØSŽ„—sÌ*ù‰¼P,KˆíÏ]ùñÓžYÆäo6é »Ú3C.h3%8Ÿœ¿MdŸ%“ÙGf|ÆgL|"ÏÕ5wŠÐîbŠÈøÛ"\Å5rÞ/1ãtå3Kåe]Š®Øg’;w2F²ÞiN¥Ó¾™z“¼Yû²¶tœÏïšk¼jÃ
Ô½SZ§¤íCiB¤˜oœ¶197™â¼"|F·^:b(’›ëº˜ï·ù–èÚªŽ’q.k\}Ts>+òšºÚ²}céºÁ³umNfUÚã—žÀˆL?mÝR5„+i²FŠ,lSâÌýú§ÞjÊÜõ)‘OÖÙXL€ë̯}º·®'·^253GÓ»c’í¨Ãñ&}æ7•QØëÍ–Ùã»×±¶fžÙS³ÆKÇ®° 'È›•NÁ¨‡ÜV×w€Ä¨ú2À
šÄ01CB¤§.¢ i^yÕ´oQÆ‚U>B|ºÝ´£ÝEw‡DTJàP¾ÞqÎUWoZÃ\õÙ.¤oAÀ
K™¹õ/.› ì7Bñx+kÌV4W¦.òÛ¼ªØ¹~ûO|æJõRmŸËÀVÒUQï|º%‹®×9È<2€Dm)÷YT«;Ö‰ö4W‘¾^ªRÖ×.†T,ñ„š6¿·1îœÜ©–ã£Æú_ÝmBÞ¥›qƒQÃ-‹•tUÄC\j•lý¯ù´ÿü2Év¾õÞ‰AfM¾®zFåH—k)+"OÜ…m •goÂ
–óS'žötX9ñ‘þ®àPäGÊRŠ”|¦átòêÒ¢™¡"@ÜS5ÑÏ«v¶râvhs5«¥WhtyÑïf9tšê¦Ú´åèWDó¶‹%aεc„¼Î%ˆ’+”_C š2žW¸åôÌi´ÄËǨ)N§ÝWEnž„£˜©š?#
v\}™?ã0Ÿë_àÉv#ŽœI‰® S‹F4¨Kz‰ir³—ù,ÀBѯk&LöebG‰²È´èN°ƒ¶\«¹Œž´e³§I«vçŠúåï¼˜Ã®î ©²ëq ‡4W7Bi:Qcå¿çE[ïtAY³^Þ-ùÛš ¬5YÚWI38+"”(]EU³‚ð§LŠ_Kv«Ì6¬À<”™#Û!2õ#ùfêèÙkó™úÎå
¾ðO¯3³Ç:Þ±cÒUÇu4¹*&4y5·ˆ¼w¡·š{鄎כ^¬´•žêõz7ÂGI<»d>¬Ïçnöu†¶ì: ü>‘M’c”ª–žk§çÝ »íÐ-wÙ‘ˆ¬%°Þ©Zqh—ËS&2¤j›ÑøÝѧaµÕ)JýjyÜ—‡°ÿmª’'a’Ûiȼš2Ú‹<£‚ÜÛäEN]O‹Læ=Oî»ò'¢»!×}™9X0lQL†â3r=n®&zñk)Ó›Ãxª_pd²cí¿ÙÂ;W¼9»¬]ãüÂù%këQÿj—à™èÞˆµ·\Œ‘«Éu2Ý Uö޵˜ ¿)o&,¦›ò½!‰’WÌäH‚¿öç'ªoä”äÎVaƒu};á·ãÓÉÑ¢È3'æé}|؃º)¸µ—ql^[_gì[ä¸i¾ëÎ"ýr&wÜ€U; ƒÕÆ&à n ç*ß9ÇýŸuž]ˤ¿\óö`o´%f‚.ĉSV³äZ߈8›¼BÝ!Ž3”ˆötÑVÀJ#šPÍo:Ú7:(Àzô`ÖwÔ•YÉqf‘ÚA2F›¹Â%˜#‚׉±[×WBžÉûæ6E‹¤aÝQŽ"?v7ÅÒÌ·iÕ•·²6Ö£W“
Ñwžîₜ`‰€}3:¹æZìÿ&@qwºëlá‚åo3
ßP>#:RåpèãÎl¥^ýþ£Å2 ²“¸¬(²„„ÄcŠ÷J
¤èM
-‘…h¼ÆÈ\•y&L®‘ZÄxÈ2Ó›™Ù‘øE
ëŠêûÕvtÙ¡,œ §˜o.Ûj
—z•F@?KzJň]æQÙ‡Ÿ¨Ž’ÝÄo“O?SåãÏooß)¢ùë/´ÄÁxŸ±HçkÒßàRoÇJy îÇø}S[q'*®:—ç\R´ÕwÁHùëM)Š‚5]2Û%k>¯ÍôƒöEªÁrp2e½C°Yn¦
säSùXû2NŽ4>”¶K®|ŒŽFî‚Ä·^§&—*O¬É3æ«)?ï[d ÌŠ"nžã3w̉|°ŒÉ Åa`¿+ì[ßþBZÁ*î̆œ9ù?—jI“)¹º=´Ë†\ð¤N©ë¯®ò›Îíä;å뇯fû¤ôúÂÞtר¿P„ɤ “çói
«*êþéj¢Œ¯#ÿ#<¿üø¸Ûîú•üŸ‡—>‚ѼëZ_Š_o7¥™ðŽê„(îâ!…¢–œ–ëBâK>EÌ$Ÿ-÷ô»íF«'e "º2Bæò‹ÁœéwÂwvæŽ:©U¡h‰wœŸŸi}A;lc`eÐ|c;’†‘…9¦ýýäENýQÞ„¸ZöÑÃsý ·èåô ³âÏë= _o¹ZÄ9íîj¸ˆOîJž‚=r¥ž¢Üûq‹PƒPÚ7rúóºP¬™ëÃo”v„¯G?aìáwÜ`s`Í&pQýO–ÜOHNå¥^UV»- jD$ ÖeXÄrÓ~vîÏg¶ýN̸‘ÙËeðdN‡qÉ0tìX ‡©tŠëÆËd`籨m§î*n`¼&vm8æKSíKŸî°Fýä|u»MðD*öfä»?G~#sW–Õµ |1EØ)庨Éugìƒ}
ÝÔ)g¿õ^r‡™À–®õ"ßY¢™ŒümÎa—Ìâ
ý¹wXµ3ß{à鉷š»)4sQþ~#:D}õA쨀¼n0ÝmWboª–œŽîgvzDÐú°†Ùþ.ëÊ+03¢eÝv»O›º¼‚jNKÆ?AŸ-û2±;F£ÔÙÊ&³¥È\ØÁ'Ý!òø
:Å•…žÌi§ÓžV‰ß(º»ž ûhkÜÖ¦/›©ÓÃÏo¥“ãÇywltµ¸‹‹°ox—á&Þ†û.Kï†uŽ2UjÄûh3aØx)Y³!t1?׋+m)nÙܹ{|Öè(NUrΘM oÚ´§‰ßûl£.äÎGÀ®cä´Ê9ã,¶ä]›M¶¾Éa9):Ò+)Ü™=ó'x(Ô³´:9Æñƒ=ÍÜ`ÏÕ$^Š÷º *Eã‰F'b$¹5×7†æ+BÞ”û°šX™Eõ~„æà‰»|&ûóôŽóÞÔŸo¹YgêFòçÕ™Ð@½é$Ù}R…ålÑ…4_Ð~óoÊMm©³omNדÞÑÝvû\ø˜nªIùhºOærÜO•ù°óÈhv¹Ž÷¸»uR®Žú xÜ~ öÀ©¾A½µ\ŽqS¯Êï]8è/N.õO9ä¶CO”suùxêÇ¿3ä¿§ß -枥ٯ»}Ü!bO÷᛹{7KþÏÁ.°M²˜úN>‹xôýJŽá?”&Tñ½§±ó0±3©ðV›ØßRÈRŽ=iŠv¶[‡KÇ4JÌÅ^Ü¿òÎî~³ròаZØ×ûøy5:·d³~}Àus
ÿÎÜî9Å:q¶T©oÚ݃ûëÓFæîXó`_C+ëÄõˆ3
zfî–ùZÉÿ PŽzzîÄ!Àp;Å*Ÿq©~.ìv9·ØEÙ³)ÐûðÅÂl¹¬™»X~Þôe±qHQ‚€nÎÅ^Ï»flœL9Å[R]|^βö…šHak—öÈ%U“úû»‡JÉì³Wÿã~ÑTÝQLL#oÊñ%;œ}c½CYRÇÿ6ž‚sØ+Ï"ñª§Å
ûÔ7W°{‡Y{‹úݺÇõÊÝþbßkqÐe˜zK(:ôµÇè$Ûè™N¨]\ ±Ð
byK[íF?´j›3Ò×ηv¬°Àφ²ãâ›IX9z„4ê´ZÝ}k—Ýù²]¬]Ö=|žÚp¡FJËý¼_ß2e<¯ùg_;0’ çÀûØ9ÍÌ„x¢¿lKBF›yG[wonämH÷Ö„:ãn{<ÔÁþ½GŽÖÉÕDÁz½²éXSl"ú%ÛÝ7‡7õ‡ýõøu¨Ä$;ŽAâ¼?™y
Æó
úÊ}²âL…í2— b5ºW“§,œè1“Ÿt7ZÈœz#}Ä.½é¶#oZÍüªè…Ži–{âº
”é’‹aìM§àa`ÀÍû‰š»½Z~¢Í$•¿Ÿü<Ž™³0ÕñRµñvÃÔkïaÿº`šC‰Zß{p–Ü”×
úúÅÖ=lƒPZÊnÒ;6€è¹Ú^Ìœ“xqX¡uŒ²I‰ÎAú9-ƒ•
öžµä>Ö^™uôІ„:wÆþÕH‡c.PÎóô~s95{”
wPŠú#¹kÃø£Ck@>¬3ÿ-Í{~Éuc ’ëi1Fu3NœÚ6æøÿ-äzÇTʬÊ2ò,Ïâ*¬ÙcÜ Ú’©³ü>NˆßT÷vÛnQ®ˆ}[îŒMYlÏiAMqzõ$5Òäžr¿:ñùLæQ®àºt §`Ôí|#N‰À2Msˆ°?özÕ6ûŒXÉ[¦YaŽ{dBþ6sÆ% „)¢‚c·_bYÇD˜èÝ+0æËô×"xä!}›¼`aDªÒHç/¸NÞÅ"ùÉê/EJ\ñ§«MvnÝ™36Ï“8îHQ)@º8Ãr½P¦ë:¬XáÓö DÞ±¶†ÚØßó¹8SÐÙå“"2¿™ëñx÷°ÔCRv.³xŸ.#÷ž~Ò®;ÕñÇ›ÞHØ$ʞν^“òÁ'q0ß(Mµ¹«kÛéªfî×Á*,ÍëÔ[x^©ÒÌYˆ½v9ÑGÃÆ¾Ù6Êq%t뺂\ôuSöП›÷r¼ª9Ä…¦!#Ϥ Rê sFîu›çŠüFÝ‚Žäú˜9Òa\–Úsw¢—ÇèÌqvSA®f›„5ÓMôsìéÕä†eŽ¡dßìå<ÿ ã–.<ùêªðiegû?zs;‹M¾³Dú@Å[ܬkÕKe‡ÕØÌÀhOt&%WëGìÉóFÈ/ñ4YÏ{Ê{`©š W…ÕôÌ T+2jõš´XÄ‘nÛ²éqžîò‰üÄ©›Š¶džð„ó
ÜJî`¦ØÒ¦Û