...
 
Commits (52)
This diff is collapsed.
Package: fBasics
Title: Rmetrics - Markets and Basic Statistics
Date: 2017-11-12
Version: 3042.89
Author: Diethelm Wuertz [aut],
Tobias Setz [cre],
Yohan Chalabi [ctb]
Martin Maechler [ctb]
Maintainer: Tobias Setz <tobias.setz@live.com>
Description: Provides a collection of functions to
explore and to investigate basic properties of financial returns
and related quantities.
The covered fields include techniques of explorative data analysis
and the investigation of distributional properties, including
parameter estimation and hypothesis testing. Even more there are
several utility functions for data handling and management.
Depends: R (>= 2.15.1), timeDate, timeSeries
Imports: stats, grDevices, graphics, methods, utils, MASS, spatial,
gss, stabledist
ImportsNote: akima not in Imports because of non-GPL licence.
Suggests: akima, RUnit, tcltk
LazyData: yes
License: GPL (>= 2)
Encoding: UTF-8
URL: https://www.rmetrics.org
NeedsCompilation: yes
Packaged: 2017-11-17 06:26:29 UTC; Tobias Setz
Repository: CRAN
Date/Publication: 2017-11-17 12:09:09 UTC
This diff is collapsed.
################################################################################
## Libraries
################################################################################
useDynLib("fBasics")
################################################################################
## Imports
################################################################################
importFrom("grDevices", as.graphicsAnnot, cm.colors, col2rgb,
colors, contourLines, gray.colors, heat.colors,
rainbow, rgb, terrain.colors, topo.colors,
xy.coords)
importFrom("graphics", axis, barplot, box, boxplot, contour,
grid, hist, layout, locator, matplot, mtext,
panel.smooth, par, persp, pie, plot.new,
plot.window, polygon, rect, rug, symbols, text,
title)
importFrom("stats", acf, ansari.test, approx, ar, arima,
complete.cases, constrOptim, cor, cor.test,
density, dnorm, dt, integrate, ks.test, lsfit,
median, model.matrix, model.response, nlm, nlminb,
numericDeriv, optim, optimize, pacf, pchisq, pf,
pnorm, ppoints, qchisq, qf, qnorm, qqline,
qqnorm, qt, residuals, rexp, rnorm, runif, sd,
shapiro.test, spline, t.test, uniroot, var)
importFrom("utils", menu)
importFrom("methods", getMethod, is, new, slot)
importFrom("spatial", prmat, surf.gls)
## 'akima' is *not* here because of its non-GPL Licence
## importFrom("akima", interp, interpp)
## (MM:) FIXME: Only import what you need!
import("timeDate")
import("timeSeries")
################################################################################
## Exports
################################################################################
exportPattern(".")
S3method("getModel", "default")
S3method("print", "control")
S3method("stdev", "default")
S3method("termPlot", "default")
S3method("volatility", "default")
S3method(".plot", "histogram")
S3method(".print", "ssd")
S3method(".summary", "gel")
S3method(".summary", "gmm")
# In the future this should be used:
#exportPattern("^[^\\.]")
# To do before implementation:
#The porfolio book needs:
#export(.blue2redPalette)
#export(.green2redPalette)
#export(.blue2greenPalette)
#export(.purple2greenPalette)
#export(.blue2yellowPalette)
#export(.cyan2magentaPalette)
#fCouplae, fExtremes, fGarch, fMultivar and fRegression need a lot of exported
#functions that start with a dot. This has to be fixed first...
# 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
###############################################################################
This diff is collapsed.
This diff is collapsed.
This diff is collapsed.
This diff is collapsed.
# 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:
# .kweigths
################################################################################
# Code borrowed from
# R's contributed package "sandwich" written by Thomas Lumley
# and Achim Zeileis.
# Rmetrics:
# To run these functions under Rmetrics we have them implemented
# here as a builtin.
# The reason is that the dependences in the original package requires
# zoo which may create conflicts with Rmetrics timeDate/timeSeries.
# Package: sandwich
# Version: 2.2-1
# Date: 2009-02-05
# Title: Robust Covariance Matrix Estimators
# Author: Thomas Lumley, Achim Zeileis
# Maintainer: Achim Zeileis <Achim.Zeileis@R-project.org>
# Description: Model-robust standard error estimators for cross-sectional,
# time series and longitudinal data.
# LazyLoad: yes
# LazyData: yes
# Depends: R (>= 2.0.0), stats, zoo
# Suggests: car, lmtest, strucchange, AER, survival, MASS
# Imports: stats
# License: GPL-2
# Copyright: (C) 2004 Thomas Lumley and Achim Zeileis
# ------------------------------------------------------------------------------
.kweights <-
function(x, kernel = c("Truncated", "Bartlett", "Parzen",
"Tukey-Hanning", "Quadratic Spectral"), normalize = FALSE)
{
kernel <- match.arg(kernel)
if(normalize) {
ca <- switch(kernel,
"Truncated" = 2,
"Bartlett" = 2/3,
"Parzen" = .539285,
"Tukey-Hanning" = 3/4,
"Quadratic Spectral" = 1)
} else ca <- 1
switch(kernel,
"Truncated" = { ifelse(ca * x > 1, 0, 1) },
"Bartlett" = { ifelse(ca * x > 1, 0, 1 - abs(ca * x)) },
"Parzen" = {
ifelse(ca * x > 1, 0, ifelse(ca * x < 0.5,
1 - 6 * (ca * x)^2 + 6 * abs(ca * x)^3, 2 * (1 - abs(ca * x))^3))
},
"Tukey-Hanning" = {
ifelse(ca * x > 1, 0, (1 + cos(pi * ca * x))/2)
},
"Quadratic Spectral" = {
y <- 6 * pi * x/5
ifelse(x < 1e-4, 1, 3 * (1/y)^2 * (sin(y)/y - cos(y)))
})
}
################################################################################
# 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:
# posdef
################################################################################
# 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
###############################################################################
##.ssden <- gss::ssden
##.pssden <- gss::pssden
##.qssden <- gss::qssden
##.dssden <- gss::dssden
###############################################################################
# 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:
# testNortest
################################################################################
# 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:
# varpie
################################################################################
# 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:
# distCheck Checks consistency of distributions
################################################################################
distCheck <- function(fun = "norm", n = 1000, robust = TRUE, subdivisions = 100, ...)
{
# A function implemented by Diethelm Wuertz
# Description:
# Checks consistency of distributions
# Arguments:
# fun - a character string denoting the name of the distribution
# n - an integer specifying the number of random variates to be
# generated
# robust - a logical flag, should robust estimates be used? By
# default \code{TRUE}
# subdivisions - an integer specifying the numbers of subdivisions
# in integration __ NB: only used in one place, *not* in the other.. hmm
# ... - the distributional parameters and passed to integrate()
### FIXME (MM): add args.integrate = list() to be passed to integrate(),
### ----- and pass the others to distrib.functions
# Examples:
# .distCheck("norm", mean = 1, sd = 1)
# .distCheck("t", df = 4)
# .distCheck("exp", rate = 2)
# .distCheck("weibull", shape = 1)
# FUNCTION:
# Distribution Functions:
cat("\nDistribution Check for:", fun, "\n ")
CALL = match.call()
cat("Call: ")
cat(paste(deparse(CALL), sep = "\n", collapse = "\n"), "\n", sep = "")
dfun = match.fun(paste("d", fun, sep = ""))
pfun = match.fun(paste("p", fun, sep = ""))
qfun = match.fun(paste("q", fun, sep = ""))
rfun = match.fun(paste("r", fun, sep = ""))
# Range:
xmin = qfun(p = 0.01, ...)
xmax = qfun(p = 0.99, ...)
# Check 1 - Normalization:
NORM = integrate(dfun, lower = -Inf, upper = Inf,
subdivisions = subdivisions, stop.on.error = FALSE, ...)
cat("\n1. Normalization Check:\n NORM ")
print(NORM)
normCheck = (abs(NORM[[1]]-1) < 0.01)
# Check 2:
cat("\n2. [p-pfun(qfun(p))]^2 Check:\n ")
p = c(0.001, 0.01, 0.1, 0.5, 0.9, 0.99, 0.999)
P = pfun(qfun(p, ...), ...)
pP = round(rbind(p, P), 3)
print(pP)
RMSE = sd(p-P)
print(c(RMSE = RMSE))
rmseCheck = (abs(RMSE) < 0.0001)
# Check 3:
cat("\n3. r(", n, ") Check:\n", sep = "")
r = rfun(n = n, ...)
if (!robust) {
SAMPLE.MEAN = mean(r)
SAMPLE.VAR = var(r)
} else {
robustSample = MASS::cov.mcd(r, quantile.used = floor(0.95*n))
SAMPLE.MEAN = robustSample$center
SAMPLE.VAR = robustSample$cov[1,1]
}
SAMPLE = data.frame(t(c(MEAN = SAMPLE.MEAN, "VAR" = SAMPLE.VAR)),
row.names = "SAMPLE")
print(signif(SAMPLE, 3))
fun1 = function(x, ...) { x * dfun(x, ...) }
fun2 = function(x, M, ...) { x^2 * dfun(x, ...) }
MEAN = integrate(fun1, lower = -Inf, upper = Inf,
subdivisions = 5000, stop.on.error = FALSE,...)
cat(" X ")
print(MEAN)
VAR = integrate(fun2, lower = -Inf, upper = Inf,
subdivisions = 5000, stop.on.error = FALSE, ...)
cat(" X^2 ")
print(VAR)
EXACT = data.frame(t(c(MEAN = MEAN[[1]], "VAR" = VAR[[1]] - MEAN[[1]]^2)),
row.names = "EXACT ")
print(signif(EXACT, 3))
meanvarCheck = (abs(SAMPLE.VAR-EXACT$VAR)/EXACT$VAR < 0.1)
cat("\n")
# Done:
ans = list(
normCheck = normCheck,
rmseCheck = rmseCheck,
meanvarCheck = meanvarCheck)
# Return Value:
unlist(ans)
}
# ------------------------------------------------------------------------------
.distCheck <- distCheck
# Keep for older Rmetrics Versions
################################################################################
# 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
################################################################################
.distStandardErrors <-
function(fit, obj, x)
{
# Add Standard Errors and t-Values:
hessian = tsHessian(x = fit$par, fun = obj, y = x, trace = FALSE)
colnames(hessian) = rownames(hessian) = names(fit$par)
fit$cvar = solve(hessian)
fit$se.coef = sqrt(diag(fit$cvar))
if (fit$scale)
fit$se.coef = fit$se.coef / fit$scaleParams
fit$tval = fit$par/fit$se.coef
fit$matcoef = cbind(fit$par, 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|)"))
# Return Value:
fit
}
################################################################################
\ No newline at end of file
# 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
################################################################################
.distFitPlot <-
function(fit, x, FUN = "dnig", main = "Parameter Estimation",
span = "auto", add = FALSE, ...)
{
x = as.vector(x)
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]
# The Density function must accept multiple parameters
# from the first parameter
dFun = match.fun(FUN)
y.points = dnig(span, fit$par)
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)
lines(x = span, y = log(y.points), col = "steelblue")
}
}
################################################################################
\ No newline at end of file
# 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:
# 'fDISTFIT' S4 Class representation
# show.fDISTFIT Prints Results from a Fitted Distribution
################################################################################
setClass("fDISTFIT",
representation(
call = "call",
model = "character",
data = "data.frame",
fit = "list",
title = "character",
description = "character"
)
)
# ------------------------------------------------------------------------------
setMethod("show", "fDISTFIT",
function(object)
{ # A function implemented by Diethelm Wuertz
# Description:
# Prints Results from a Fitted Distribution
# FUNCTION:
# Title:
cat("\nTitle:\n ")
cat(object@title, "\n")
# Call:
cat("\nCall:\n ")
cat(paste(deparse(object@call), sep = "\n", collapse = "\n"),
"\n", sep = "")
# Model:
cat("\nModel:\n ", object@model, "\n", sep = "")
# Estimate:
cat("\nEstimated Parameter(s):\n")
print(object@fit$estimate)
# Description:
cat("\nDescription:\n ")
cat(object@description, "\n\n")
# Return Value:
invisible()
})
# ------------------------------------------------------------------------------
################################################################################
# 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:
# dgh Returns density for generalized hyperbolic DF
# pgh Returns probability for generalized hyperbolic DF
# qgh Returns quantiles for generalized hyperbolic DF
# rgh Returns random variates for generalized hyperbolic DF
################################################################################
dgh <-
function(x, alpha = 1, beta = 0, delta = 1, mu = 0, lambda = -1/2, log = FALSE)
{
# A function implemented by Diethelm Wuertz
# Description:
# Returns density for the generalized hyperbolic distribution
# FUNCTION:
# Parameters:
if (length(alpha) == 4) {
mu = alpha[4]
delta = alpha[3]
beta = alpha[2]
alpha = alpha[1]
}
# Checks:
if (alpha <= 0) stop("alpha must be greater than zero")
if (delta <= 0) stop("delta must be greater than zero")
if (abs(beta) >= alpha) stop("abs value of beta must be less than alpha")
# Density:
arg = delta*sqrt(alpha^2-beta^2)
a = (lambda/2)*log(alpha^2-beta^2) - (
log(sqrt(2*pi)) + (lambda-0.5)*log(alpha) + lambda*log(delta) +
log(besselK(arg, lambda, expon.scaled = TRUE)) - arg )
f = ((lambda-0.5)/2)*log(delta^2+(x - mu)^2)
# Use exponential scaled form to prevent from overflows:
arg = alpha * sqrt(delta^2+(x-mu)^2)
k = log(besselK(arg, lambda-0.5, expon.scaled = TRUE)) - arg
e = beta*(x-mu)
# Put all together:
ans = a + f + k + e
if(!log) ans = exp(ans)
# Return Value:
ans
}
# ------------------------------------------------------------------------------
pgh <-
function(q, alpha = 1, beta = 0, delta = 1, mu = 0, lambda = -1/2)
{
# A function implemented by Diethelm Wuertz
# Description:
# Returns probability for the generalized hyperbolic distribution
# FUNCTION:
# Checks:
if (alpha <= 0) stop("alpha must be greater than zero")
if (delta <= 0) stop("delta must be greater than zero")
if (abs(beta) >= alpha) stop("abs value of beta must be less than alpha")
# Probability:
ans = NULL
for (Q in q) {
Integral = integrate(dgh, -Inf, Q, stop.on.error = FALSE,
alpha = alpha, beta = beta, delta = delta, mu = mu,
lambda = lambda)
ans = c(ans, as.numeric(unlist(Integral)[1]))
}
# Return Value:
ans
}
# ------------------------------------------------------------------------------
qgh <-
function(p, alpha = 1, beta = 0, delta = 1, mu = 0, lambda = -1/2)
{
# A function implemented by Diethelm Wuertz
# Description:
# Returns quantiles for the generalized hyperbolic distribution
# FUNCTION:
# Checks:
if (alpha <= 0) stop("alpha must be greater than zero")
if (delta <= 0) stop("delta must be greater than zero")
if (abs(beta) >= alpha) stop("abs value of beta must be less than alpha")
# Internal Function:
.froot <- function(x, alpha, beta, delta, mu, lambda, p)
{
pgh(q = x, alpha = alpha, beta = beta, delta = delta,
mu = mu, lambda = lambda) - p
}
# Quantiles:
result = NULL
for (pp in p) {
lower = -1
upper = +1
counter = 0
iteration = NA
while (is.na(iteration)) {
iteration = .unirootNA(f = .froot, interval = c(lower,
upper), alpha = alpha, beta = beta, delta = delta,
mu = mu, lambda = lambda, p = pp)
counter = counter + 1
lower = lower - 2^counter
upper = upper + 2^counter
}
result = c(result, iteration)
}
# Return Value:
result
}
# ------------------------------------------------------------------------------
rgh <-
function(n, alpha = 1, beta = 0, delta = 1, mu = 0, lambda = -1/2)
{
# A function implemented by Diethelm Wuertz
# Description:
# Returns random variates for the generalized hyperbolic distribution
# FUNCTION:
# Checks:
if (alpha <= 0) stop("alpha must be greater than zero")
if (delta <= 0) stop("delta must be greater than zero")
if (abs(beta) >= alpha) stop("abs value of beta must be less than alpha")
# Settings:
theta = c(lambda, alpha, beta, delta, mu)
# Random Numbers:
ans = .rghyp(n, theta)
# Attributes:
attr(ans, "control") = c(dist = "gh", alpha = alpha, beta = beta,
delta = delta, mu = mu, lambda = lambda)
# Return Value:
ans
}
################################################################################
# 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: GENERALIZED DISTRIBUTION:
# ghFit Fits parameters of a generalized hyperbolic DF
################################################################################
ghFit <-
function(x, alpha = 1, beta = 0, delta = 1, mu = 0, lambda = -1/2,
scale = TRUE, doplot = TRUE, span = "auto", trace = TRUE,
title = NULL, description = NULL, ...)
{
# A function implemented by Diethelm Wuertz
# Description:
# Fits parameters of a generalized hyperbolic density
# FUNCTION:
# Transform:
x.orig = x
x = as.vector(x)
if (scale) {
SD = sd(x)
x = x / SD
}
# Settings:
CALL = match.call()
# Log-likelihood Function:
obj = function(x, y = x, trace){
if (NA %in% x) return(1e99)
if (abs(x[2]) >= x[1]) return(1e99)
f = -sum(dgh(y, x[1], x[2], x[3], x[4], x[5], log = TRUE))
# Print Iteration Path:
if (trace) {
cat("\n Objective Function Value: ", -f)
cat("\n Parameter Estimates: ", x, "\n")
}
f
}
# Minimization:
r = # Variable Transformation and Minimization:
eps = 1e-10
BIG = 1000
f = obj(x = c(alpha, beta, delta, mu, lambda), y = x, trace = FALSE)
r = nlminb(start = c(alpha, beta, delta, mu, lambda), objective = obj,
lower = c(eps, -BIG, eps, -BIG, -BIG), upper = BIG, y = x,
trace = trace)
names(r$par) <- c("alpha", "beta", "delta", "mu", "lambda")
# Result:
if (scale) {
r$par = r$par / c(SD, SD, 1/SD, 1/SD, 1)
r$objective = obj(r$par, y = as.vector(x.orig), trace = trace)
}
# Optional Plot:
if (doplot) {
x = as.vector(x.orig)
if (span == "auto") span = seq(min(x), max(x), length = 51)
z = density(x, n = 100, ...)
x = z$x[z$y > 0]
y = z$y[z$y > 0]
y.points = dnig(span, r$par[1], r$par[2], r$par[3], r$par[4])
ylim = log(c(min(y.points), max(y.points)))
plot(x, log(y), xlim = c(span[1], span[length(span)]),
ylim = ylim, type = "p", xlab = "x", ylab = "log f(x)", ...)
title("GH Parameter Estimation")
lines(x = span, y = log(y.points), col = "steelblue")
}
# Add Title and Description:
if (is.null(title)) title = "Generalized Hyperbolic Parameter Estimation"
if (is.null(description)) description = description()
# Fit:
fit = list(estimate = r$par, minimum = -r$objective, code = r$convergence)
# Return Value:
new("fDISTFIT",
call = as.call(CALL),
model = "Generalized Hyperbolic Distribution",
data = as.data.frame(x.orig),
fit = fit,
title = as.character(title),
description = description() )
}
################################################################################
# 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:
# ghMode Computes mode of the generalized hyperbolic DF
################################################################################
ghMode <-
function(alpha = 1, beta = 0, delta = 1, mu = 0, lambda = -1/2)
{
# A function implemented by Diethelm Wuertz
# Description:
# Computes the mode of the Generalized Hyperbolic PDF
# FUNCTION:
# Find Maximum:
min = qgh(0.01, alpha, beta, delta, mu, lambda)
max = qgh(0.99, alpha, beta, delta, mu, lambda)
ans = optimize(f = dgh, interval = c(min, max),
alpha = alpha, beta = beta, delta = delta, mu = mu, lambda = lambda,
maximum = TRUE, tol = .Machine$double.eps)$maximum
# Return Value:
ans
}
################################################################################
This diff is collapsed.
# 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:
# ghMED Returns true gh median
# ghIQR Returns true gh inter quartal range
# ghSKEW Returns true gh robust skewness
# ghKURT Returns true gh robust kurtosis
################################################################################
ghMED <-
function(alpha = 1, beta = 0, delta = 1, mu = 0, lambda = -1/2)
{
# A function implemented by Diethelm Wuertz
# Description:
# Returns true gh median
# Arguments:
# beta - a numeric value, the location parameter
# delta - a numeric value, the scale parameter
# mu - a numeric value, the first shape parameter
# nu - a numeric value, the second parameter
# FUNCTION:
# gh Median
Q = qgh(p=0.5, alpha, beta, delta, mu, lambda)
med = c(MED = Q)
# Return Value:
med
}
# ------------------------------------------------------------------------------
ghIQR <-
function(alpha = 1, beta = 0, delta = 1, mu = 0, lambda = -1/2)
{
# A function implemented by Diethelm Wuertz
# Description:
# Returns true gh inter quartal range
# Arguments:
# beta - a numeric value, the location parameter
# delta - a numeric value, the scale parameter
# mu - a numeric value, the first shape parameter
# nu - a numeric value, the second parameter
# FUNCTION:
# gh Inter Quartile Range
Q = numeric()
Q[1] = qgh(p=0.25, alpha, beta, delta, mu, lambda)
Q[2] = qgh(p=0.75, alpha, beta, delta, mu, lambda)
iqr = c(IQR = Q[[2]] - Q[[1]])
# Return Value:
iqr
}
# ------------------------------------------------------------------------------
ghSKEW <-
function(alpha = 1, beta = 0, delta = 1, mu = 0, lambda = -1/2)
{
# A function implemented by Diethelm Wuertz
# Description:
# Returns true gh robust gh skewness
# Arguments:
# beta - a numeric value, the location parameter
# delta - a numeric value, the scale parameter
# mu - a numeric value, the first shape parameter
# nu - a numeric value, the second parameter
# FUNCTION:
# gh Robust Skewness:
Q = numeric()
Q[1] = qgh(p=0.25, alpha, beta, delta, mu, lambda)
Q[2] = qgh(p=0.50, alpha, beta, delta, mu, lambda)
Q[3] = qgh(p=0.75, alpha, beta, delta, mu, lambda)
skew = c(SKEW = ( Q[[3]] + Q[[1]] - 2* Q[[2]] ) / (Q[[3]] - Q[[1]] ) )
# Return Value:
skew
}
# ------------------------------------------------------------------------------
ghKURT <-
function(alpha = 1, beta = 0, delta = 1, mu = 0, lambda = -1/2)
{
# A function implemented by Diethelm Wuertz
# Description:
# Returns true gh robust gh kurtosis
# Arguments:
# beta - a numeric value, the location parameter
# delta - a numeric value, the scale parameter
# mu - a numeric value, the first shape parameter
# nu - a numeric value, the second parameter
# FUNCTION:
# gh Robust Kurtosis:
Q = numeric()
for (p in (1:7)/8) Q = c(Q, qgh(p, alpha, beta, delta, mu, lambda))
kurt <