fCopulae/0000755000176200001440000000000014356373443012024 5ustar liggesusersfCopulae/NAMESPACE0000644000176200001440000000127014265245633013241 0ustar liggesusers################################################################################ ## Exports ################################################################################ exportPattern("^[^\\.]") ############################################################################### ## Imports ################################################################################ import(timeDate) import(timeSeries) import(fBasics) import(fMultivar) importFrom("grDevices", heat.colors) importFrom("graphics", contour, grid, image, mtext, par, persp, text, title) importFrom("stats", approx, cor, dnorm, dt, integrate, nlminb, optimize, pnorm, pt, qcauchy, qnorm, qt, rexp, rgamma, runif, uniroot, var) fCopulae/ChangeLog0000644000176200001440000000561014355000773013570 0ustar liggesusers ChangeLog Package fCopulae 2023-01-03 smith * R/ArchimedieanGenerator.R further work on uniroot to refine handling of cases where .invK was limited by numerical tolerance of uniroot 2022-12-11 smith * DESCRIPTION: Updated version number * R/ArchimedieanGenerator.R fixed bounds on uniroot in .invK function to avoid intermitent warnings on CRAN * inst/unitTest/runTests.R alter options to recommended warn=1. Set random number generators to match R4.2.2 defaults- avoids warnings in the test output 2021-07-18 smith * DESCRIPTION: Updated version number and maintainer * R/EllipticalCopulae.R method for random number generation from normal copula calls fMultivar::rnorm2d rather then fMultivar:::.rnorm2d. This breaks the reproducability of the output from previous versions. * inst/obsolete removed 2014-09-16 setz * ChangeLog, DESCRIPTION: Updated ChangeLog and DESCRIPTION files after submission to CRAN * NAMESPACE: Updated NAMESPACE; functions with a dot in front are no longer exported. * R/ArchimedianSlider.R: Removed duplicated functions * src and depending R functions moved to inst/obsolete/ 2014-02-03 wuertz * mvtnorm and sn are now loaded as Depends from fMultivar 2013-03-15 chalabi * DESCRIPTION: Updated maintainer field and version number * R/zzz.R: Removed depcrecated .First.lib() * R/bv-dnorm.R: Removed trailing whitespaces 2011-09-23 mmaechler * DESCRIPTION: remove deprecated "LazyLoad" entry 2010-10-26 chalabi * NAMESPACE: updated NAMESPACE 2010-07-23 chalabi * inst/DocCopying.pdf: removed DocCopying.pdf license is already specified in DESCRIPTION file 2009-10-27 chalabi * ChangeLog, DESCRIPTION: updated Changelog and DESCRIPTION file * DESCRIPTION, src/adapt_callback.c: added declaration of FORTRAN routine in C before use 2009-10-16 chalabi * NAMESPACE: updated NAMESPACE 2009-10-16 wuertz * DESCRIPTION, R/builtin-adapt.R, man/builtin-adapt.Rd, src, src/adapt2.f, src/adapt_callback.c: adapt added 2009-09-28 chalabi * DESCRIPTION: updated version number * ChangeLog, DESCRIPTION: updated DESCR and ChangeLog * NAMESPACE: new NAMESPACE structure which should ease maintenance of packages. 2009-06-25 chalabi * DESCRIPTION: Merge branch 'devel-timeSeries' Conflicts: pkg/timeSeries/R/base-Extract.R pkg/timeSeries/R/timeSeries.R 2009-04-19 chalabi * DESCRIPTION: added explicit version number in Depends field for key packages 2009-04-02 chalabi * DESCRIPTION: more explicit depends and suggests field in DESC file. * NAMESPACE: updated NAMESPACE * DESCRIPTION: updated DESC file 2009-01-28 chalabi * man/ArchimedeanCopulae.Rd, man/ArchimedeanDependency.Rd, man/ArchimedeanModelling.Rd, man/EmpiricalCopulae.Rd, man/ExtremeValueCopulae.Rd, man/ExtremeValueDependency.Rd, man/ExtremeValueGenerator.Rd, man/ExtremeValueModelling.Rd: updated manual pages to new Rd parser fCopulae/man/0000755000176200001440000000000014265245633012575 5ustar liggesusersfCopulae/man/EmpiricalCopulae.Rd0000644000176200001440000000527414265245633016312 0ustar liggesusers\name{EmpiricalCopulae} \alias{EmpiricalCopulae} \alias{pempiricalCopula} \alias{dempiricalCopula} \title{Bivariate Empirical Copulae} \description{ A collection and description of functions to investigate bivariate empirical copulae. \cr Empirical Copulae Functions: \tabular{ll}{ \code{pempiricalCopula} \tab computes empirical copula probability, \cr \code{dempiricalCopula} \tab computes empirical copula density. } } \usage{ pempiricalCopula(u, v, N = 10) dempiricalCopula(u, v, N = 10) } \arguments{ \item{N}{ [empiricalCopula] - \cr ... . } \item{u, v}{ [*evCopula][*archmCopula] - \cr two numeric values or vectors of the same length at which the copula will be computed. If \code{u} is a list then the the \code{$x} and \code{$y} elements will be used as \code{u} and \code{v}. If \code{u} is a two column matrix then the first column will be used as \code{u} and the the second as \code{v}. } } \value{ Th functions \code{*Spec} return an S4 object of class \code{"fCOPULA"}. The object contains the following slots: \item{@call}{ the function call. } \item{@copula}{ the name of the copula. } \item{@param}{ a list whose elements specify the model parameters. } \item{@title}{ a character string with the name of the copula. This can be overwritten specifying a user defined input argument. } \item{@description}{ a character string with an optional user defined description. By default just the current date when the test was applied will be returned. } The function \code{pcopula} returns a numeric matrix of probabilities computed at grid positions \code{x}|\code{y}. \cr The function \code{parchmCopula} returns a numeric matrix with values computed for the Archemedean copula. \cr The function \code{darchmCopula} returns a numeric matrix with values computed for thedensity of the Archemedean copula. \cr The functions \code{Phi*} return a numeric vector with the values computed from the Archemedean generator, its derivatives, or its inverse. \cr The functions \code{cK} and \code{cKInv} return a numeric vector with the values of the density and inverse for Archimedian copulae. } \author{ Diethelm Wuertz for the Rmetrics \R-port. } % \examples{ % ## fCOPULA - % # getClass("fCOPULA") % ## pcopula - % # The default Normal Copula: % # contour(pcopula()) % } \keyword{models} fCopulae/man/ArchimedeanCopulae.Rd0000644000176200001440000001113514265245633016576 0ustar liggesusers\name{ArchimedeanCopulae} \alias{ArchimedeanCopulae} \alias{rarchmCopula} \alias{parchmCopula} \alias{darchmCopula} \alias{rarchmSlider} \alias{parchmSlider} \alias{darchmSlider} \alias{rgumbelCopula} \alias{pgumbelCopula} \alias{dgumbelCopula} \title{Bivariate Archimedean Copulae} \description{ A collection and description of functions to investigate bivariate Archimedean copulae. \cr Archimedean Copulae Functions: \tabular{ll}{ \code{rarchmCopula} \tab Generates Archimedean copula variates, \cr \code{parchmCopula} \tab computes Archimedean copula probability, \cr \code{darchmCopula} \tab computes Archimedean copula density, \cr \code{rarchmSlider} \tab displays interactive plots of variates, \cr \code{parchmSlider} \tab displays interactive plots of probability, \cr \code{darchmSlider} \tab displays interactive plots of density. } Special Copulae Functions: \tabular{ll}{ \code{rgumbelCopula} \tab Generates Gumbel copula variates, \cr \code{pgumbelCopula} \tab computes Gumbel copula probability, \cr \code{dgumbelCopula} \tab computes Gumbel copula density. } } \usage{ rarchmCopula(n, alpha = NULL, type = archmList()) parchmCopula(u = 0.5, v = u, alpha = NULL, type = archmList(), output = c("vector", "list"), alternative = FALSE ) darchmCopula(u = 0.5, v = u, alpha = NULL, type = archmList(), output = c("vector", "list"), alternative = FALSE ) rarchmSlider(B = 10) parchmSlider(type = c("persp", "contour"), B = 10) darchmSlider(type = c("persp", "contour"), B = 10) rgumbelCopula(n, alpha = 2) pgumbelCopula(u = 0.5, v = u, alpha = 2, output = c("vector", "list")) dgumbelCopula(u = 0.5, v = u, alpha = 2, output = c("vector", "list")) } \arguments{ \item{alpha}{ [Phi*][*archmCopula] - \cr the parameter of the Archemedean copula. A numerical value. } \item{alternative}{ [*Copula] - \cr Should the probability be computed alternatively ... } \item{B}{ [*Slider] - \cr the maximum slider menu value when the boundary value is infinite. By default this is set to 10. } \item{n}{ [rarchmCopula] - \cr the number of random deviates to be generated, an integer value. } \item{output}{ [*archmCopula] - \cr output - a character string specifying how the output should be formatted. By default a vector of the same length as \code{u} and \code{v}. If specified as \code{"list"} then \code{u} and \code{v} are expected to span a two-dimensional grid as outputted by the function \code{grid2d} and the function returns a list with elements \code{\$x}, \code{\$y}, and \code{\$z} which can be directly used for example by 2D plotting functions. } \item{type}{ [*archmCopula] - \cr the type of the Archimedean copula. A character string ranging beween \code{"1"} and \code{"22"}. By default copula No. 1 will be chosen.\cr [*archmSlider] - \cr the type of the plot. A charcter string either specifying a perspective or contour plot. } \item{u, v}{ [*archmCopula] - \cr two numeric values or vectors of the same length at which the copula will be computed. If \code{u} is a list then the the \code{\$x} and \code{\$y} elements will be used as \code{u} and \code{v}. If \code{u} is a two column matrix then the first column will be used as \code{u} and the the second as \code{v}. } } \value{ The function \code{pcopula} returns a numeric matrix of probabilities computed at grid positions \code{x}|\code{y}. \cr The function \code{parchmCopula} returns a numeric matrix with values computed for the Archemedean copula. \cr The function \code{darchmCopula} returns a numeric matrix with values computed for thedensity of the Archemedean copula. \cr The functions \code{Phi*} return a numeric vector with the values computed from the Archemedean generator, its derivatives, or its inverse. \cr The functions \code{cK} and \code{cKInv} return a numeric vector with the values of the density and inverse for Archimedian copulae. } \author{ Diethelm Wuertz for the Rmetrics \R-port. } % \examples{ % ## fCOPULA - % # getClass("fCOPULA") % ## pcopula - % # The default Normal Copula: % # contour(pcopula()) % } \keyword{models} fCopulae/man/EllipticalModelling.Rd0000644000176200001440000001425514265245633017010 0ustar liggesusers\name{EllipticalModelling} \alias{EllipticalModelling} \alias{ellipticalCopulaSim} \alias{ellipticalCopulaFit} \title{Bivariate Elliptical Copulae} \description{ A collection and description of functions to investigate bivariate elliptical copulae. \cr Elliptical Copulae Functions: \tabular{ll}{ \code{ellipticalCopulaSim} \tab simulates an elliptical copula, \cr \code{ellipticalCopulaFit} \tab fits the parameters of an elliptical copula. } } \usage{ ellipticalCopulaSim(n, rho = 0.75, param = NULL, type = c("norm", "cauchy", "t")) ellipticalCopulaFit(u, v, type = c("norm", "cauchy", "t"), \dots) } \arguments{ \item{n}{ [rellipticalCopula][ellipticalCopulaSim] - \cr the number of random deviates to be generated, an integer value. } \item{rho}{ [*ellipticalCopula] - \cr is the numeric value setting the correlation strength, ranging between minus one and one. } \item{param}{ [*ellipticalCopula][gfunc] - \cr additional distributional parameters: for the Sudent-t distribution this is "nu", for the Kotz distribution this is "r", and for the Exponential Power distribution these are "r" and "s". If the argument \code{param=NULL} then default values are taken. These are for the Student-t \code{param=c(nu=4))}, for the Kotz distribution \code{param=c(r=1))}, and for the exponential power distribution \code{param=c(r=1,s=1)}. Note, that the Kotz and exponential power copulae are independent of \code{r}, and that \code{r} only enters the generator, the density, the probability and the quantile functions. } \item{type}{ [*ellipticalCopula][gfunc] - \cr the type of the elliptical copula. A character string selected from: "norm", "cauchy", "t", "logistic", "laplace", "kotz", or "epower". [*ellipticalSlider] - \cr a character string which indicates what kind of plot should be displayed, either a perspective plot if \code{type="persp"}, the default value, or a contour plot if \code{type="contour"}. } \item{u, v}{ [*ellipticalCopula] - \cr two numeric values or vectors of the same length at which the copula will be computed. If \code{u} is a list then the the \code{\$x} and \code{\$y} elements will be used as \code{u} and \code{v}. If \code{u} is a two column matrix then the first column will be used as \code{u} and the the second as \code{v}. If \code{u} is an integer value greater than one, say \code{N}, than the values for all points on the \code{[(0:N)/N]^2} grid spanning the unit square will be returned. } \item{\dots}{ [ellipticalCopulaFit] - \cr arguments passed to the optimization function \code{nlminb}. } } \value{ \bold{Copula Functions:} \cr\cr The functions \code{[rpd]ellipticalCopula} return a numeric vector of random variates, probabilities, or densities for the specified copula computed at grid coordinates \code{u}|\code{v}. \cr The functions \code{[rpd]ellipticalSlider} display an interactive graph of an perspective copula plot either for random variates, probabilities or densities. Alternatively, an image underlayed contour plot can be shown. \cr \bold{Copula Dependence Measures:} \cr\cr The functions \code{ellipticalTau} and \code{ellipticalRho} return a numericc value for Kendall's Tau and Spearman's Rho. \cr \bold{Copula Tail Coefficient:} \cr\cr The function \code{ellipticalTailCoeff} returns the coefficient of tail dependence for a specified copula. The function \code{ellipticalTailPlot} displays a whole plot for the upper or alternatively for the lower tail dependence as a function of \code{u} for a set of nine \code{rho} values. \cr \bold{Copula Generator Function:} \cr\cr The function \code{gfunc} computes the generator function for the specified copula, by default the normal copula. If the argument \code{x} is missing, then the normalization constand lambda will be returned, otherwise if \code{x} is specified the values for the function \emph{g(x)} will be freturned. The selected type of copula is added to the output as an attribute named \code{"control"}. The function \code{gfuncSlider} allows to display interactively the generator function, the marginal density, the marginal probability, and the contours of the the bivariate density. \cr \bold{Copula Simulation and Parameter Fitting:} \cr\cr The function \code{ellipticalCopulaSim} returns a numeric two-column matrix with randomly generated variates for the specified copula. \cr The function \code{ellipticalCopulaFit} returns a fit to empirical data for the specified copula. The returned object is a list with elements from the function \code{nlminb}. } \author{ Diethelm Wuertz for the Rmetrics \R-port. } \examples{ ## [rp]ellipticalCopula - # Default Normal Copula: rellipticalCopula(10) pellipticalCopula(10) ## [rp]ellipticalCopula - # Student-t Copula Probability and Density: u = grid2d(x = (0:25)/25) # CHECK ERROR # pellipticalCopula(u, rho = 0.75, param = 4, # type = "t", output = "list") # CHECK ERROR DONE d = dellipticalCopula(u, rho = 0.75, param = 4, type = "t", output = "list") persp(d, theta = -40, phi = 30, col = "steelblue") ## ellipticalTau - ## ellipticalRho - # Dependence Measures: ellipticalTau(rho = -0.5) ellipticalRho(rho = 0.75, type = "logistic", subdivisions = 100) ## ellipticalTailCoeff - # Student-t Tail Coefficient: ellipticalTailCoeff(rho = 0.25, param = 3, type = "t") ## gfunc - # Generator Function: plot(gfunc(x = 0:10), main = "Generator Function") ## ellipticalCopulaSim - ## ellipticalCopulaSim - # Simualtion and Parameter Fitting: rv <- ellipticalCopulaSim(n = 100, rho = 0.75) ellipticalCopulaFit(rv) } \keyword{models} fCopulae/man/ExtremeValueCopulae.Rd0000644000176200001440000001161214265245633017004 0ustar liggesusers\name{ExtremeValueCopulae} \alias{ExtremeValueCopulae} \alias{revCopula} \alias{pevCopula} \alias{devCopula} \alias{revSlider} \alias{pevSlider} \alias{devSlider} \title{Bivariate Extreme Value Copulae} \description{ A collection and description of functions to investigate bivariate extreme value copulae. \cr Extreme Value Copulae Functions: \tabular{ll}{ \code{revCopula} \tab Generates extreme value copula random variates, \cr \code{pevCopula} \tab computes extreme value copula probability, \cr \code{devCopula} \tab computes extreme value copula density, \cr \code{revSlider} \tab displays interactive plots of extreme value random variates, \cr \code{pevSlider} \tab displays interactive plots of extreme value probability, \cr \code{devSlider} \tab displays interactive plots of extreme value density. } } \usage{ revCopula(n, param = NULL, type = evList()) pevCopula(u = 0.5, v = u, param = NULL, type = evList(), output = c("vector", "list"), alternative = FALSE ) devCopula(u = 0.5, v = u, param = NULL, type = evList(), output = c("vector", "list"), alternative = FALSE ) revSlider(B = 10) pevSlider(type = c("persp", "contour"), B = 10) devSlider(type = c("persp", "contour"), B = 10) } \arguments{ \item{alternative}{ [evRho][evTau][*evCopula] - \cr Should the probability be computed alternatively in a direct way from the probability formula or by default via the dependency function? } \item{B}{ [*Slider] - \cr the maximum slider menu value when the boundary value is infinite. By default this is set to 10. } %\item{error}{ % [evRho] - \cr % the error bound to be achieved by the \code{integrate2d} % integration formula. A numeric value, by default \code{error=1.0e-5}. % } \item{n}{ [revCopula][evCopulaSim] - \cr the number of random deviates to be generated, an integer value. } \item{output}{ [*evCopula] - \cr output - a character string specifying how the output should be formatted. By default a vector of the same length as \code{u} and \code{v}. If specified as \code{"list"} then \code{u} and \code{v} are expected to span a two-dimensional grid as outputted by the function \code{grid2d} and the function returns a list with elements \code{$x}, \code{y}, and \code{z} which can be directly used for example by 2D plotting functions. } \item{param}{ [*ev*][A*] - \cr distribution and copulae parameters. A numeric value or vector of named parameters as required by the copula specified by the variable \code{type}. If set to \code{NULL}, then the default parameters will be taken. } \item{type}{ [*ev*][Afunc] - \cr the type of the extreme value copula. A character string selected from: "gumbel", "galambos", "husler.reiss", "tawn", or "bb5". \cr [evSlider] - \cr a character string specifying the plot type. Either a perspective plot which is the default or a contour plot with an underlying image plot will be created. } \item{u, v}{ [*evCopula][*archmCopula] - \cr two numeric values or vectors of the same length at which the copula will be computed. If \code{u} is a list then the the \code{$x} and \code{$y} elements will be used as \code{u} and \code{v}. If \code{u} is a two column matrix then the first column will be used as \code{u} and the the second as \code{v}. } } \value{ The function \code{pcopula} returns a numeric matrix of probabilities computed at grid positions \code{x}|\code{y}. \cr The function \code{parchmCopula} returns a numeric matrix with values computed for the Archemedean copula. \cr The function \code{darchmCopula} returns a numeric matrix with values computed for thedensity of the Archemedean copula. \cr The functions \code{Phi*} return a numeric vector with the values computed from the Archemedean generator, its derivatives, or its inverse. \cr The functions \code{cK} and \code{cKInv} return a numeric vector with the values of the density and inverse for Archimedian copulae. } \author{ Diethelm Wuertz for the Rmetrics \R-port. } \examples{ ## fCOPULA - getClass("fCOPULA") getSlots("fCOPULA") ## revCopula - # Not yet implemented # revCopula(n = 10, type = "galambos") ## pevCopula - pevCopula(u = grid2d(), type = "galambos", output = "list") ## devCopula - devCopula(u = grid2d(), type = "galambos", output = "list") ## AfuncSlider - # Generator, try: \dontrun{AfuncSlider()} } \keyword{models} fCopulae/man/EllipticalGenerator.Rd0000644000176200001440000001260114265245633017015 0ustar liggesusers\name{EllipticalGenerator} \alias{EllipticalGenerator} \alias{ellipticalList} \alias{ellipticalParam} \alias{ellipticalRange} \alias{ellipticalCheck} \alias{gfunc} \alias{gfuncSlider} \title{Bivariate Elliptical Copulae} \description{ A collection and description of functions concerned with the generator function for the elliptical copula and with functions for setting and checking the distributional parameters. \cr Functions: \tabular{ll}{ \code{ellipticalList} \tab Returns list of implemented elliptical copulae, \cr \code{ellipticalParam} \tab Sets default parameters for an elliptical copula, \cr \code{ellipticalRange} \tab returns the range of valid rho values, \cr \code{ellipticalCheck} \tab checks if rho is in the valid range, \cr \code{gfunc} \tab Generator function for elliptical distributions, \cr \code{gfuncSlider} \tab Slider for generator, density and probability. } } \usage{ ellipticalList() ellipticalParam(type = ellipticalList()) ellipticalRange(type = ellipticalList()) ellipticalCheck(rho = 0.75, param = NULL, type = ellipticalList()) gfunc(x, param = NULL, type = ellipticalList()) gfuncSlider(B = 10) } \arguments{ \item{B}{ [*Slider] - \cr the maximum slider menu value when the boundary value is infinite. By default this is set to 10. } \item{rho}{ [*ellipticalCopula] - \cr is the numeric value setting the correlation strength, ranging between minus one and one. } \item{param}{ [*ellipticalCopula][gfunc] - \cr additional distributional parameters: for the Sudent-t distribution this is "nu", for the Kotz distribution this is "r", and for the Exponential Power distribution these are "r" and "s". If the argument \code{param=NULL} then default values are taken. These are for the Student-t \code{param=c(nu=4))}, for the Kotz distribution \code{param=c(r=1))}, and for the exponential power distribution \code{param=c(r=1,s=1)}. Note, that the Kotz and exponential power copulae are independent of \code{r}, and that \code{r} only enters the generator, the density, the probability and the quantile functions. } \item{type}{ [*ellipticalCopula][gfunc] - \cr the type of the elliptical copula. A character string selected from: "norm", "cauchy", "t", "logistic", "laplace", "kotz", or "epower". [*ellipticalSlider] - \cr a character string which indicates what kind of plot should be displayed, either a perspective plot if \code{type="persp"}, the default value, or a contour plot if \code{type="contour"}. } \item{x}{ [gfunc] - \cr a numeric value or vector out of the range \code{[0,Inf)} at which the generator will be computed. } } \value{ \bold{Copula Functions:} \cr\cr The functions \code{[rpd]ellipticalCopula} return a numeric vector of random variates, probabilities, or densities for the specified copula computed at grid coordinates \code{u}|\code{v}. \cr The functions \code{[rpd]ellipticalSlider} display an interactive graph of an perspective copula plot either for random variates, probabilities or densities. Alternatively, an image underlayed contour plot can be shown. \cr \bold{Copula Dependence Measures:} \cr\cr The functions \code{ellipticalTau} and \code{ellipticalRho} return a numericc value for Kendall's Tau and Spearman's Rho. \cr \bold{Copula Tail Coefficient:} \cr\cr The function \code{ellipticalTailCoeff} returns the coefficient of tail dependence for a specified copula. The function \code{ellipticalTailPlot} displays a whole plot for the upper or alternatively for the lower tail dependence as a function of \code{u} for a set of nine \code{rho} values. \cr \bold{Copula Generator Function:} \cr\cr The function \code{gfunc} computes the generator function for the specified copula, by default the normal copula. If the argument \code{x} is missing, then the normalization constand lambda will be returned, otherwise if \code{x} is specified the values for the function \emph{g(x)} will be freturned. The selected type of copula is added to the output as an attribute named \code{"control"}. The function \code{gfuncSlider} allows to display interactively the generator function, the marginal density, the marginal probability, and the contours of the the bivariate density. \cr \bold{Copula Simulation and Parameter Fitting:} \cr\cr The function \code{ellipticalCopulaSim} returns a numeric two-column matrix with randomly generated variates for the specified copula. \cr The function \code{ellipticalCopulaFit} returns a fit to empirical data for the specified copula. The returned object is a list with elements from the function \code{nlminb}. } \author{ Diethelm Wuertz for the Rmetrics \R-port. } \examples{ ## ellipticalList - # List implemented copulae: ellipticalList() ## gfunc - # Generator Function: gfunc(x <- (0:10)/10, param = 2, type = "t") ## gfuncSlider - # Try: \dontrun{ gfuncSlider()} } \keyword{models} fCopulae/man/aaaCopulaEnv.Rd0000644000176200001440000000035114265245633015422 0ustar liggesusers\name{CopulaEnv} \alias{CopulaEnv} \title{Bivariate Copula Environment} \description{ Set and Get functions for the Copula environment. } %\usage{} %\arguments{} %\value{} %\examples{} \keyword{models} fCopulae/man/ArchimedeanModelling.Rd0000644000176200001440000000506414265245633017124 0ustar liggesusers\name{ArchimedeanModelling} \alias{ArchimedeanModelling} \alias{archmCopulaSim} \alias{archmCopulaFit} \title{Bivariate Archimedean Copulae} \description{ A collection and description of functions to investigate bivariate Archimedean copulae. \cr Archimedean Copulae Functions: \tabular{ll}{ \code{archmCopulaSim} \tab simulates an Archimedean copula, \cr \code{archmCopulaFit} \tab fits the parameters of an Archimedean copula. } } \usage{ archmCopulaSim(n, alpha = NULL, type = archmList()) archmCopulaFit(u, v = NULL, type = archmList(), \dots) } \arguments{ \item{alpha}{ [Phi*][*archmCopula] - \cr the parameter of the Archemedean copula. A numerical value. } \item{n}{ [rarchmCopula] - \cr the number of random deviates to be generated, an integer value. } \item{type}{ the type of the Archimedean copula. A character string ranging beween \code{"1"} and \code{"22"}. By default copula No. 1 will be chosen. } \item{u, v}{ [*archmCopula] - \cr two numeric values or vectors of the same length at which the copula will be computed. If \code{u} is a list then the the \code{\$x} and \code{\$y} elements will be used as \code{u} and \code{v}. If \code{u} is a two column matrix then the first column will be used as \code{u} and the the second as \code{v}. } \item{\dots}{ [archmCopulaFit] - \cr arguments passed to the optimization function in use, \code{nlminb}. } } \value{ The function \code{pcopula} returns a numeric matrix of probabilities computed at grid positions \code{x}|\code{y}. \cr The function \code{parchmCopula} returns a numeric matrix with values computed for the Archemedean copula. \cr The function \code{darchmCopula} returns a numeric matrix with values computed for thedensity of the Archemedean copula. \cr The functions \code{Phi*} return a numeric vector with the values computed from the Archemedean generator, its derivatives, or its inverse. \cr The functions \code{cK} and \code{cKInv} return a numeric vector with the values of the density and inverse for Archimedian copulae. } \author{ Diethelm Wuertz for the Rmetrics \R-port. } % \examples{ % ## fCOPULA - % # getClass("fCOPULA") % ## pcopula - % # The default Normal Copula: % # contour(pcopula()) % } \keyword{models} fCopulae/man/00fCopulae-package.Rd0000644000176200001440000001643314265245633016362 0ustar liggesusers\name{fCopulae-package} \alias{fCopulae-package} \alias{fCopulae} \docType{package} \title{Modelling Copulae and Dependence Structures} \description{ The Rmetrics \code{fCopulae} package is a collection of functions to manage, to investigate and to analyze bivariate financial returns by Copulae. Included are the families of Archemedean, Elliptical, Extreme Value, and Empirical Copulae. } \details{ \tabular{ll}{ Package: \tab fCopulae\cr Type: \tab Package\cr Version: \tab R 3.0.1\cr Date: \tab 2014\cr License: \tab GPL Version 2 or later\cr Copyright: \tab (c) 1999-2014 Rmetrics Assiciation\cr URL: \tab \url{https://www.rmetrics.org} } } \section{1 Introduction}{ The package \code{fCoplae} was written to explore and investigate bivariate copulae and dependence structures. } \section{2 Archimedean Copulae}{ This chapter contains functions for analysing and modeling Archemedean copulae. \emph{Archimedean Copula Density, Probability and Random Numbers:} \preformatted{ darchmCopula Computes Archimedean copula density parchmCopula Computes Archimedean copula probability rarchmCopula Generates Archimedean copula random variates } For the Gumbel Copula we have a fast implementation. \preformatted{ rgumbelCopula Generates fast gumbel random variates dgumbelCopula Computes bivariate Gumbel copula density pgumbelCopula Computes bivariate Gumbel copula probability } \emph{Archimedean Copula Dependency Structure:} \preformatted{ archmTau Returns Kendall's tau for Archemedean copulae archmRho Returns Spearman's rho for Archemedean copulae } \preformatted{ archmTailCoeff Computes tail dependence for Archimedean copulae archmTailPlot Plots Archimedean tail dependence function } \emph{Archimedean Copula Generator:} \preformatted{ archmList Returns list of implemented Archimedean copulae archmParam Sets Default parameters for an Archimedean copula archmRange Returns the range of valid alpha values archmCheck Checks if alpha is in the valid range } \preformatted{ Phi Computes Archimedean Phi, inverse and derivatives PhiSlider Displays interactively generator function Kfunc Computes Archimedean Density Kc and its Inverse KfuncSlider Displays interactively the density and concordance } \emph{Archemedean Copula Modeling:} \preformatted{ archmCopulaSim Simulates bivariate elliptical copula archmCopulaFit Fits the paramter of an elliptical copula } \emph{Archemedean Copula Slider:} \preformatted{ darchmSlider Displays interactively archimedean density parchmSlider Displays interactively Archimedean probability rarchmSlider Displays interactively Archimedean probability } } \section{3 Elliptical Copulae}{ This chapter contains functions for analysing and modeling elliptical copulae. \emph{Elliptical Copula Density, Probability and Random Numbers:} \preformatted{ dellipticalCopula Computes elliptical copula density pellipticalCopula Computes elliptical copula probability rellipticalCopula Generates elliptical copula variates } \emph{Elliptical Copula Slider:} \preformatted{ dellipticalSlider Generates interactive plots of density pellipticalSlider Generates interactive plots of probability rellipticalSlider Generates interactive plots of random variates } \emph{Elliptical Copula Dependency Structures:} \preformatted{ ellipticalTau Computes Kendall's tau for elliptical copulae ellipticalRho Computes Spearman's rho for elliptical copulae } \preformatted{ ellipticalTailCoeff Computes tail dependence for elliptical copulae ellipticalTailPlot Plots tail dependence function } \emph{Elliptical Copula Generator:} \preformatted{ ellipticalList Returns list of implemented Elliptical copulae ellipticalParam Sets default parameters for an elliptical copula ellipticalRange Returns the range of valid rho values ellipticalCheck Checks if rho is in the valid range } \preformatted{ gfunc Generator function for elliptical distributions gfuncSlider Slider for generator, density and probability } \emph{Elliptical Copula Modeling:} \preformatted{ ellipticalCopulaSim Simulates bivariate elliptical copula ellipticalCopulaFit Fits the paramter of an elliptical copula } } \section{4 Extreme Value Copulae}{ This chapter contains functions for analysing and modeling extreme value copulae. \emph{Extremem Value Copula Density, Probability and Random Numbers:} \preformatted{ devCopula Computes extreme value copula density pevCopula Computes extreme value copula probability revCopula Generates extreme value copula random variates } \preformatted{ devSlider Displays interactively plots of density pevSlider Displays interactively plots of probability revSlider isplays interactively plots of random variates } \emph{Extreme Value Copula Dependeny Structures:} \preformatted{ evTau Returns Kendall's tau for extreme value copulae evRho Returns Spearman's rho for extreme value copulae } \preformatted{ evTailCoeff Computes tail dependence for extreme value copulae evTailCoeffSlider Plots extreme value tail dependence function } \emph{Extreme Value Copula Generator:} \preformatted{ evList Returns list of implemented extreme value copulae evParam Sets Default parameters for an extreme value copula evCheck Checks if parameters are in the valid range evRange Returns the range of valid parameter values } \preformatted{ Afunc Computes Dependence function AfuncSlider Displays interactively dependence function } \emph{Extreme Value Copula Modeling:} \preformatted{ evCopulaSim Simulates bivariate extreme value copula evCopulaFit Fits the paramter of an extreme value copula } } \section{5 Empirical Copula.}{ This chapter contains functions for analysing and modeling empirical copulae. \emph{Empirical Copulae Density and Probability:} \preformatted{ pempiricalCopula Computes empirical copula probability dempiricalCopula Computes empirical copula density } } \section{About Rmetrics:}{ The \code{fCopulae} Rmetrics package is written for educational support in teaching "Computational Finance and Financial Engineering" and licensed under the GPL. } \keyword{package} fCopulae/man/aaaCopulaClass.Rd0000644000176200001440000000726314265245633015750 0ustar liggesusers\name{CopulaClass} \alias{CopulaClass} \alias{fCOPULA} \alias{fCOPULA-class} \alias{show,fCOPULA-method} \alias{pfrechetCopula} \title{Bivariate Copula Class} \description{ A collection and description of functions to specify the copula class and to investigate bivariate Frechet copulae. \cr The class representation and methods are: \tabular{ll}{ \code{fCOPULA} \tab representation for an S4 object of class "fCOPULA", \cr \code{show} \tab S4 print method. } Frechet Copulae: \tabular{ll}{ \code{pfrechetCopula} \tab computes Frechet copula probability. } } \usage{ \S4method{show}{fCOPULA}(object) pfrechetCopula(u = 0.5, v = u, type = c("m", "pi", "w"), output = c("vector", "list")) } \arguments{ \item{object}{ [show] - \cr an S4 object of class \code{"fCOPULA"}. } \item{output}{ [*frechetCopula] - \cr output - a character string specifying how the output should be formatted. By default a vector of the same length as \code{u} and \code{v}. If specified as \code{"list"} then \code{u} and \code{v} are expected to span a two-dimensional grid as outputted by the function \code{grid2d} and the function returns a list with elements \code{$x}, \code{y}, and \code{z} which can be directly used for example by 2D plotting functions. } \item{type}{ [*frechetCopula] - \cr the type of the Frechet copula. A character string selected from: \code{"m"}, \code{"pi"}, or \code{"w"}. } \item{u, v}{ two numeric values or vectors of the same length at which the copula will be computed. If \code{u} is a list then the the \code{$x} and \code{$y} elements will be used as \code{u} and \code{v}. If \code{u} is a two column matrix then the first column will be used as \code{u} and the the second as \code{v}. } } \value{ The print method \code{show} returns an S4 object of class \code{"fCOPULA"}. The object contains the following slots: \item{@call}{ the function call. } \item{@copula}{ the name of the copula. } \item{@param}{ a list whose elements specify the model parameters of the copula. } \item{@title}{ a character string with the name of the copula. This can be overwritten specifying a user defined input argument. } \item{@description}{ a character string with an optional user defined description. By default just the current date will be returned. } The function \code{pfrechetCopula} returns a numeric vector of probabilities. An attribute named \code{"control"} is added which returns the name of the Frechet copula. } \details{ The function \code{pfrechetCopula} returns a numeric matrix of probabilities computed at grid positions \code{u}|\code{v}. The arguments \code{u} and \code{v} are two single values or two numeric vectors of the same length. If \code{v} is not specified then the same values are taken as for \code{u}. Alternatively, \code{u} may be given as a two column vector or as a list with two entries as vectors. The first column or entry is taken as \code{u} and the second as \code{v}. } \author{ Diethelm Wuertz for the Rmetrics \R-port. } \examples{ ## fCOPULA - getClass("fCOPULA") ## pfrechet - # The Frechet Copula - m: pfrechetCopula(0.5) pfrechetCopula(0.25, 0.75) pfrechetCopula(runif(5)) ## grid2d - grid2d() pfrechetCopula(grid2d()) } \keyword{models} fCopulae/man/ExtremeValueModelling.Rd0000644000176200001440000000632414265245633017332 0ustar liggesusers\name{ExtremeValueModelling} \alias{ExtremeValueModelling} \alias{evCopulaSim} \alias{evCopulaFit} \title{Bivariate Extreme Value Copulae} \description{ A collection and description of functions to investigate bivariate extreme value copulae. \cr Extreme Value Copulae Functions: \tabular{ll}{ \code{evCopulaSim} \tab simulates an extreme value copula, \cr \code{evCopulaFit} \tab fits the parameters of an extreme value copula. } } \usage{ evCopulaSim(n, param = NULL, type = evList()) evCopulaFit(u, v = NULL, type = evList(), \dots) } \arguments{ \item{n}{ [revCopula][evCopulaSim] - \cr the number of random deviates to be generated, an integer value. } \item{param}{ [*ev*][A*] - \cr distribution and copulae parameters. A numeric value or vector of named parameters as required by the copula specified by the variable \code{type}. If set to \code{NULL}, then the default parameters will be taken. } \item{type}{ [*ev*][Afunc] - \cr the type of the extreme value copula. A character string selected from: "gumbel", "galambos", "husler.reiss", "tawn", or "bb5". \cr [evSlider] - \cr a character string specifying the plot type. Either a perspective plot which is the default or a contour plot with an underlying image plot will be created. } \item{u, v}{ [*evCopula][*archmCopula] - \cr two numeric values or vectors of the same length at which the copula will be computed. If \code{u} is a list then the the \code{$x} and \code{$y} elements will be used as \code{u} and \code{v}. If \code{u} is a two column matrix then the first column will be used as \code{u} and the the second as \code{v}. } \item{\dots}{ [evCopulaFit] - \cr arguments passed to the optimization function \code{nlminb}. } } \value{ The function \code{pcopula} returns a numeric matrix of probabilities computed at grid positions \code{x}|\code{y}. \cr The function \code{parchmCopula} returns a numeric matrix with values computed for the Archemedean copula. \cr The function \code{darchmCopula} returns a numeric matrix with values computed for thedensity of the Archemedean copula. \cr The functions \code{Phi*} return a numeric vector with the values computed from the Archemedean generator, its derivatives, or its inverse. \cr The functions \code{cK} and \code{cKInv} return a numeric vector with the values of the density and inverse for Archimedian copulae. } \author{ Diethelm Wuertz for the Rmetrics \R-port. } \examples{ ## fCOPULA - getClass("fCOPULA") getSlots("fCOPULA") ## revCopula - # Not yet implemented # revCopula(n = 10, type = "galambos") ## pevCopula - pevCopula(u = grid2d(), type = "galambos", output = "list") ## devCopula - devCopula(u = grid2d(), type = "galambos", output = "list") ## AfuncSlider - # Generator, try: \dontrun{AfuncSlider()} } \keyword{models} fCopulae/man/ExtremeValueDependency.Rd0000644000176200001440000000670314265245633017477 0ustar liggesusers\name{ExtremeValueDependency} \alias{ExtremeValueDependency} \alias{evTau} \alias{evRho} \alias{evTailCoeff} \alias{evTailCoeffSlider} \title{Bivariate Extreme Value Copulae} \description{ A collection and description of functions to investigate bivariate extreme value copulae. \cr Extreme Value Copulae Functions: \tabular{ll}{ \code{evTau} \tab Computes Kendall's tau for extreme value copulae, \cr \code{evRho} \tab computes Spearman's rho for extreme value copulae, \cr \code{evTailCoeff} \tab computes tail dependence for extreme value copulae, \cr \code{evTailCoeffSlider} \tab plots tail dependence for extreme value copulae. } } \usage{ evTau(param = NULL, type = evList(), alternative = FALSE) evRho(param = NULL, type = evList(), alternative = FALSE) evTailCoeff(param = NULL, type = evList()) evTailCoeffSlider(B = 10) } \arguments{ \item{alternative}{ [evRho][evTau][*evCopula] - \cr Should the probability be computed alternatively in a direct way from the probability formula or by default via the dependency function? } \item{B}{ [*Slider] - \cr the maximum slider menu value when the boundary value is infinite. By default this is set to 10. } %\item{error}{ % [evRho] - \cr % the error bound to be achieved by the \code{integrate2d} % integration formula. A numeric value, by default \code{error=1.0e-5}. % } \item{param}{ [*ev*][A*] - \cr distribution and copulae parameters. A numeric value or vector of named parameters as required by the copula specified by the variable \code{type}. If set to \code{NULL}, then the default parameters will be taken. } \item{type}{ [*ev*][Afunc] - \cr the type of the extreme value copula. A character string selected from: "gumbel", "galambos", "husler.reiss", "tawn", or "bb5". \cr [evSlider] - \cr a character string specifying the plot type. Either a perspective plot which is the default or a contour plot with an underlying image plot will be created. } } \value{ The function \code{pcopula} returns a numeric matrix of probabilities computed at grid positions \code{x}|\code{y}. \cr The function \code{parchmCopula} returns a numeric matrix with values computed for the Archemedean copula. \cr The function \code{darchmCopula} returns a numeric matrix with values computed for thedensity of the Archemedean copula. \cr The functions \code{Phi*} return a numeric vector with the values computed from the Archemedean generator, its derivatives, or its inverse. \cr The functions \code{cK} and \code{cKInv} return a numeric vector with the values of the density and inverse for Archimedian copulae. } \author{ Diethelm Wuertz for the Rmetrics \R-port. } \examples{ ## fCOPULA - getClass("fCOPULA") getSlots("fCOPULA") ## revCopula - # Not yet implemented # revCopula(n = 10, type = "galambos") ## pevCopula - pevCopula(u = grid2d(), type = "galambos", output = "list") ## devCopula - devCopula(u = grid2d(), type = "galambos", output = "list") ## AfuncSlider - # Generator, try: \dontrun{AfuncSlider()} } \keyword{models} fCopulae/man/EllipticalDependency.Rd0000644000176200001440000001416214265245633017151 0ustar liggesusers\name{EllipticalDependency} \alias{EllipticalDependency} \alias{ellipticalTau} \alias{ellipticalRho} \alias{ellipticalTailCoeff} \alias{ellipticalTailPlot} \title{Bivariate Elliptical Copulae} \description{ A collection and description of functions to investigate bivariate elliptical copulae. \cr Elliptical Copulae Functions: \tabular{ll}{ \code{ellipticalTau} \tab Computes Kendall's tau for elliptical copulae, \cr \code{ellipticalRho} \tab computes Spearman's rho for elliptical copulae, \cr \code{ellipticalTailCoeff} \tab computes tail dependence for elliptical copulae, \cr \code{ellipticalTailPlot} \tab plots tail dependence for elliptical copulae. } } \usage{ ellipticalTau(rho) ellipticalRho(rho, param = NULL, type = ellipticalList(), subdivisions = 500) ellipticalTailCoeff(rho, param = NULL, type = c("norm", "cauchy", "t")) ellipticalTailPlot(param = NULL, type = c("norm", "cauchy", "t"), tail = c("Lower", "Upper")) } \arguments{ \item{rho}{ [*ellipticalCopula] - \cr is the numeric value setting the correlation strength, ranging between minus one and one. } \item{param}{ [*ellipticalCopula][gfunc] - \cr additional distributional parameters: for the Sudent-t distribution this is "nu", for the Kotz distribution this is "r", and for the Exponential Power distribution these are "r" and "s". If the argument \code{param=NULL} then default values are taken. These are for the Student-t \code{param=c(nu=4))}, for the Kotz distribution \code{param=c(r=1))}, and for the exponential power distribution \code{param=c(r=1,s=1)}. Note, that the Kotz and exponential power copulae are independent of \code{r}, and that \code{r} only enters the generator, the density, the probability and the quantile functions. } \item{subdivisions}{ [ellipticalRho] - \cr an integer value with the number of subdivisons in each direction on the two dimensional unit square to compute the mean value of Spearman's Rho. By default 500 subdivisions are used. } \item{tail}{ [ellipticalTailPlot] - \cr a character string, either \code{"Upper"} or \code{"Lower"} denoting which of the two tails should be displayed. By default the upper tail dependence will be considered. } \item{type}{ [*ellipticalCopula][gfunc] - \cr the type of the elliptical copula. A character string selected from: "norm", "cauchy", "t", "logistic", "laplace", "kotz", or "epower". [*ellipticalSlider] - \cr a character string which indicates what kind of plot should be displayed, either a perspective plot if \code{type="persp"}, the default value, or a contour plot if \code{type="contour"}. } } \value{ \bold{Copula Functions:} \cr\cr The functions \code{[rpd]ellipticalCopula} return a numeric vector of random variates, probabilities, or densities for the specified copula computed at grid coordinates \code{u}|\code{v}. \cr The functions \code{[rpd]ellipticalSlider} display an interactive graph of an perspective copula plot either for random variates, probabilities or densities. Alternatively, an image underlayed contour plot can be shown. \cr \bold{Copula Dependence Measures:} \cr\cr The functions \code{ellipticalTau} and \code{ellipticalRho} return a numericc value for Kendall's Tau and Spearman's Rho. \cr \bold{Copula Tail Coefficient:} \cr\cr The function \code{ellipticalTailCoeff} returns the coefficient of tail dependence for a specified copula. The function \code{ellipticalTailPlot} displays a whole plot for the upper or alternatively for the lower tail dependence as a function of \code{u} for a set of nine \code{rho} values. \cr \bold{Copula Generator Function:} \cr\cr The function \code{gfunc} computes the generator function for the specified copula, by default the normal copula. If the argument \code{x} is missing, then the normalization constand lambda will be returned, otherwise if \code{x} is specified the values for the function \emph{g(x)} will be freturned. The selected type of copula is added to the output as an attribute named \code{"control"}. The function \code{gfuncSlider} allows to display interactively the generator function, the marginal density, the marginal probability, and the contours of the the bivariate density. \cr \bold{Copula Simulation and Parameter Fitting:} \cr\cr The function \code{ellipticalCopulaSim} returns a numeric two-column matrix with randomly generated variates for the specified copula. \cr The function \code{ellipticalCopulaFit} returns a fit to empirical data for the specified copula. The returned object is a list with elements from the function \code{nlminb}. } \author{ Diethelm Wuertz for the Rmetrics \R-port. } \examples{ ## [rp]ellipticalCopula - # Default Normal Copula: rellipticalCopula(10) pellipticalCopula(10) ## [rp]ellipticalCopula - # Student-t Copula Probability and Density: u = grid2d(x = (0:25)/25) pellipticalCopula(u, rho = 0.75, param = 4, type = "t", output = "list") d <- dellipticalCopula(u, rho = 0.75, param = 4, type = "t", output = "list") persp(d, theta = -40, phi = 30, col = "steelblue") ## ellipticalTau - ## ellipticalRho - # Dependence Measures: ellipticalTau(rho = -0.5) ellipticalRho(rho = 0.75, type = "logistic", subdivisions = 100) ## ellipticalTailCoeff - # Student-t Tail Coefficient: ellipticalTailCoeff(rho = 0.25, param = 3, type = "t") ## gfunc - # Generator Function: plot(gfunc(x = 0:10), main = "Generator Function") ## ellipticalCopulaSim - ## ellipticalCopulaSim - # Simualtion and Parameter Fitting: rv <- ellipticalCopulaSim(n = 100, rho = 0.75) ellipticalCopulaFit(rv) } \keyword{models} fCopulae/man/EllipticalCopulae.Rd0000644000176200001440000002032214265245633016456 0ustar liggesusers\name{EllipticalCopulae} \alias{EllipticalCopulae} \alias{rellipticalCopula} \alias{pellipticalCopula} \alias{dellipticalCopula} \alias{rellipticalSlider} \alias{pellipticalSlider} \alias{dellipticalSlider} \title{Bivariate Elliptical Copulae} \description{ A collection and description of functions to investigate bivariate elliptical copulae. \cr Elliptical Copulae Functions: \tabular{ll}{ \code{rellipticalCopula} \tab Generates elliptical copula variates, \cr \code{pellipticalCopula} \tab computes elliptical copula probability, \cr \code{dellipticalCopula} \tab computes elliptical copula density, \cr \code{rellipticalSlider} \tab displays interactive plots of variates, \cr \code{pellipticalSlider} \tab displays interactive plots of probability, \cr \code{dellipticalSlider} \tab displays interactive plots of density. } } \usage{ rellipticalCopula(n, rho = 0.75, param = NULL, type = c("norm", "cauchy", "t")) pellipticalCopula(u = 0.5, v = u, rho = 0.75, param = NULL, type = ellipticalList(), output = c("vector", "list"), border = TRUE) dellipticalCopula(u = 0.5, v = u, rho = 0.75, param = NULL, type = ellipticalList(), output = c("vector", "list"), border = TRUE) rellipticalSlider(B = 100) pellipticalSlider(type = c("persp", "contour"), B = 20) dellipticalSlider(type = c("persp", "contour"), B = 20) } \arguments{ \item{B}{ [*Slider] - \cr the maximum slider menu value when the boundary value is infinite. By default this is set to 10. } \item{border}{ [pellipticalCopula][dellipticalCopula] - \cr a logical flag. If the argument \code{u} is an integer, say \code{N}, greater than one than all points on a square grid \code{[(0:N)/N]^2} are computed. If border is FALSE than the border points are removed from the returned value, by default this is not the case. } \item{n}{ [rellipticalCopula][ellipticalCopulaSim] - \cr the number of random deviates to be generated, an integer value. } \item{output}{ [pellipticalCopula][dellipticalCopula] - \cr a character string specifying how the output should be formatted. By default a vector of the same length as \code{u} and \code{v} is returned. If specified as \code{"list"} then \code{u} and \code{v} are expected to span a two-dimensional grid as outputted by the function \code{grid2d} and the function returns a list with elements \code{$x}, \code{y}, and \code{z} which can be directly used for example by 2D plotting functions. For the grid version, when \code{u} is specified as an integer greater than one, always the output in form of a list will be returned. } \item{rho}{ [*ellipticalCopula] - \cr is the numeric value setting the correlation strength, ranging between minus one and one. } \item{param}{ [*ellipticalCopula][gfunc] - \cr additional distributional parameters: for the Sudent-t distribution this is "nu", for the Kotz distribution this is "r", and for the Exponential Power distribution these are "r" and "s". If the argument \code{param=NULL} then default values are taken. These are for the Student-t \code{param=c(nu=4))}, for the Kotz distribution \code{param=c(r=1))}, and for the exponential power distribution \code{param=c(r=1,s=1)}. Note, that the Kotz and exponential power copulae are independent of \code{r}, and that \code{r} only enters the generator, the density, the probability and the quantile functions. } \item{type}{ [*ellipticalCopula][gfunc] - \cr the type of the elliptical copula. A character string selected from: "norm", "cauchy", "t", "logistic", "laplace", "kotz", or "epower". [*ellipticalSlider] - \cr a character string which indicates what kind of plot should be displayed, either a perspective plot if \code{type="persp"}, the default value, or a contour plot if \code{type="contour"}. } \item{u, v}{ [*ellipticalCopula] - \cr two numeric values or vectors of the same length at which the copula will be computed. If \code{u} is a list then the the \code{$x} and \code{$y} elements will be used as \code{u} and \code{v}. If \code{u} is a two column matrix then the first column will be used as \code{u} and the the second as \code{v}. If \code{u} is an integer value greater than one, say \code{N}, than the values for all points on the \code{[(0:N)/N]^2} grid spanning the unit square will be returned. } } \value{ \bold{Copula Functions:} \cr\cr The functions \code{[rpd]ellipticalCopula} return a numeric vector of random variates, probabilities, or densities for the specified copula computed at grid coordinates \code{u}|\code{v}. \cr The functions \code{[rpd]ellipticalSlider} display an interactive graph of an perspective copula plot either for random variates, probabilities or densities. Alternatively, an image underlayed contour plot can be shown. \cr \bold{Copula Dependence Measures:} \cr\cr The functions \code{ellipticalTau} and \code{ellipticalRho} return a numericc value for Kendall's Tau and Spearman's Rho. \cr \bold{Copula Tail Coefficient:} \cr\cr The function \code{ellipticalTailCoeff} returns the coefficient of tail dependence for a specified copula. The function \code{ellipticalTailPlot} displays a whole plot for the upper or alternatively for the lower tail dependence as a function of \code{u} for a set of nine \code{rho} values. \cr \bold{Copula Generator Function:} \cr\cr The function \code{gfunc} computes the generator function for the specified copula, by default the normal copula. If the argument \code{x} is missing, then the normalization constand lambda will be returned, otherwise if \code{x} is specified the values for the function \emph{g(x)} will be freturned. The selected type of copula is added to the output as an attribute named \code{"control"}. The function \code{gfuncSlider} allows to display interactively the generator function, the marginal density, the marginal probability, and the contours of the the bivariate density. \cr \bold{Copula Simulation and Parameter Fitting:} \cr\cr The function \code{ellipticalCopulaSim} returns a numeric two-column matrix with randomly generated variates for the specified copula. \cr The function \code{ellipticalCopulaFit} returns a fit to empirical data for the specified copula. The returned object is a list with elements from the function \code{nlminb}. } \author{ Diethelm Wuertz for the Rmetrics \R-port. } \examples{ ## [rp]ellipticalCopula - # Default Normal Copula: rellipticalCopula(10) pellipticalCopula(10) ## [rp]ellipticalCopula - # Student-t Copula Probability and Density: u <- grid2d(x = (0:25)/25) pellipticalCopula(u, rho = 0.75, param = 4, type = "t", output = "list") d <- dellipticalCopula(u, rho = 0.75, param = 4, type = "t", output = "list") persp(d, theta = -40, phi = 30, col = "steelblue") ## ellipticalTau - ## ellipticalRho - # Dependence Measures: ellipticalTau(rho = -0.5) ellipticalRho(rho = 0.75, type = "logistic", subdivisions = 100) ## ellipticalTailCoeff - # Student-t Tail Coefficient: ellipticalTailCoeff(rho = 0.25, param = 3, type = "t") ## gfunc - # Generator Function: plot(gfunc(x = 0:10), main = "Generator Function") ## ellipticalCopulaSim - ## ellipticalCopulaSim - # Simualtion and Parameter Fitting: rv <- ellipticalCopulaSim(n = 100, rho = 0.75) ellipticalCopulaFit(rv) } \keyword{models} fCopulae/man/ExtremeValueGenerator.Rd0000644000176200001440000000545214265245633017347 0ustar liggesusers\name{ExtremeValueGenerator} \alias{ExtremeValueGenerator} \alias{evList} \alias{evParam} \alias{evRange} \alias{evCheck} \alias{Afunc} \alias{AfuncSlider} \title{Bivariate Extreme Value Copulae} \description{ A collection and description of functions concerned with the generator function for the extreme value copula and with functions for setting and checking the distributional parameters. \cr Functions: \tabular{ll}{ \code{evList} \tab Returns list of implemented extreme value copulae, \cr \code{evParam} \tab sets default parameters for an extreme value copula, \cr \code{evRange} \tab returns the range of valid rho values, \cr \code{evCheck} \tab checks if rho is in the valid range, \cr \code{Afunc} \tab computes dependence function, \cr \code{AfuncSlider} \tab displays interactively dependence function. } } \usage{ evList() evParam(type = evList()) evRange(type = evList()) evCheck(param, type = evList()) Afunc(x, param = NULL, type = evList()) AfuncSlider() } \arguments{ \item{param}{ distribution and copulae parameters. A numeric value or vector of named parameters as required by the copula specified by the variable \code{type}. If set to \code{NULL}, then the default parameters will be taken. } \item{type}{ the type of the extreme value copula. A character string selected from: "gumbel", "galambos", "husler.reiss", "tawn", or "bb5". } \item{x}{ a numeric value or vector ranging between zero and one. } } \value{ The function \code{pcopula} returns a numeric matrix of probabilities computed at grid positions \code{x}|\code{y}. \cr The function \code{parchmCopula} returns a numeric matrix with values computed for the Archemedean copula. \cr The function \code{darchmCopula} returns a numeric matrix with values computed for thedensity of the Archemedean copula. \cr The functions \code{Phi*} return a numeric vector with the values computed from the Archemedean generator, its derivatives, or its inverse. \cr The functions \code{cK} and \code{cKInv} return a numeric vector with the values of the density and inverse for Archimedian copulae. } \author{ Diethelm Wuertz for the Rmetrics \R-port. } \examples{ ## fCOPULA - getClass("fCOPULA") getSlots("fCOPULA") ## revCopula - # Not yet implemented # revCopula(n = 10, type = "galambos") ## pevCopula - pevCopula(u = grid2d(), type = "galambos", output = "list") ## devCopula - devCopula(u = grid2d(), type = "galambos", output = "list") ## AfuncSlider - # Generator, try: \dontrun{AfuncSlider()} } \keyword{models} fCopulae/man/ArchimedeanGenerator.Rd0000644000176200001440000000650014265245633017134 0ustar liggesusers\name{ArchimedeanGenerator} \alias{ArchimedeanGenerator} \alias{archmList} \alias{archmParam} \alias{archmRange} \alias{archmCheck} \alias{Phi} \alias{PhiSlider} \alias{Kfunc} \alias{KfuncSlider} \title{Bivariate Archimedean Copulae} \description{ A collection and description of functions concerned with the generator function for the Archimedean copula and with functions for setting and checking the distributional parameters. \cr Functions: \tabular{ll}{ \code{evList} \tab Returns list of implemented Archimedean copulae, \cr \code{archmParam} \tab Sets default parameters for an Archimedean copula, \cr \code{archmRange} \tab returns the range of valid rho values, \cr \code{archmCheck} \tab checks if rho is in the valid range, \cr \code{Phi} \tab Computes generator Phi, inverse and derivatives, \cr \code{PhiSlider} \tab displays interactively generator function, \cr \code{Kfunc} \tab computes copula density and its inverse, \cr \code{KfuncSlider} \tab displays interactively density function. } } \usage{ archmList() archmParam(type = archmList()) archmRange(type = archmList(), B = Inf) archmCheck(alpha, type = archmList()) Phi(x, alpha = NULL, type = archmList(), inv = FALSE, deriv = paste(0:2)) PhiSlider(B = 5) Kfunc(x, alpha = NULL, type = archmList(), inv = FALSE, lower = 1.0e-8) KfuncSlider(B = 5) } \arguments{ \item{alpha}{ [Phi*][*archmCopula] - \cr the parameter of the Archemedean copula. A numerical value. } \item{B}{ [archmRange] - \cr the maximum slider menu value when the boundary value is infinite. By default this is set to \code{B=Inf}.\cr [*Slider] - \cr the maximum slider menu value when the boundary value is infinite. By default this is set to \code{B=5}. } \item{deriv}{ [Phi] - \cr an integer value. Should the function itself, \code{deriv="0"}, or the first \code{deriv="1"}, or second \code{deriv="2"} derivative be evaluated? } \item{inv}{ [Phi][Kfunc] - \cr a logical flag. Should the inverse function be computed? } \item{lower}{ [Kfunc] - \cr a numeric value setting the lower bound for the internal root finding function \code{uniroot}. } \item{type}{ [*archmCopula][Phi][Kfunc] - \cr the type of the Archimedean copula. A character string ranging beween \code{"1"} and \code{"22"}. By default copula No. 1 will be chosen. } \item{x}{ [Kfunc] - \cr a numeric value or vector ranging between zero and one.\cr [Phi] - \cr a numeric value or vector. } } \value{ The function \code{Phi} returns a numeric vector with the values computed from the Archemedean generator, its derivatives, or its inverse. \cr The function \code{Kfunc} returns a numeric vector with the values of the density and inverse for Archimedian copulae. } \author{ Diethelm Wuertz for the Rmetrics \R-port. } \references{ RB Nelson - An Introduction to Copulas } \examples{ ## archmList - # Return list of implemented copulae: archmList() } \keyword{models} fCopulae/man/ArchimedeanDependency.Rd0000644000176200001440000000625214265245633017270 0ustar liggesusers\name{ArchimedeanDependency} \alias{ArchimedeanDependency} \alias{archmTau} \alias{archmRho} \alias{archmTailCoeff} \alias{archmTailPlot} \title{Bivariate Archimedean Copulae} \description{ A collection and description of functions to investigate bivariate Archimedean copulae. \cr Archimedean Copulae Functions: \tabular{ll}{ \code{archmTau} \tab Computes Kendall's tau for Archimedean copulae, \cr \code{archmRho} \tab computes Spearman's rho for Archimedean copulae, \cr \code{archmTailCoeff} \tab computes tail dependence for Archimedean copulae, \cr \code{archmTailPlot} \tab plots tail dependence for Archimedean copulae. } } \usage{ archmTau(alpha = NULL, type = archmList(), lower = 1.0e-10) archmRho(alpha = NULL, type = archmList(), method = c("integrate2d", "adapt"), error = 1.0e-5) archmTailCoeff(alpha = NULL, type = archmList()) archmTailPlot(alpha = NULL, type = archmList(), tail = c("Upper", "Lower")) } \arguments{ \item{alpha}{ the parameter of the Archemedean copula. A numerical value. } \item{error}{ [archmRho] - \cr the error bound to be achieved by the \code{integrate2d} integration formula. A numeric value, by default \code{error=1.0e-5}. } \item{lower}{ [archmTau] - \cr a numeric value setting the lower bound for the internal integration function \code{integrate}. } \item{tail}{ [archmTailPlot] - \cr a character string, either \code{"Upper"} or \code{"Lower"} denoting which of the two tails should be displayed. By default the upper tail dependence will be considered. } \item{type}{ the type of the Archimedean copula. A character string ranging beween \code{"1"} and \code{"22"}. By default copula No. 1 will be chosen. } \item{method}{ [archmRho] - \cr a character string that determines which integration method should be used, either \code{"integrate2d"} or \code{"adapt"}. If the second method is selected the contributed R package \code{"adapt"} is required. } } \value{ The function \code{pcopula} returns a numeric matrix of probabilities computed at grid positions \code{x}|\code{y}. \cr The function \code{parchmCopula} returns a numeric matrix with values computed for the Archemedean copula. \cr The function \code{darchmCopula} returns a numeric matrix with values computed for thedensity of the Archemedean copula. \cr The functions \code{Phi*} return a numeric vector with the values computed from the Archemedean generator, its derivatives, or its inverse. \cr The functions \code{cK} and \code{cKInv} return a numeric vector with the values of the density and inverse for Archimedian copulae. } \author{ Diethelm Wuertz for the Rmetrics \R-port. } % \examples{ % ## fCOPULA - % # getClass("fCOPULA") % ## pcopula - % # The default Normal Copula: % # contour(pcopula()) % } \keyword{models} fCopulae/DESCRIPTION0000644000176200001440000000144014356373443013531 0ustar liggesusersPackage: fCopulae Title: Rmetrics - Bivariate Dependence Structures with Copulae Date: 2023-01-03 Version: 4022.85 Author: Diethelm Wuertz [aut], Tobias Setz [aut], Yohan Chalabi [ctb], Paul Smith [cre] Maintainer: Paul Smith Description: Provides a collection of functions to manage, to investigate and to analyze bivariate financial returns by Copulae. Included are the families of Archemedean, Elliptical, Extreme Value, and Empirical Copulae. Depends: R (>= 2.15.1), timeDate, timeSeries, fBasics, fMultivar Imports: grDevices, graphics, stats Suggests: methods, RUnit, tcltk, mvtnorm, sn License: GPL (>= 2) URL: https://www.rmetrics.org NeedsCompilation: no Packaged: 2023-01-07 20:15:28 UTC; paul Repository: CRAN Date/Publication: 2023-01-07 22:50:11 UTC fCopulae/tests/0000755000176200001440000000000014265245633013164 5ustar liggesusersfCopulae/tests/doRUnit.R0000644000176200001440000000151614265245633014676 0ustar liggesusers#### 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) } fCopulae/R/0000755000176200001440000000000014354776142012226 5ustar liggesusersfCopulae/R/ExtremeValueModelling.R0000644000176200001440000000627414265245633016620 0ustar liggesusers # 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: EXTREME VALUE COPULA PARAMETER FITTING: # evCopulaSim Simulates bivariate extreme value copula # evCopulaFit Fits the paramter of an extreme value copula ################################################################################ ################################################################################ # FUNCTION: EXTREME VALUE COPULA PARAMETER FITTING: # evCopulaSim Simulates bivariate extreme value copula # evCopulaFit Fits the paramter of an extreme value copula evCopulaSim = function(n, param = NULL, type = evList()) { # A function implemented by Diethelm Wuertz # Description: # Simulates bivariate extreme value Copula # FUNCTION: # Match Arguments: type = match.arg(type) # Settings: if (is.null(param)) param = evParam(type)$param # Random Variates: ans = revCopula(n = n, param = param, type = type) # Return Value: ans } # ------------------------------------------------------------------------------ evCopulaFit = function(u, v = NULL, type = evList(), ...) { # A function implemented by Diethelm Wuertz # Description: # Fits the paramter of an elliptical copula # Note: # The upper limit for nu is 100 # FUNCTION: # Match Arguments: type = match.arg(type) # Settings: U <<- u V <<- v if (is.list(u)) { U <<- u[[1]] V <<- u[[2]] } if (is.matrix(u)) { U = u[, 1] V = u[, 2] } # Start Values: param = evParam(type)$param range = evRange(type) paramLength = length(param) # Log-Likelihood Function: .fun = function(x, type) { -mean( log(devCopula(u = U, v = V, param = x, type = type)) ) } if (paramLength == 1) { # We have only one parameter to optimize ... fit = optimize(f = .fun, lower = range[1], upper = range[2], maximum = FALSE, tol = .Machine$double.eps^0.25, type = type, ...) } else { # Log-Likelihood Function: range = evRange(type) fit = nlminb(start = param, objective = .fun, lower = range[1], upper = range[2], type = type, ...) } # Return Value: fit } ################################################################################ fCopulae/R/EllipticalCopulae.R0000644000176200001440000012551414265247131015744 0ustar liggesusers # 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: ELLIPTICAL COPULAE RANDOM DEVIATES: # rellipticalCopula Generates elliptical copula variates # rellipticalSlider Generates interactive plots of random variates # .rnormCopula Generates normal copula random variate # .rcauchyCopula Generates Cauchy copula random variate # .rtCopula Generates Student-t copula random variate # FUNCTION: ELLIPTICAL COPULAE PROBABILITY: # pellipticalCopula Computes elliptical copula probability # pellipticalSlider Generates interactive plots of probability # .pnormCopula Computes normal copula probability # .pcauchyCopula Computes Cauchy copula probability # .ptCopula Computes Student-t copula probability # .pellipticalCopulaGrid Fast equidistant grid version # .pellipticalCopulaDiag Fast diagonal cross section version # .pellipticalPerspSlider Interactive perspective plots of probability # .pellipticalContourSlider Interactive contour plots of probability # FUNCTION: ELLIPTICAL COPULAE DENSITY: # dellipticalCopula Computes elliptical copula density # dellipticalSlider Generates interactive plots of density # .dnormCopula Computes normal copula density # .dcauchyCopula Computes Cauchy copula density # .dtCopula Computes Student-t copula density # .dellipticalCopulaGrid Fast grid version for elliptical copula density # .dellipticalPerspSlider Interactive perspective plots of density # .dellipticalContourSlider Interactive contour plots of density ################################################################################ ################################################################################ # FUNCTION: ELLIPTICAL COPULAE RANDOM DEVIATES: # rellipticalCopula Generates elliptical copula variates # rellipticalSlider Generates interactive plots of random variates # .rnormCopula Generates normal copula random variate # .rcauchyCopula Generates Cauchy copula random variate # .rtCopula Generates Student-t copula random variate rellipticalCopula <- function(n, rho = 0.75, param = NULL, type = c("norm", "cauchy", "t")) { # A function implemented by Diethelm Wuertz # Description: # Computes extreme value copula probability # Arguments: # n - number of deviates to be generated. # rho - a numeric value setting the coorelation strength, ranging # between minus one and one. # nu - the number of degrees of freedom, only required for # Student-t copulae. # type - the type of the elliptical copula. Either "norm" or # "t" denoting the normal or Student-t copula, respectively. # output - a character string specifying how the output should # be formatted. By default a vector of the same length as # 'u' and 'v'. If specified as "list" then 'u' and 'v' are # expected to span a two-dimensional grid as outputted by the # function 'grid2d' and the function returns a list with # elements '$x', 'y', and 'z' which can be directly used # for example by 2D plotting functions. # Value: # returns a vector or list of probabilities depending on the # value of the "output" variable. # Example: # Diagonal Value: pnormCopula((0:10)/10) # persp(pnormCopula(u = grid2d(), output = "list")) # FUNCTION: # Settings: type = match.arg(type) # Parameters: if (type == "t") { if(is.null(param)) { param = c(nu = 4) } else { param = c(nu = param) } names(param) = "nu" } # Copula: if (type == "norm") ans = .rnormCopula(n = n, rho = rho) if (type == "cauchy") ans = .rcauchyCopula(n = n, rho = rho) if (type == "t") ans = .rtCopula(n = n, rho = rho, nu = param) # Add Control Attribute: control = list(rho = rho, param = param, type = type) attr(ans, "control")<-unlist(control) # Return Value: ans } # ------------------------------------------------------------------------------ rellipticalSlider <- function(B = 100) { # A function implemented by Diethelm Wuertz # Description: # Displays interactively perspective plots of random variates #FUNCTION: # Graphic Frame: par(mfrow = c(1, 1)) # Internal Function: refresh.code <- function(...) { # Startup Counter: .counter <- getRmetricsOptions(".counter") + 1 setRmetricsOptions(.counter = .counter) if (.counter < 7) return () # Sliders: Copula = .sliderMenu(no = 1) N = .sliderMenu(no = 2) rho = .sliderMenu(no = 3) nu = .sliderMenu(no = 4) seed = .sliderMenu(no = 5) size = .sliderMenu(no = 6) col = .sliderMenu(no = 7) Names = c("- Normal", "- Cauchy", "- Student t") Type = c("norm", "cauchy", "t") eps = 1.0e-6 if (rho == +1) rho = rho - eps if (rho == -1) rho = rho + eps # Tau and Rho: Tau = ellipticalTau(rho) Rho = ellipticalRho(rho) # Plot: Title = paste("Elliptical Copula No:", as.character(Copula), Names[Copula], "\nrho =", as.character(rho), "|") if (Copula == 2) Title = paste(Title, "nu =", as.character(nu), "|") Title = paste(Title, "Kendall = ", as.character(round(Tau, digits = 3)), "|", "Spearman = ", as.character(round(Rho, digits = 3)) ) set.seed(seed) R = rellipticalCopula(n = N, rho = rho, param = nu, type = Type[Copula]) plot(x = R[, 1], y = R[, 2], xlim = c(0, 1), ylim = c(0, 1), xlab = "u", ylab = "v", pch = 19, col = col, cex = size) title(main = Title) # Reset Frame: par(mfrow = c(1, 1)) } # Open Slider Menu: setRmetricsOptions(.counter = 0) plot.names = c("Plot - size", "... color") .sliderMenu(refresh.code, names = c("Copula", "N", "rho", "t: nu", "seed", plot.names), minima = c( 1, 1000, -1, 1, 1000, 0, 1), maxima = c( 3, 10000, +1, B, 9999, 1, 16), resolutions = c( 1, 500, 0.01, 1, 1, 0.1, 1), starts = c( 1, 1000, 0, 4, 4711, 0.5, 1)) } # ------------------------------------------------------------------------------ .rnormCopula <- function(n, rho = 0.75) { # A function implemented by Diethelm Wuertz # Description: # Generates normal copula random variate # Example: # UV = rnormCopula(n = 10000); plot(UV[,1], UV[,2], cex = 0.25) # FUNCTION: ## Use: X = .rnorm2d(n, rho) or alternatively: ## X = fMultivar:::.rnorm2d(n = n, rho = rho) ## The above isn;t exported - use the exported function X = fMultivar::rnorm2d(n = n, rho = rho) # Generate Z <- NULL for(i in (1:n)) Z <- rbind(Z, pnorm(X [i,])) # Return Value: Z } # ------------------------------------------------------------------------------ .rcauchyCopula <- function(n, rho = 0.75) { # A function implemented by Diethelm Wuertz # Description: # Generates Student-t copula random variate # Example: # UV = rtCopula(n = 10000); plot(UV[,1], UV[,2], cex = 0.25) # FUNCTION: # Cauchy Deviates: Z = .rtCopula(n = n, rho = rho, nu = 1) # Return Value: Z } # ------------------------------------------------------------------------------ .rtCopula <- function(n, rho = 0.75, nu = 4) { # A function implemented by Diethelm Wuertz # Description: # Generates Student-t copula random variate # Example: # UV = rtCopula(n = 10000); plot(UV[,1], UV[,2], cex = 0.25) # FUNCTION: # Use: X = .rnorm2d(n, rho) or alternatively: X = rt2d(n = n, rho = rho, nu = nu) # Generate Z = NULL for (i in (1:n)) Z = rbind(Z, pt(X [i,], df = nu)) # Return Value: Z } ################################################################################ # FUNCTION: ELLIPTICAL COPULAE PROBABILITY: # pellipticalCopula Computes elliptical copula probability # pellipticalSlider Generates interactive plots of probability # .pnormCopula Computes normal copula probability # .pcauchyCopula Computes Cauchy copula probability # .ptCopula Computes Student-t copula probability # .pellipticalCopulaGrid Fast equidistant grid version # .pellipticalCopulaDiag Fast diagonal cross section version # .pellipticalPerspSlider Interactive perspective plots of probability # .pellipticalContourSlider Interactive contour plots of probability pellipticalCopula <- function(u = 0.5, v = u, rho = 0.75, param = NULL, type = ellipticalList(), output = c("vector", "list"), border = TRUE) { # A function implemented by Diethelm Wuertz # Description: # Computes extreme value copula probability # Arguments: # u, v - two numeric values or vectors of the same length at # which the copula will be computed. If 'u' is a list then the # the '$x' and '$y' elements will be used as 'u' and 'v'. # If 'u' is a two column matrix then the first column will # be used as 'u' and the the second as 'v'. # rho - a numeric value setting the coorelation strength, ranging # between minus one and one. # param - distributional parameters, the number of degrees of # freedom for the Student-t copulae. # type - the type of the elliptical copula. Either "norm" or # "t" denoting the normal or Student-t copula, respectively. # output - a character string specifying how the output should # be formatted. By default a vector of the same length as # 'u' and 'v'. If specified as "list" then 'u' and 'v' are # expected to span a two-dimensional grid as outputted by the # function 'grid2d' and the function returns a list with # elements '$x', 'y', and 'z' which can be directly used # for example by 2D plotting functions. # Value: # returns a vector or list of probabilities depending on the # value of the "output" variable. # FUNCTION: # Match Arguments: type <- match.arg(type) output <- match.arg(output) # Settings: subdivisions = 100 if (is.list(u)) { v = u[[2]] u = u[[1]] } if (is.matrix(u)) { v = u[, 2] u = u[, 1] } if (length(u) == 1 & u[1] > 1) { return(.pellipticalCopulaGrid(N = u, rho, param, type, border = border)) } # Parameters: if (type == "t") if (is.null(param)) param = c(nu = 4) if (type == "kotz") if (is.null(param)) param = c(r = 1) if (type == "epower") if (is.null(param)) param = c(r = 1, s = 1) # Specical Copulae: if (type == "norm") { if (rho == -1) { ans <- pfrechetCopula(u = u, v = v, type = "m", output = output) return(ans) } else if (rho == +1) { ans <- pfrechetCopula(u = u, v = v, type = "w", output = output) return(ans) } else { ans = .pnormCopula(u = u, v = v, rho = rho, output = output) return(ans) } } else if (type == "cauchy") { ans <- .pcauchyCopula(u = u, v = v, rho = rho, output = output) return(ans) } else if (type == "t") { if (is.null(param)) param = 4 ans <- .ptCopula(u = u, v = v, rho = rho, nu = param, output = output) return(ans) } # The remaining Copulae - Compute Density on Regular Grid: N = subdivisions x = (0:N)/N c.uv = .dellipticalCopulaGrid(N = N, rho, param, type, border = TRUE) c.uv$z[is.na(c.uv$z)] = 0 # Integrate to get Probability: C.uv = 0*c.uv$z for (i in 1:(N+1)) { D = matrix(rep(0, times = (N+1)^2), ncol = N+1) for (j in 1:i) { D[1:i, j] = 1 C.uv[i,j] = C.uv[j,i] = sum(D*c.uv$z) } } C.uv = C.uv/N^2 # Take care about the Boundary on the Unit Square: C.uv[1, ] = C.uv[, 1] = 0 C.uv[N+1, ] = C.uv[, N+1] = c.uv$x # Interpolate for the desired Values on the grid: U0 = trunc(u*N) V0 = trunc(v*N) P = (u - U0/N) Q = (v - V0/N) U0 = U0 + 1 U1 = U0 + 1 V0 = V0 + 1 V1 = V0 + 1 C.vec = rep(NA, times = length(u)) for ( i in 1:length(u) ) { p = P[i] q = Q[i] if (p == 0 & q == 0) { C.vec[i] = C.uv[U0[i], V0[i]] } else if (p == 0 & q > 0) { C.vec[i] = (1-q)*C.uv[U0[i], V0[i]] + q*C.uv[U0[i], V1[i]] } else if (p > 0 & q == 0) { C.vec[i] = (1-p)*C.uv[U0[i], V0[i]] + p*C.uv[U1[i], V0[i]] } else { C.vec[i] = (1-p)*(1-q)*C.uv[U0[i], V0[i]] + p*(1-q)*C.uv[U1[i], V0[i]] + (1-p)*q*C.uv[U0[i], V1[i]] + p*q*C.uv[U1[i], V1[i]] } } C.uv = round(C.vec, digits = 3) attr(C.uv, "control") <- c(rho = rho) # As List ? if (output == "list") { N = sqrt(length(u)) x = u[1:N] y = matrix(v, ncol = N)[1, ] names(x) = names(y) = NULL C.uv = list(x = x, y = y, z = matrix(C.uv, ncol = N)) } # Return Value: C.uv } # ------------------------------------------------------------------------------ pellipticalSlider <- function(type = c("persp", "contour"), B = 20) { # A function implemented by Diethelm Wuertz # Description: # Displays interactively plots of probability # Description: # Displays interactively plots of probability # Arguments: # type - a character string specifying the plot type. # Either a perspective plot which is the default or # a contour plot with an underlying image plot will # be created. # B - the maximum slider menu value when the boundary # value is infinite. By default this is set to 10. # FUNCTION: # Settings: type = match.arg(type) # Plot: if (type == "persp") .pellipticalPerspSlider(B = B) if (type == "contour") .pellipticalContourSlider(B = B) # Return Value: invisible() } # ------------------------------------------------------------------------------ .pnormCopula <- function(u = 0.5, v = u, rho = 0.75, output = c("vector", "list") ) { # A function implemented by Diethelm Wuertz # Description: # Computes normal copula probability # Arguments: # see function 'pellipticalCopula' # FUNCTION: # Type: output = match.arg(output) # Settings: type = "norm" if (is.list(u)) { v = u[[2]] u = u[[1]] } if (is.matrix(u)) { v = u[, 2] u = u[, 1] } # Copula Probability: C.uv = pnorm2d(qnorm(u), qnorm(v), rho = rho) names(C.uv) = NULL # Simulates Max function: C.uv = (C.uv + abs(C.uv))/2 # On Boundary: C.uv[is.na(C.uv)] = 0 C.uv[which(u == 0)] = 0 C.uv[which(u == 1)] = v[which(u == 1)] C.uv[which(v == 0)] = 0 C.uv[which(v == 1)] = u[which(v == 1)] C.uv[which(u*v == 1)] = 1 C.uv[which(u+v == 0)] = 0 # Result: attr(C.uv, "control") <- c(rho = rho) # As List ? if (output == "list") { N = sqrt(length(u)) x = u[1:N] y = matrix(v, ncol = N)[1, ] C.uv = list(x = x, y = y, z = matrix(C.uv, ncol = N)) } # Return Value: C.uv } # ------------------------------------------------------------------------------ .pcauchyCopula <- function(u = 0.5, v = u, rho = 0.75, output = c("vector", "list") ) { # A function implemented by Diethelm Wuertz # Description: # Computes Student-t copula probability # Arguments: # see function 'pellipticalCopula' # FUNCTION: # Cauchy Probability: C.uv <- .ptCopula(u = u, v = v, rho = rho, nu = 1, output = output) attr(C.uv, "control") <- c(rho = rho) # Return Value: C.uv } # ------------------------------------------------------------------------------ .ptCopula <- function(u = 0.5, v = u, rho = 0.75, nu = 4, output = c("vector", "list") ) { # A function implemented by Diethelm Wuertz # Description: # Computes Student-t copula probability # Arguments: # see function 'pellipticalCopula' # FUNCTION: # Match Arguments: output <- match.arg(output) # Settings: type = "t" if (is.list(u)) { v = u[[2]] u = u[[1]] } if (is.matrix(u)) { v = u[, 2] u = u[, 1] } # Copula Probability: C.uv <- pt2d(qt(u, df = nu), qt(v, df = nu), rho = rho, nu = nu) names(C.uv) = NULL # Simulates Max function: C.uv = (C.uv + abs(C.uv))/2 # On Boundary: C.uv[is.na(C.uv)] = 0 C.uv[which(u == 0)] = 0 C.uv[which(u == 1)] = v[which(u == 1)] C.uv[which(v == 0)] = 0 C.uv[which(v == 1)] = u[which(v == 1)] C.uv[which(u*v == 1)] = 1 C.uv[which(u+v == 0)] = 0 # Result: attr(C.uv, "control") <- c(rho = rho, nu = nu) # As List ? if (output == "list") { N = sqrt(length(u)) x = u[1:N] y = matrix(v, ncol = N)[1, ] C.uv = list(x = x, y = y, z = matrix(C.uv, ncol = N)) } # Return Value: C.uv } # ------------------------------------------------------------------------------ .pellipticalCopulaGrid <- function(N, rho = 0.75, param = NULL, type = ellipticalList(), border = TRUE) { # A function implemented by Diethelm Wuertz # Description: # Computes elliptical copula probability on a 2d grid # Arguments: # see function pellipticalCopula() # FUNCTION: # Settings: U = (0:N)/N V = (1:(N-1))/N # Compute Density on Regular Grid: c.uv = .dellipticalCopulaGrid(N, rho, param, type, border = TRUE) c.uv$z[is.na(c.uv$z)] = 0 # Integrate to get Probability: if (TRUE) { C.uv = 0*c.uv$z for (i in 1:(N+1)) { for (j in 1:i) { C.uv[i,j] = C.uv[j,i] = sum(c.uv$z[1:i, 1:j]) } } C.uv = C.uv/N^2 } if (FALSE) { # This is much slower ! IJ = grid2d(1:(N+1)) X = cbind(IJ$x, IJ$y) fun = function(X, C) sum(C[1:X[1], 1:X[2]]) C.uv = apply(X, MARGIN=1, FUN = fun, C = c.uv$z) C.uv = matrix(C.uv, byrow = TRUE, ncol = N+1) / N^2 } # Probability - Take care about the Boundary on the Unit Square: C.uv[1, ] = C.uv[, 1] = 0 C.uv[N+1, ] = C.uv[, N+1] = c.uv$x names(C.uv) = NULL attr(C.uv, "control") <- c(rho = rho) C.uv = list(x = U, y = U, z = matrix(C.uv, ncol = length(U))) if (!border) { C.uv$z = C.uv$z[-1, ] C.uv$z = C.uv$z[-N, ] C.uv$z = C.uv$z[, -1] C.uv$z = C.uv$z[, -N] C.uv$x = C.uv$y = V } # Return Value: C.uv } # ------------------------------------------------------------------------------ .pellipticalCopulaDiag <- function(N, rho = 0.75, param = NULL, type = ellipticalList(), border = TRUE) { # A function implemented by Diethelm Wuertz # Description: # Computes elliptical diagonal cross section copula probability # Arguments: # see function pellipticalCopula() # FUNCTION: # Settings: U = (0:N)/N V = (1:(N-1))/N # Compute Density on Regular Grid: c.uv = .dellipticalCopulaGrid(N, rho, param, type[1], border = TRUE) c.uv$z[is.na(c.uv$z)] = 0 # Integrate to get Probability: C.uu = 0*U for (i in 1:(N+1)) { C.uu[i] = sum(c.uv$z[1:i, 1:i]) } C.uu = C.uu/N^2 names(C.uu) = NULL attr(C.uu, "control") <- c(rho = rho) if (border) { C.uu = list(x = U, y = C.uu) } else { C.uu = list(x = V, y = C.uu[c(-1,-(N+1))]) } # Return Value: C.uu } # ------------------------------------------------------------------------------ .pellipticalPerspSlider <- function(B = 20) { # A function implemented by Diethelm Wuertz # Description: # Displays interactively perspective plots of probability # Arguments: # FUNCTION: # Graphic Frame: par(mfrow = c(1, 1)) # Internal Function: refresh.code = function(...) { # Startup Counter: .counter <- getRmetricsOptions(".counter") + 1 setRmetricsOptions(.counter = .counter) if (.counter < 7) return () # Sliders: Copula = .sliderMenu(no = 1) N = .sliderMenu(no = 2) rho = .sliderMenu(no = 3) nu = .sliderMenu(no = 4) s = .sliderMenu(no = 5) theta = .sliderMenu(no = 6) phi = .sliderMenu(no = 7) r = 1 # Title: Names = c("- Normal", "- Student t", "- Logistic", "- Exponential Power") if (nu == 1) Names[2] = "- Student-t [Cauchy]" if (s == 0.5) Names[4] = "- Exponential Power [Laplace]" if (s == 1) Names[4] = "- Exponential Power [Kotz|Normal]" Title = paste("Elliptical Copula No:", as.character(Copula), Names[Copula], "\nrho = ", as.character(rho)) if (Copula == 2) Title = paste(Title, "nu =", as.character(nu)) if (Copula == 4) Title = paste(Title, "s =", as.character(s)) # Plot: Type = c("norm", "t", "logistic", "epower") param = NULL if (Copula == 2) param = nu if (Copula == 4) param = c(r, s) P = .pellipticalCopulaGrid(N = N, rho = rho, param = param, type = Type[Copula], border = TRUE) persp(P, theta = theta, phi = phi, col = "steelblue", shade = 0.5, ticktype = "detailed", cex = 0.5, xlab = "u", ylab = "v", zlab = "C(u, v)", xlim = c(0, 1), ylim = c(0, 1), zlim = c(0, 1) ) title(main = Title) Tau = as.character(round(2*asin(rho)/pi, 2)) mTitle = paste("Tau", Tau) mtext(mTitle, side = 4, col = "grey", cex = 0.7) mTitle = paste("1: Normal | 2: Student-t [Cauchy] | 3: Logistic |", "4: Exponential Power [Laplace|Kotz]") mtext(mTitle, side = 1, line = 3, col = "grey", cex = 0.7) # Reset Frame: par(mfrow = c(1, 1)) } # Open Slider Menu: setRmetricsOptions(.counter = 0) plot.names = c("Plot - theta", "... phi") .sliderMenu(refresh.code, names = c("Copula", "N", "rho", "2: nu", "4: s", plot.names), minima = c( 1, 10, -0.95, 1, 0.1, -180, 0), maxima = c( 4, 100, 0.95, B, 5, 180, 360), resolutions = c( 1, 10, 0.05, 0.1, 0.1, 1, 1), starts = c( 1, 20, 0.50, 4, 1, -40, 30)) } # ------------------------------------------------------------------------------ .pellipticalContourSlider <- function(B = 20) { # A function implemented by Diethelm Wuertz # Description: # Displays interactively perspective plots of probability # Arguments: # FUNCTION: # Graphic Frame: par(mfrow = c(1, 1)) # Internal Function: refresh.code = function(...) { # Startup Counter: .counter <- getRmetricsOptions(".counter") + 1 setRmetricsOptions(.counter = .counter) if (.counter < 7) return () # Sliders: Copula = .sliderMenu(no = 1) N = .sliderMenu(no = 2) rho = .sliderMenu(no = 3) nu = .sliderMenu(no = 4) s = .sliderMenu(no = 5) nlev = .sliderMenu(no = 6) ncol = .sliderMenu(no = 7) r = 1 # Title: Names = c("- Normal", "- Student t", "- Logistic", "- Exponential Power") if (nu == 1) Names[2] = "- Student-t [Cauchy]" if (s == 0.5) Names[4] = "- Exponential Power [Laplace]" if (s == 1) Names[4] = "- Exponential Power [Kotz|Normal]" Title = paste("Elliptical Copula No:", as.character(Copula), Names[Copula], "\nrho = ", as.character(rho)) if (Copula == 2) Title = paste(Title, "nu =", as.character(nu)) if (Copula == 4) Title = paste(Title, "s =", as.character(s)) # Plot: Type = c("norm", "t", "logistic", "epower") param = NULL if (Copula == 2) param = nu if (Copula == 4) param = c(r, s) P = .pellipticalCopulaGrid(N = N, rho = rho, param = param, type = Type[Copula], border = FALSE) image(P, col = heat.colors(ncol), ylab = "v") mtext("u", side = 1, line = 2, cex = 0.7) contour(P, nlevels = nlev, add = TRUE) title(main = Title) Tau = as.character(round(2*asin(rho)/pi, 2)) mTitle = paste("Tau", Tau) mtext(mTitle, side = 4, col = "grey", cex = 0.7) mTitle = paste("1: Normal | 2: Student-t [Cauchy] | 3: Logistic |", "4: Exponential Power [Laplace|Kotz]") mtext(mTitle, side = 1, line = 3, col = "grey", cex = 0.7) # Reset Frame: par(mfrow = c(1, 1)) } # Open Slider Menu: setRmetricsOptions(.counter = 0) plot.names = c("Plot - levels", "... colors") .sliderMenu(refresh.code, names = c("Copula", "N", "rho", "2: nu", "4: s", plot.names), minima = c( 1, 10, -0.95, 1, 0.1, 5, 12), maxima = c( 4, 100, 0.95, B, 5, 100, 256), resolutions = c( 1, 10, 0.05, 0.1, 0.1, 5, 4), starts = c( 1, 20, 0.50, 4, 1, 10, 32)) } ################################################################################ # FUNCTION: ELLIPTICAL COPULAE DENSITY: # dellipticalCopula Computes elliptical copula density # dellipticalSlider Generates interactive plots of density # .dnormCopula Computes normal copula density # .dcauchyCopula Computes Cauchy copula density # .dtCopula Computes Student-t copula density # .dellipticalCopulaGrid Fast grid version for elliptical copula density # .dellipticalPerspSlider Interactive perspective plots of density # .dellipticalContourSlider Interactive contour plots of density dellipticalCopula <- function(u = 0.5, v = u, rho = 0.75, param = NULL, type = ellipticalList(), output = c("vector", "list"), border = TRUE) { # A function implemented by Diethelm Wuertz # Description: # Computes extreme value copula density # Arguments: # u, v - two numeric values or vectors of the same length at # which the copula will be computed. If 'u' is a list then the # the '$x' and '$y' elements will be used as 'u' and 'v'. # If 'u' is a two column matrix then the first column will # be used as 'u' and the the second as 'v'. # rho - a numeric value setting the coorelation strength, ranging # between minus one and one. # param - additional distributional parameters. # type - the type of the elliptical copula. Either "norm" or # "t" denoting the normal or Student-t copula, respectively. # output - a character string specifying how the output should # be formatted. By default a vector of the same length as # 'u' and 'v'. If specified as "list" then 'u' and 'v' are # expected to span a two-dimensional grid as outputted by the # function 'grid2d' and the function returns a list with # elements '$x', 'y', and 'z' which can be directly used # for example by 2D plotting functions. # Value: # returns a vector or list of probabilities depending on the # value of the "output" variable. # Example: # Diagonal Value: pnormCopula((0:10)/10) # persp(pnormCopula(u = grid2d(), output = "list")) # FUNCTION: # Use Grid Version? if (is.numeric(u)) { if (length(u) == 1 & u[1] > 1) { ans = .dellipticalCopulaGrid(N = u, rho = rho, param = param, type = type, border = border) return(ans) } } # Match Arguments: type = match.arg(type) output = match.arg(output) # Settings: if (is.list(u)) { v = u[[2]] u = u[[1]] } if (is.matrix(u)) { v = u[, 2] u = u[, 1] } if (length(u) == 1 & u[1] > 1) { return(.pellipticalCopulaGrid(N = u, rho, param, type, border = border)) } # Parameters: if (type == "t") if (is.null(param)) param = c(nu = 4) if (type == "kotz") if (is.null(param)) param = c(r = 1) if (type == "epower") if (is.null(param)) param = c(r = 1, s = 1) # Density: x = .qelliptical(u, param = param, type = type) y = .qelliptical(v, param = param, type = type) c.uv = delliptical2d(x, y, rho = rho, param = param, type = type) / ( .delliptical(x, param = param, type = type) * .delliptical(y, param = param, type = type) ) if (rho == 0 & type == "norm") c.uv[!is.na(c.uv)] = 1 names(c.uv) = NULL attr(c.uv, "control") <- c(rho = rho) if (output == "list") { N = sqrt(length(u)) x = u[1:N] y = matrix(v, ncol = N)[1, ] c.uv = list(x = x, y = y, z = matrix(c.uv, ncol = N)) } # Return Value: c.uv } # ------------------------------------------------------------------------------ dellipticalSlider <- function(type = c("persp", "contour"), B = 20) { # A function implemented by Diethelm Wuertz # Description: # Displays interactively plots of density # Description: # Displays interactively plots of density # Arguments: # type - a character string specifying the plot type. # Either a perspective plot which is the default or # a contour plot with an underlying image plot will # be created. # B - the maximum slider menu value when the boundary # value is infinite. By default this is set to 10. # FUNCTION: # Settings: type = match.arg(type) # Plot: if (type == "persp") .dellipticalPerspSlider(B = B) if (type == "contour") .dellipticalContourSlider(B = B) # Return Value: invisible() } # ------------------------------------------------------------------------------ .dnormCopula <- function(u = 0.5, v = u, rho = 0.75, output = c("vector", "list") ) { # A function implemented by Diethelm Wuertz # Description: # Computes normal copula density # Arguments: # see function 'dellipticalCopula' # FUNCTION: # Type: output = match.arg(output) # Settings: type = "norm" if (is.list(u)) { v = u[[2]] u = u[[1]] } if (is.matrix(u)) { v = u[, 2] u = u[, 1] } # Copula Density: x = qnorm(u) y = qnorm(v) c.uv = dnorm2d(x, y, rho)/(dnorm(x) * dnorm(y)) names(c.uv) = NULL # Result: attr(c.uv, "control") <- c(rho = rho) # As List ? if (output == "list") { N = sqrt(length(u)) x = u[1:N] y = matrix(v, ncol = N)[1, ] c.uv = list(x = x, y = y, z = matrix(c.uv, ncol = N)) } # Return Value: c.uv } # ------------------------------------------------------------------------------ .dtCopula <- function(u = 0.5, v = u, rho = 0.75, nu = 4, output = c("vector", "list") ) { # A function implemented by Diethelm Wuertz # Description: # Computes Student-t copula density # Arguments: # see function 'dellipticalCopula' # FUNCTION: # Match Arguments: output = match.arg(output) # Settings: type = "t" if (is.list(u)) { v = u[[2]] u = u[[1]] } if (is.matrix(u)) { v = u[, 2] u = u[, 1] } # Copula Probability: x = qt(u, df = nu) y = qt(v, df = nu) c.uv = dt2d(x, y, rho, nu)/(dt(x, nu) * dt(y, nu)) names(c.uv) = NULL # Result: attr(c.uv, "control") <- c(rho = rho, nu = nu) # As List ? if (output == "list") { N = sqrt(length(u)) x = u[1:N] y = matrix(v, ncol = N)[1, ] c.uv = list(x = x, y = y, z = matrix(c.uv, ncol = N)) } # Return Value: c.uv } # ------------------------------------------------------------------------------ .dcauchyCopula <- function(u = 0.5, v = u, rho = 0.75, nu = 4, output = c("vector", "list") ) { # A function implemented by Diethelm Wuertz # Description: # Computes Student-t copula density # Arguments: # see function 'dellipticalCopula' # FUNCTION: # Cauchy Density: c.uv = .dtCopula(u = u, v = v, rho = rho, nu = 1, output = output) attr(c.uv, "control") <- c(rho = rho) # Return Value: c.uv } # ------------------------------------------------------------------------------ .dellipticalCopulaGrid <- function(N, rho = 0.75, param = NULL, type = ellipticalList(), border = TRUE) { # A function implemented by Diethelm Wuertz # Description: # Computes extreme value copula density # Arguments: # N - the number of grid points is (N+1)*(N+1) # rho - a numeric value setting the coorelation strength, ranging # between minus one and one. # param - additional distributional parameters. # type - the type of the elliptical copula. Either "norm" or # "t" denoting the normal or Student-t copula, respectively. # Value: # returns a vector or list of probabilities depending on the # value of the "output" variable. # Note: # Made for the Sliders. # FUNCTION: # Settings: type = type[1] U = (0:N)/N V = (1:(N-1))/N # Reduce to Grid - speeds up the computation: M = N%/%2 + 1 X = .qelliptical(U[1:M], param = param, type = type) if (N%%2 == 0) { X = c(X, rev(-X)[-1]) } else { X = c(X, rev(-X)) } NX = length(X) x = rep(X, times = NX) y = rep(X, each = NX) D = .delliptical(X, param = param, type = type) DX = rep(D, times = NX) DY = rep(D, each = NX) # Density: c.uv = delliptical2d(x, y, rho = rho, param = param, type = type) / (DX*DY) if (rho == 0 & type == "norm") c.uv[!is.na(c.uv)] = 1 c.uv[is.na(c.uv)] = 0 names(c.uv) = NULL attr(c.uv, "control") <- c(rho = rho) c.uv = list(x = U, y = U, z = matrix(c.uv, ncol = N+1)) if (!border) { c.uv$z = c.uv$z[-1, ] c.uv$z = c.uv$z[-N, ] c.uv$z = c.uv$z[, -1] c.uv$z = c.uv$z[, -N] c.uv = list(x = V, y = V, z = matrix(c.uv$z, ncol = N-1)) } # Return Value: c.uv } # ------------------------------------------------------------------------------ .dellipticalPerspSlider <- function(B = 20) { # A function implemented by Diethelm Wuertz # Description: # Displays interactively perspective plots of density # FUNCTION: # Graphic Frame: par(mfrow = c(1, 1)) # Internal Function: refresh.code = function(...) { # Startup Counter: .counter <- getRmetricsOptions(".counter") + 1 setRmetricsOptions(.counter = .counter) if (.counter < 7) return () # Sliders: Copula = .sliderMenu(no = 1) N = .sliderMenu(no = 2) rho = .sliderMenu(no = 3) nu = .sliderMenu(no = 4) s = .sliderMenu(no = 5) theta = .sliderMenu(no = 6) phi = .sliderMenu(no = 7) r = 1 # Title: Names = c("- Normal", "- Student t", "- Logistic", "- Exponential Power") if (nu == 1) Names[2] = "- Student-t [Cauchy]" if (s == 0.5) Names[4] = "- Exponential Power [Laplace]" if (s == 1) Names[4] = "- Exponential Power [Kotz|Normal]" Title = paste("Elliptical Copula Density No:", as.character(Copula), Names[Copula], "\nrho = ", as.character(rho)) if (Copula == 2) Title = paste(Title, "nu =", as.character(nu)) if (Copula == 4) Title = paste(Title, "s =", as.character(s)) # Plot: uv = grid2d(x = (1:(N-1))/N) Type = c("norm", "t", "logistic", "epower") param = NULL if (Copula == 2) param = nu if (Copula == 4) param = c(r, s) D = .dellipticalCopulaGrid(N, rho = rho, param = param, type = Type[Copula], border = FALSE) Integrated = as.character(round(mean(D$z),2)) Var = var(as.vector(D$z), na.rm = TRUE) if (Var < 1.0e-6) { # A flat perspective plot fails, if zlim is not specified! Mean = round(1.5*mean(as.vector(D$z), na.rm = TRUE), 2) persp(D, theta = theta, phi = phi, col = "steelblue", shade = 0.5, ticktype = "detailed", cex = 0.5, xlab = "u", ylab = "v", zlim = c(0, Mean), zlab = "C(u,v)" ) } else { persp(D, theta = theta, phi = phi, col = "steelblue", shade = 0.5, ticktype = "detailed", cex = 0.5, xlab = "u", ylab = "v", zlab = "C(u,v)" ) } title(main = Title) Tau = as.character(round(2*asin(rho)/pi, 2)) mTitle = paste("Mean: ", Integrated, " | Tau", Tau) mtext(mTitle, side = 4, col = "grey", cex = 0.7) mTitle = paste("1: Normal | 2: Student-t [Cauchy] | 3: Logistic |", "4: Exponential Power [Laplace|Kotz]") mtext(mTitle, side = 1, col = "grey", cex = 0.7) # Reset Frame: par(mfrow = c(1, 1)) } # Open Slider Menu: setRmetricsOptions(.counter = 0) plot.names = c("Plot - theta", "... phi") .sliderMenu(refresh.code, names = c("Copula", "N", "rho", "3: nu", "4: s", plot.names), minima = c( 1, 10, -0.95, 1, 0.1, -180, 0), maxima = c( 4, 100, 0.95, B, 5, 180, 360), resolutions = c( 1, 10, 0.05, 0.1, 0.1, 1, 1), starts = c( 1, 20, 0.50, 4, 1, -40, 30)) } # ------------------------------------------------------------------------------ .dellipticalContourSlider <- function(B = 20) { # A function implemented by Diethelm Wuertz # Description: # Displays interactively perspective plots of density #FUNCTION: # Graphic Frame: par(mfrow = c(1, 1)) # Internal Function: refresh.code = function(...) { # Startup Counter: .counter <- getRmetricsOptions(".counter") + 1 setRmetricsOptions(.counter = .counter) if (.counter < 7) return () # Sliders: Copula = .sliderMenu(no = 1) N = .sliderMenu(no = 2) rho = .sliderMenu(no = 3) nu = .sliderMenu(no = 4) s = .sliderMenu(no = 5) nlev = .sliderMenu(no = 6) ncol = .sliderMenu(no = 7) if (rho == 0 & Copula == 1) return(invisible()) r = 1 # Title: Names = c("- Normal", "- Student t", "- Logistic", "- Exponential Power") if (nu == 1) Names[2] = "- Student-t [Cauchy]" if (s == 0.5) Names[4] = "- Exponential Power [Laplace]" if (s == 1) Names[4] = "- Exponential Power [Kotz|Normal]" Title = paste("Elliptical Copula Density No:", as.character(Copula), Names[Copula], "\nrho = ", as.character(rho)) if (Copula == 2) Title = paste(Title, "nu =", as.character(nu)) if (Copula == 4) Title = paste(Title, "s =", as.character(s)) # Plot: uv = grid2d(x = (0:N)/N) Type = c("norm", "t", "logistic", "laplace", "kotz", "epower") param = NULL if (Copula == 2) param = nu if (Copula == 5) param = r if (Copula == 6) param = c(r, s) D = .dellipticalCopulaGrid(N, rho = rho, param = param, type = Type[Copula], border = FALSE) Integrated = as.character(round(mean(D$z),2)) image(D, col = heat.colors(ncol), ylab = "v", xlim = c(0,1), ylim = c(0,1) ) mtext("u", side = 1, line = 2, cex = 0.7) contour(D, nlevels = nlev, add = TRUE) title(main = Title) Tau = as.character(round(2*asin(rho)/pi, 2)) mTitle = paste("Mean: ", Integrated, " | Tau", Tau) mtext(mTitle, side = 4, col = "grey", cex = 0.7) mTitle = paste("1: Normal | 2: Student-t [Cauchy] | 3: Logistic |", "4: Exponential Power [Laplace|Kotz]") mtext(mTitle, side = 1, line = 3, col = "grey", cex = 0.7) # Reset Frame: par(mfrow = c(1, 1)) } # Open Slider Menu: setRmetricsOptions(.counter = 0) plot.names = c("Plot - levels", "... colors") .sliderMenu(refresh.code, names = c("Copula", "N", "rho", "2: nu", "4: s", plot.names), minima = c( 1, 10, -0.95, 1, 0.1, 5, 12), maxima = c( 4, 100, 0.95, B, 5, 100, 256), resolutions = c( 1, 10, 0.05, 0.1, 0.1, 5, 4), starts = c( 1, 20, 0.50, 4, 1, 10, 32)) } ################################################################################ fCopulae/R/EllipticalGenerator.R0000644000176200001440000014600314265245633016303 0ustar liggesusers # 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: UTILITY FUNCTIONS: # ellipticalList Returns list of implemented Elliptical copulae # ellipticalParam Sets default parameters for an elliptical copula # ellipticalRange Returns the range of valid rho values # ellipticalCheck Checks if rho is in the valid range # FUNCTION: ELLIPTICAL GENERATOR AND RELATED FUNCTIONS: # gfunc Generator function for elliptical distributions # gfuncSlider Slider for generator, density and probability # .pelliptical Univariate elliptical distribution probability # .delliptical Univariate elliptical distribution density # .qelliptical Univariate elliptical distribution quantiles # .qlogistic Fast tabulated logistic quantile function # .qlogisticData Table generator for logistic quantiles # .qlogisticTable Table for logistic quantiles ################################################################################ ################################################################################ # UTILITY FUNCTIONS: # ellipticalParam Sets Default parameters for an elliptical copula # ellipticalList Returns list of implemented Elliptical copulae # ellipticalRange Returns the range of valid rho values # ellipticalCheck Checks if rho is in the valid range ellipticalList <- function() { # A function implemented by Diethelm Wuertz # Description: # Returns list of implemented elliptical copulae # Arguments: # FUNCTION: # Compose List: ans = c("norm", "cauchy", "t", "logistic", "laplace", "kotz", "epower") # Return Value: ans } # ------------------------------------------------------------------------------ ellipticalParam <- function(type = ellipticalList()) { # A function implemented by Diethelm Wuertz # Description: # Sets default parameters for elliptical copulae # Arguments: # type - a character string denoting the type of distribution. # This may be either # "norm" for the normal distribution, or # "cauchy" for the Cauchy distribution, or # "t" for the Student-t distribution, or # "logistic" for the logistic distribution, or # "laplace" for the distribution, or # "kotz" for the original Kotz distribution, or # "epower" for the exponential power distribution # Value: # returns a list with two elements, 'param' sets the parameters # which may be a vector, 'range' the range with minimum and # maximum values for each of the parameters. # Example: # ellipticalParam("norm"); ellipticalParam("t") # FUNCTION: # Settings: type = match.arg(type) # Parameter Values: # ("norm", "cauchy", "t", "logistic", "laplace", "kotz", "epower") lower = c( -1, -1, -1, -1, -1, -1, -1) upper = c( +1, +1, +1, +1, +1, +1, +1) rho = c(3/4, 3/4, 3/4, 3/4, 3/4, 3/4, 3/4) param1 = c( NA, NA, 4, NA, NA, 1, 1) param2 = c( NA, NA, NA, NA, NA, NA, 1) # Create Parameter List: ans = list(type = type) if (type == "norm") { ans$param = c(rho = rho[1]) ans$range = c(lower = lower[1], upper = upper[1]) } if (type == "cauchy") { ans$param = c(rho = rho[2]) ans$range = c(lower = lower[2], upper = upper[2]) } if (type == "t") { ans$param = c(rho = rho[3], nu = param1[3]) ans$range = c(lower = lower[3], upper = upper[3]) } if (type == "logistic") { ans$param = c(rho = rho[4]) ans$range = c(lower = lower[4], upper = upper[4]) } if (type == "laplace") { ans$param = c(rho = rho[5]) ans$range = c(lower = lower[5], upper = upper[5]) } if (type == "kotz") { ans$param = c(rho = rho[6], r = param1[6]) ans$range = c(lower = lower[6], upper = upper[6]) } if (type == "epower") { ans$param = c(rho = rho[7], r = param1[7], s = param2[7]) ans$range = c(lower = lower[7], upper = upper[7]) } # Return Value: ans } # ------------------------------------------------------------------------------ ellipticalRange <- function(type = ellipticalList()) { # A function implemented by Diethelm Wuertz # Description: # Returns the range of valid alpha values # Arguments: # type - a character string denoting the type of distribution. # This may be either # "norm" for the normal distribution, or # "cauchy" for the Cauchy distribution, or # "t" for the Student-t distribution, or # "logistic" for the logistic distribution, or # "laplace" for the distribution, or # "kotz" for the original Kotz distribution, or # "epower" for the exponential power distribution # Example: # ellipticalRange("norm"); ellipticalRange("t") # FUNCTION: # Type: type = match.arg(type) # Range: ans = ellipticalParam(type)$range attr(ans, "control") <- type # Return Value: ans } # ------------------------------------------------------------------------------ ellipticalCheck <- function(rho = 0.75, param = NULL, type = ellipticalList()) { # A function implemented by Diethelm Wuertz # Description: # Checks if alpha is in the valid range # Arguments: # rho - correlation coefficient # param - currently not used # type - a character string denoting the type of distribution. # This may be either # "norm" for the normal distribution, or # "cauchy" for the Cauchy distribution, or # "t" for the Student-t distribution, or # "logistic" for the logistic distribution, or # "laplace" for the distribution, or # "kotz" for the original Kotz distribution, or # "epower" for the exponential power distribution # Example: # ellipticalCheck(0.5, NULL, "norm") # ellipticalCheck(1.5, NULL, "t") # FUNCTION: # Type: type = match.arg(type) # Range: range = as.vector(ellipticalRange(type)) if (rho < range[1] | rho > range[2]) { print(c(rho = rho)) print(c(range = range)) stop("rho is out of range") } # Return Value: invisible() } ################################################################################ # FUNCTION: ELLIPTICAL GENERATOR AND RELATED FUNCTIONS: # gfunc Generator function for elliptical distributions # gfuncSlider Slider for generator, density and probability # .pelliptical Univariate elliptical distribution probability # .delliptical Univariate elliptical distribution density # .qelliptical Univariate elliptical distribution quantiles # .qlogistic Fast tabulated logistic quantile function # .qlogisticData Table generator for logistic quantiles # .qlogisticTable Table for logistic quantiles gfunc <- function(x, param = NULL, type = ellipticalList()) { # A function implemented by Diethelm Wuertz # Description: # Generator function for elliptical distributions # Arguments: # x - a numeric vector # param - NULL, a numeric value, or a numeric vector adding. # additional parameters to the generator function. # type - a character string denoting the type of distribution. # This may be either # "norm" for the normal distribution, or # "cauchy" for the Cauchy distribution, or # "t" for the Student-t distribution, or # "logistic" for the logistic distribution, or # "laplace" for the distribution, or # "kotz" for the original Kotz distribution, or # "epower" for the exponential power distribution # Value: # Returns a numeric vector "g(x)" for the generator computed at # the x values taken from the input vector. If x is missing, # the normalizing constant "lambda" will be returned. # FUNCTION: # Match Arguments: type = match.arg(type) # Handle Missing x: if (missing(x)) { x = NA output = "lambda" } else { output = "g" } # Get Type: type = type[1] # Get Parameters: # if (is.null(param)) param = ellipticalParam$param # Create Generator: if (type == "norm") { g = exp(-x/2) lambda = 1 / (2*pi) param = NULL } if (type == "cauchy") { g = ( 1 + x )^ (-3/2 ) lambda = 1 / (2*pi) param = NULL } if (type == "t") { if (is.null(param)) { nu = 4 } else { nu = param[[1]] } g = ( 1 + x/nu )^ ( -(nu+2)/2 ) lambda = 1/(2*pi) param = c(nu = nu) } if (type == "logistic"){ g = exp(-x/2)/(1+exp(-x/2))^2 # lambda: # integrate(function(x) { exp(-x)/(1+exp(-x))^2}, 0, Inf, # subdivision = 10000, rel.tol = .Machine$double.eps^0.8) # 0.5 with absolute error < 2.0e-13 lambda = 1 / pi param = NULL } if (type == "laplace") { # or "double exponential" # epower - with r = 1, s = 1 # g = exp(-r*(x/2)^s) # lambda = s * r^(1/s) / ( 2 * pi * gamma(1/s) ) g = exp(-sqrt(x)) lambda = 1/(2*pi) param = NULL } if (type == "kotz") { # epower - with s = 1 if (is.null(param)) { r = 1 } else { r = param } g = exp(-r*(x/2)) lambda = r/(2*pi) param = c(r = r) } if (type == "epower") { if (is.null(param)) { r = 1 s = 1 } else { r = param[[1]] s = param[[2]] } g = exp(-r*(x/2)^s) lambda = s * r^(1/s) / ( 2 * pi * gamma(1/s) ) param = c(r = r, s = s) } # Output: output = output[1] if (output == "g") { ans = g } else if (output == "lambda") { ans = lambda } # Add Control: if (output == "g") { attr(ans, "control") <- c(copula = "elliptical", type = type, lambda = as.character(lambda)) } else if (output == "lambda") { if (is.null(param)) { attr(ans, "control") <- unlist(list(copula = "elliptical", type = type)) } else { attr(ans, "control") <- unlist(list(copula = "elliptical", type = type, param = param)) } } # Return Value: ans } # ------------------------------------------------------------------------------ gfuncSlider <- function(B = 10) { # A function implemented by Diethelm Wuertz # Description: # Slider for generator function, density and probability # FUNCTION: # Graphic Frame: par(mfrow = c(2, 2), cex = 0.7) # Internal Function: refresh.code = function(...) { # Startup Counter: .counter <- setRmetricsOptions(".counter") + 1 setRmetricsOptions(.counter = .counter) if (.counter < 6) return () # Sliders: Copula = as.integer(.sliderMenu(no = 1)) type = ellipticalList() type = type[Copula] Type = c("Normal", "Cauchy", "Student-t", "Logistic", "Laplace", "Kotz", "Exponential Power") Type = Type[Copula] N = .sliderMenu(no = 2) nu = .sliderMenu(no = 3) r = .sliderMenu(no = 4) s = .sliderMenu(no = 5) rho = .sliderMenu(no = 6) L = 6.5 # Parameters: param = NULL if (Copula == 3) param = nu if (Copula == 6) param = r if (Copula == 7) param = c(r, s) prefactor = gfunc(param = param, type = type)[[1]] Lambda = as.character(round(prefactor, digits = 3)) Nu = R = S = NA if (Copula == 3) Nu = as.character(round(nu, digits = 1)) if (Copula >= 6) R = as.character(round(r, digits = 1)) if (Copula == 7) S = as.character(round(s, digits = 1)) delta = 10/N # Bivariate Density: x = y = seq(-4, 4, length = 101) D = delliptical2d(grid2d(x), rho = rho, param = param, type = type, output = "list") # Plot 1: Limit = "" if (Copula == 3 & nu == 1) Limit = "| [Cauchy]" if (Copula == 6 & r == 1) Limit = "| [Normal]" if (Copula == 7 & s == 1) Limit = "| [Kotz]" if (Copula == 7 & r == 1 & s == 1) Limit = "| [Normal]" lambda = gfunc(param = param, type = type) x = seq(0, L, length = N) y = gfunc(x, param = param, type = type) y.norm = gfunc(x, type = "norm") plot(x, y, type = "l", ylab = "g", ylim = c(0, 1)) abline(h = 0, lty = 3, col = "grey") lines(x, y.norm, lty = 3, col = "red") title(main = paste("Generator:", Type, Limit, "\nPre-Factor:", Lambda)) mtext("Dotted Curve: Normal Generator", side = 4, col = "grey", cex = 0.7) # Plot 2 - Density: x = seq(-L, L, length = N) y = .delliptical(x, param = param, type = type) y.norm = .delliptical(x, type = "norm") plot(x, y, type = "l", ylab = "Density", ylim = c(0, 0.65)) abline(h = 0, lty = 3, col = "grey") abline(v = 0, lty = 3, col = "grey") lines(x, y.norm, lty = 3, col = "red") Y = 2*integrate(.delliptical, 0, Inf, param = param, type = type)[[1]] Y = as.character(round(Y, 2)) .velliptical = function(x, param, type) x^2*.delliptical(x, param, type) V = 2*integrate(.delliptical, 0, Inf, param = param, type = type)[[1]] V = as.character(round(V, 2)) mtext(paste("Normalization Test:", Y, " | Variance Test:", V), side = 4, col = "grey", cex = 0.7) if (type == "t") { title(main = paste(Type, "Density\n nu =", Nu)) } else if (type == "kotz") { title(main = paste(Type, "Density\n r =", R)) } else if (type == "epower") { title(main = paste(Type, "Density\n r =", R, "s =", S)) } else { title(main = paste(Type, "Density\n ")) } # Plot 3 - Probability: x = seq(-L, L, length = N) y = .pelliptical(x, param = param, type = type) y.norm = .pelliptical(x, type = "norm") plot(x, y, type = "l", ylab = "Probability", ylim = c(0, 1)) abline(h = 0, lty = 3, col = "grey") abline(h = 1, lty = 3, col = "grey") abline(h = 0.5, lty = 3, col = "grey") lines(x, y.norm, lty = 3, col = "red") p95 = .qelliptical(0.95, param = param, type = type) P95 = as.character(round(p95, digits = 2)) abline(v = p95, lty = 3) abline(v = -p95, lty = 3) q95 = .pelliptical(p95, param = param, type = type) points(+p95, q95, pch = 19, cex = 0.5) points(-p95, 1-q95, pch = 19, cex = 0.5) mtext("Dots: Probability(Quantile(0.95)) Test", side = 4, col = "grey", cex = 0.7) Title = paste(Type, "Probability\n 95% =", P95) title(main = Title) # Plot 4 - Bivariate Density: contour(D, levels = c(0.001, 0.01, 0.025, 0.05, 0.1), xlab = "x", ylab = "y") title(main = paste("Bivariate Density\nrho = ", as.character(rho))) grid() # Reset Frame: par(mfrow = c(2, 2), cex = 0.7) } # Open Slider Menu: setRmetricsOptions(.counter = 0) .sliderMenu(refresh.code, names = c("Copula", "N", "3: nu", "6|7: r", "7: s", "rho"), minima = c( 1, 50, 1, 0.1, 0.1, -0.95), maxima = c( 7, 2000, B, B, B, 0.95), resolutions = c( 1, 50, 0.1, 0.1, 0.1, 0.05), starts = c( 1, 100, 4, 1, 1, 0.00)) } # ------------------------------------------------------------------------------ .pelliptical <- function(q, param = NULL, type = ellipticalList(), alternative = TRUE, subdivisions = 100) { # A function implemented by Diethelm Wuertz # Description: # Probability function for univariate elliptical distributions # Arguments: # q - a numeric vector # param - NULL, a numeric value, or a numeric vector adding. # additional parameters to the generator function. # type - a character string denoting the type of distribution. # This may be either # "norm" for the normal distribution, or # "cauchy" for the Cauchy distribution, or # "t" for the Student-t distribution, or # "logistic" for the logistic distribution, or # "laplace" for the distribution, or # "kotz" for the original Kotz distribution, or # "epower" for the exponential power distribution. # Details: # The probability is computed by integration using the generator # function. If an alternative faster algorithm is available, # this one is used by default. # FUNCTION: # Type: type = match.arg(type) # Alternative Available? if (type == "logistic") alternative = FALSE if (type == "laplace") alternative = FALSE if (type == "kotz") alternative = FALSE if (type == "epower") alternative = FALSE # Original Function: # Fq1 = function (x, Q, param, type) { # acos(abs(Q)/sqrt(x)) * gfunc(x, param, type) } # Transformed Function: u = exp(-x+Q^2) Fq2 = function (x, Q, param, type) { Q^2 * acos(sqrt(x))/x^2 * gfunc(Q^2/x, param, type) } # Add Default Parameters: if (is.null(param)) { if (type == "t") param = c(nu = 4) if (type == "kotz") param = c(r = 1) if (type == "epower") param = c(r = 1, s = 1) } # Probability: ans = NULL if (alternative) { ans = NA if (type[1] == "norm") ans = pnorm(q) if (type[1] == "cauchy") ans = pt(q, df = 1) # pcauchy(q) if (type[1] == "t") ans = pt(q, df = param[[1]]) if (type[1] == "kotz") ans = dnorm(q, sd = 1/sqrt(param[[1]])) } else { lambda = gfunc(param = param, type = type)[[1]] ans = NULL for ( Q in q ) { # More Precise Adaptive Rule: # p = lambda * integrate(Fq1, lower = Q^2, upper = Inf, Q = Q, # param = param, type = type, subdivisions = subdivisions)[[1]] p = lambda*integrate(Fq2, lower = .Machine$double.eps^0.5, upper = 1, Q = Q, param = param, type = type, stop.on.error = FALSE, subdivisions = subdivisions)[[1]] if (Q > 0) p = 1 - p if (abs(Q) < .Machine$double.eps^0.5) p = 0.5 ans = c(ans, p) } } # Return Value: ans } # ------------------------------------------------------------------------------ .delliptical <- function(x, param = NULL, type = ellipticalList(), alternative = TRUE, subdivisions = 100) { # A function implemented by Diethelm Wuertz # Description: # Density function for univariate elliptical distributions # Arguments: # x - a numeric vector # param - NULL, a numeric value, or a numeric vector adding. # additional parameters to the generator function. # type - a character string denoting the type of distribution. # This may be either # "norm" for the normal distribution, or # "cauchy" for the Cauchy distribution, or # "t" for the Student-t distribution, or # "logistic" for the logistic distribution, or # "laplace" for the distribution, or # "kotz" for the original Kotz distribution, or # "epower" for the exponential power distribution. # alternative - a logical flag. Should alternatively used a # faster algorithm if available? By default TRUE. # Details: # The density is computed by integration using the generator # function. If an alternative faster algorithm is available, # this one is used by default. # FUNCTION: # Type: type = match.arg(type) # Alternative Available? if (type == "logistic") alternative = FALSE if (type == "laplace") alternative = FALSE if (type == "kotz") alternative = FALSE if (type == "epower") alternative = FALSE # Original Function: # fq1 = function (x, Q, param, type) { # gfunc(x, param, type) / ( sqrt(x - Q^2) ) } # Transformed Function: log(x)^2 = x - Q^2 fq2 = function (x, Q, param, type) { 2 * gfunc(log(x)^2+Q^2, param, type) / x } # Add Default Parameters: if (is.null(param)) { if (type == "t") param = c(nu = 4) if (type == "kotz") param = c(r = 1) if (type == "epower") param = c(r = 1, s = 1) } # Normalizing constant lambda: lambda = gfunc(param = param, type = type)[[1]] # Density: ans = NULL if (alternative) { ans = NA if (type[1] == "norm") ans = dnorm(x) if (type[1] == "cauchy") ans = dt(x, df = 1) # dcauchy(x) if (type[1] == "t") ans = dt(x, df = param[[1]]) if (type[1] == "kotz") ans = dnorm(x, sd = 1/sqrt(param[[1]])) } else { lambda = gfunc(param = param, type = type)[[1]] ans = NULL for ( Q in x ) { # More Precise Adaptive Rule: # p = lambda*integrate(fq1, lower = Q^2, upper = Inf, Q = Q, # param = param, type = type)[[1]] p = lambda*integrate(fq2, lower = 0, upper = 1, Q = Q, param = param, type = type, stop.on.error = FALSE, subdivisions = subdivisions)[[1]] ans = c(ans, p) } } # Return Value: ans } # ------------------------------------------------------------------------------ .qelliptical <- function(p, param = NULL, type = ellipticalList(), alternative = TRUE) { # A function implemented by Diethelm Wuertz # Description: # Quantile function for univariate elliptical distributions # Arguments: # p - a numeric vector # param - NULL, a numeric value, or a numeric vector adding. # additional parameters to the generator function. # type - a character string denoting the type of distribution. # This may be either # "norm" for the normal distribution, or # "cauchy" for the Cauchy distribution, or # "t" for the Student-t distribution, or # "logistic" for the logistic distribution, or # "laplace" for the distribution, or # "kotz" for the original Kotz distribution, or # "epower" for the exponential power distribution. # alternative - a logical flag. Should be an alternative # faster algorithm used and not the standard algorithm? # Details: # The probability is computed by integration using the generator # function. If an alternative faster algorithm is available, # this one is used by default. # FUNCTION: # Type: type = match.arg(type) # Alternative Available? if (type == "laplace") alternative = FALSE if (type == "kotz") alternative = FALSE if (type == "epower") alternative = FALSE # Add Default Parameters: if (is.null(param)) { if (type == "t") param = c(nu = 4) if (type == "kotz") param = c(r = 1) if (type == "epower") param = c(r = 1, s = 1) } # Probability: ans = NULL if (alternative) { ans = NA if (type[1] == "norm") ans = qnorm(p) if (type[1] == "cauchy") ans = qcauchy(p) if (type[1] == "t") ans = qt(p, df = param[[1]]) if (type[1] == "logistic") ans = .qlogistic(p) if (type[1] == "kotz") ans = dnorm(p, sd = 1/sqrt(param[[1]])) } else { froot <- function(x, p, param, type) { .pelliptical(q = x, param = param, type = type) - p } ans = NULL for (pp in p) { if (pp < .Machine$double.eps) { ans = c(ans, -Inf) } else if (pp > 1 - .Machine$double.eps) { ans = c(ans, Inf) } else { lower = -1 upper = +1 counter = 0 iteration = NA while (is.na(iteration)) { iteration = .unirootNA(f = froot, interval = c(lower, upper), param = param, type = type, p = pp) counter = counter + 1 lower = lower - 2^counter upper = upper + 2^counter } ans = c(ans, iteration) } } } # Return Value: ans } # ------------------------------------------------------------------------------ .qlogistic <- function(p) { # A function implemented by Diethelm Wuertz # Description: # Fast Quantile function for the logistic distribution # FUNCTION: # Table: data = .qlogisticTable # Quantiles: P = (sign(p-1/2)+1)/2 - sign(p-1/2)*p ans = sign(0.5-p) * approx(x = data[, 2], y = data[, 1], xout = P)$y # p Boundary: index = which(p < 0.001 & p > 0) if (length(index) > 0) { ans[index] = .qelliptical(p[index], type = "logistic", alternative = FALSE) } index = which(p > 1-0.001 & p < 1) if (length(index) > 0) { ans[index] = .qelliptical(p[index], type = "logistic", alternative = FALSE) } ans[p == 0.5] = 0 ans[p == 0] = -Inf ans[p == 1] = Inf # Return Value: ans } # ------------------------------------------------------------------------------ .qlogisticData <- function (dump = FALSE ) { # A function implemented by Diethelm Wuertz # FUNCTION: # Range: p = seq(0.001, 0.500, by = 0.001) # Quantiles by Integration: froot = function(x, p) { .pelliptical(x, type = "logistic") - p } X = NULL for (P in p) { lower = -1 upper = +1 counter = 0 iteration = NA while (is.na(iteration)) { iteration = .unirootNA(f = froot, interval = c(lower, upper), p = P) counter = counter + 1 lower = lower - 2^counter upper = upper + 2^counter } X = c(X, iteration) } Y = .pelliptical(X, type = "logistic") .qlogisticTable = data.frame(cbind(X = X, Y = Y)) # Dump: if (dump) dump(".qlogisticTable", "qlogisticTable.R") # Return Value: invisible(.qlogisticTable) } # ------------------------------------------------------------------------------ .qlogisticTable <- structure(list( X = c( -3.28961095698868, -3.08838952917050, -2.96495324742154, -2.87441959067841, -2.80235793855428, -2.74216585623189, -2.69027685632636, -2.64454429353653, -2.60362855984489, -2.56644066721983, -2.53234562858188, -2.50082506289166, -2.47148229772502, -2.44400686160488, -2.41815107184679, -2.39371408491880, -2.37053072103299, -2.34846344243532, -2.32739647429067, -2.30723141378254, -2.28791218251300, -2.26930432832626, -2.25137887299253, -2.23407971956745, -2.21735785753918, -2.20116988800091, -2.18547719458243, -2.17024525936846, -2.15544310253510, -2.14104280951074, -2.12701913726668, -2.11334918152059, -2.1000120943421, -2.08698884326631, -2.07426200479765, -2.06181558657013, -2.04963487351506, -2.03770629424047, -2.02601730451810, -2.01455628530110, -2.00331245315227, -1.99227557959128, -1.98143672734491, -1.97078698069461, -1.96031819468915, -1.95002274531123, -1.93989348557452, -1.92992370611904, -1.92010709998667, -1.91043773071894, -1.90091000365456, -1.89151863995147, -1.88225865304357, -1.87312532726254, -1.86411419838938, -1.85522103592924, -1.84644182692950, -1.83777276118156, -1.82921021766652, -1.82074871277337, -1.81238487394136, -1.80411802330877, -1.79594515630526, -1.78786340687312, -1.77987003898311, -1.77196243800415, -1.76413810662673, -1.75639465334193, -1.74872978943490, -1.7412023575414, -1.73368818564377, -1.7262462929639, -1.71887474483312, -1.71157168326167, -1.70433532304102, -1.69716394791141, -1.69005590701564, -1.68300961157971, -1.67602353180290, -1.66909619394163, -1.66222617757269, -1.65541211302264, -1.64865267895148, -1.64194660007940, -1.63529264504669, -1.62868962439725, -1.62213638867753, -1.61563182664270, -1.60917486356300, -1.60276445962361, -1.59639952641875, -1.59007925325713, -1.58380261455573, -1.57756869582143, -1.57137660985193, -1.56522549889593, -1.55911452857102, -1.55304289016109, -1.54700979879211, -1.54101449249394, -1.53505623130807, -1.52915261112904, -1.52326458881694, -1.51741167285209, -1.5115931890518, -1.50580848264567, -1.50005691749585, -1.49433787536073, -1.48865075519602, -1.48299497249102, -1.47736995863785, -1.47177516036924, -1.46621003903524, -1.4606740702944, -1.4551667434371, -1.44968756093365, -1.4442360379646, -1.43881170197258, -1.43341409223487, -1.42804275945499, -1.42269726537273, -1.41737718239130, -1.41208209321679, -1.40681159053369, -1.40156527665306, -1.39634276321712, -1.39114367089538, -1.38596762909750, -1.38081427569799, -1.37568325677215, -1.37057422634254, -1.36548684613562, -1.36042078534799, -1.35537572042174, -1.35035133482848, -1.34534731886170, -1.34036336943694, -1.33539918989953, -1.33045448983943, -1.32552898491301, -1.32062239667119, -1.31573445239396, -1.31086488493075, -1.30601343254650, -1.30117983877317, -1.29636385226647, -1.29156522666752, -1.28678372046926, -1.28201909688745, -1.27727112373605, -1.27253957330672, -1.26782422225068, -1.26312485147296, -1.25844124601302, -1.25377319494646, -1.24912049128124, -1.24448293185896, -1.23986031725926, -1.23525245170728, -1.23065914298397, -1.22608020233923, -1.22151544440770, -1.21696225226631, -1.21242200176641, -1.20789558040343, -1.20338280567676, -1.19888349860929, -1.19439748365017, -1.18992458855333, -1.18546464439883, -1.18101748533607, -1.17658294861366, -1.17216087446918, -1.16775110605060, -1.16341452449662, -1.15902890823835, -1.15465514386589, -1.15029304960735, -1.14594255361642, -1.14160347928037, -1.13727568813146, -1.13295904407152, -1.12865341331407, -1.12435866432809, -1.12007466778373, -1.11580129649967, -1.11153842461814, -1.10728593065946, -1.10304369280653, -1.09881159197813, -1.09458951100203, -1.09037733457144, -1.08617494920272, -1.08198224319439, -1.07779910658730, -1.07362543112605, -1.06946111022151, -1.06528196623425, -1.06113353941502, -1.05699432071886, -1.05286419954172, -1.04874306739911, -1.04463081785862, -1.04058838163140, -1.0364935858852, -1.03240736512243, -1.02832962049820, -1.02426025492196, -1.02019917300514, -1.01614628101095, -1.01210148680617, -1.00806469981498, -1.00403583097456, -1.00001479269255, -0.995987692143912, -0.99198188126047, -0.987982882923126,-0.983990646036694,-0.980005119840238, -0.976026253905185,-0.972053998133449,-0.968088302755545,-0.964129118328723, -0.96023743089134, -0.956291121335992,-0.952351176345156,-0.948417547764324, -0.944491447079358,-0.940578633091236,-0.936672395329904,-0.932772667777382, -0.928879385227229,-0.924992483271505,-0.921111898287973,-0.917237567427541, -0.913369428601936,-0.909507420471605,-0.905651482433843,-0.901801554611138, -0.89795757783973, -0.894119493658381,-0.890287244297353,-0.886460772667583, -0.882640022350059,-0.878824937585387,-0.875015463263552,-0.871211544913856, -0.867413128695051,-0.863620161385636,-0.859832590374336,-0.856050363650754, -0.852273429796184,-0.848501737974597,-0.844735237923773,-0.840973879946612, -0.837217614902577,-0.833466394199305,-0.82972016978436, -0.825978894137128, -0.82224252026086, -0.81851100167485, -0.81478429240676, -0.81106234698506, -0.807345120431618,-0.803632568254409, -0.799924646440352, -0.796221311448274, -0.79252252020199, -0.788828230083503, -0.785138398926326, -0.781452985008911, -0.777771947048196,-0.774095244193254, -0.770422836019059, -0.766754682520353, -0.763090744605994,-0.759430982092061, -0.755775356696648, -0.752123830034272, -0.748476364110065,-0.744832921314231, -0.741193464432255, -0.737557956577102, -0.733926361277322,-0.730298642409806, -0.726674764210157, -0.723054691267668, -0.719438388520393,-0.715825821250292, -0.712216955078455, -0.708611755960407, -0.705010190181483,-0.701412224352282, -0.697817825404193, -0.69422696058499, -0.690639597454501,-0.687055703880342, -0.68347524803372, -0.679898198385306, -0.676324523701167,-0.672754193038763, -0.669187175743011, -0.665623441442406, -0.662062960045204,-0.658505701735664, -0.654951636970346, -0.651400736474472, -0.647852971238333,-0.644308312513762, -0.640766731810652, -0.637228200893533, -0.633692691778194,-0.630160176728364, -0.626630628252438, -0.623104019100251, -0.619580322259904,-0.616059510954638, -0.612541558639745, -0.60902643899954, -0.60551412594436, -0.602004593607625, -0.598497816342926, -0.594993768721168, -0.591492425527744,-0.587993761759759, -0.584497752623287, -0.581004373530672, -0.577513600097867,-0.574025408141805, -0.570539773677817, -0.567056672917079, -0.563576082264099,-0.560097978314237, -0.55662233785126, -0.553149137844933, -0.549678355448641,-0.546209967997043, -0.542743953003765, -0.539280288159113, -0.53581895132783, -0.532359920546873, -0.528903174023226, -0.525448690131743, -0.521996447413011,-0.518546424571258, -0.515098600472271, -0.511652954141354, -0.508209464761305,-0.504768111670429, -0.501328874360566, -0.497891732475152, -0.494456665807302,-0.491023654297919, -0.487592678033829, -0.484163717245933, -0.480736752307392,-0.477311763731828, -0.473888732171551, -0.470467638415803, -0.467048463389035,-0.463631188149193, -0.460215793886032, -0.45680226191945, -0.453390573697839,-0.449980710796464, -0.44657265491585, -0.443166387880198, -0.43976189163582, -0.436359148249581, -0.432958139907375, -0.429558848912609, -0.426161257684707,-0.422765348757635, -0.419371104778434, -0.415978508505784, -0.41258754280857, -0.409198190664474, -0.405810435158577, -0.402424259481984, -0.399039646930456,-0.395656580903062, -0.392275044900847, -0.388895022525509, -0.385516497478098,-0.382139453557724, -0.378763874660278, -0.375389744777172, -0.372017047994090,-0.368645768489747, -0.36527589053467, -0.361907398489987, -0.358540276806227,-0.355174510022136, -0.351810082763504, -0.348446979742001, -0.345085185754029,-0.341724685679586, -0.338365464481134, -0.335007507202486, -0.331650798967702,-0.328295324979995, -0.324941070520646, -0.321588020947929, -0.318236161696055,-0.314885478274112, -0.311535956265027, -0.308187581324529, -0.304840339180130,-0.301494152790354, -0.298149133027608, -0.294805203648722, -0.291462350657759,-0.28812056012555, -0.284779814605342, -0.281440107419829, -0.278101421295547,-0.274763742560770, -0.271427057605776, -0.268091352881914, -0.264756614900680,-0.261422830232804, -0.258089985507338, -0.254758067410761, -0.251427062686079,-0.248096958131943, -0.244767740601768, -0.241439397002857, -0.238111914295537,-0.234785279492298, -0.231459479656942, -0.228134501903726, -0.224810333396537,-0.221486961348039, -0.218164373018853, -0.214842555716734, -0.21152149679575, -0.208201183655463, -0.204881603740137, -0.201562744537922, -0.198244593580064,-0.194927138440111, -0.191610366733128, -0.188294266114916, -0.184978824281230,-0.181664028967013, -0.178349867945625, -0.175036329028080, -0.171723400062291,-0.168411068932309, -0.165099323557576, -0.161788151892181, -0.158477541924117,-0.15516748167454, -0.151857959197035, -0.148548962576890, -0.145240479930364,-0.141932499403962, -0.138625009173723, -0.135317997444490, -0.132011452449203,-0.128705362448187, -0.125399715728434, -0.122094500602899, -0.118789705409793,-0.115485318511868, -0.112181328295712, -0.108877723171037, -0.105574491569969, -0.102271621946344, -0.0989691027749957, -0.0956669225510829, -0.0923650697894468, -0.0890635330240574, -0.0857623008076265, -0.0824613617115197, -0.0791607043262014, -0.0758603172625963, -0.0725601891549516, -0.069260308666142, -0.0659606644967098, -0.0626612453993505, -0.0593620402006167, -0.0560630378306748, -0.0527642273584164, -0.0494655980205171, -0.0461671392155751, -0.0428688404062201, -0.0395706908379783, -0.0362726789608858, -0.0329747914456716, -0.0296770116896015, -0.0263793175678826, -0.0230816777192755, -0.0197840449696766, -0.0164872991738574, -0.0132014769537292, -0.0099153529555198, -0.00656807273015348,-0.00328316565264927, 0), Y = c(0.000999989790249075, 0.00199997659631066,0.0030000533744429, 0.00400032302535487, 0.00500028183011033,0.00600024440622486, 0.00700036400791461, 0.00800057651215374,0.00899926075702241, 0.00999936918645765, 0.0109994715833541,0.0119995614818643,0.0129996374478306,0.0139997002917028, 0.0149997517033347,0.0159997935471271,0.0169998275539801,0.0179998552300887, 0.0189998778128955,0.0199998963093886,0.0209984200243254,0.0219986195324741, 0.0229987985092580,0.0239989556602773,0.0249990929774641,0.0259992125331238, 0.0269993163154686,0.0279994063127642,0.028999484230876, 0.0299995516446606, 0.0309996099536415,0.0319996603894939,0.0329997040283535,0.033999741805388, 0.034999774530007, 0.0359998029007155,0.0369998275190071,0.0379998489022468, 0.0389998674948231,0.0399998836784007,0.0409998977807025,0.0419999100844623, 0.0429999208323128,0.0439999302262356,0.0449999384488791,0.0459999456542143, 0.0469999519731455,0.0479999575239014,0.0489999624033934,0.0499999666971179, 0.050999970479087, 0.0519999738134476,0.0529999767558638,0.0539999793547017, 0.0549999816520199,0.0559999836844612,0.0569999854839726,0.0579999870784435, 0.0589999884922518,0.0600002322660306,0.0610007382842464,0.0620012176556511, 0.0630016721028811,0.0640021032232844,0.0650025124989912,0.0660029014066227, 0.0670032710226466,0.0680036226385918,0.0690039573610388,0.0699961909442808, 0.0709964157890431,0.0719966272564782,0.0729968261635939,0.0739970132882051, 0.074997189351493, 0.075997355027219, 0.076997510945194, 0.0779976576944622, 0.0789977958262262,0.0799979258565364,0.0809980482687644,0.0819981635158824, 0.0829982720225615,0.0839983741871086,0.0849984703832535,0.0859985609618, 0.0869986462521522,0.0879987265637271,0.0889988021872626,0.0899988733960295, 0.0909989402880648,0.0919990034241728,0.0929990628713735,0.0939991188435381, 0.0949991716757273,0.0959992212888924,0.0969992679961586,0.0979993119655162, 0.0989993533551862,0.0999993923142102,0.100999428983003, 0.101996361340610, 0.102996667458178, 0.103996948294911, 0.104997205893694, 0.105997442136406, 0.106997658756622, 0.107997857350875, 0.108998039389096, 0.109998206224314, 0.110998359101641, 0.111998499159902, 0.112998627466711, 0.113998744983746, 0.114998852601866, 0.115998951139948, 0.116999041350541, 0.117999123925120, 0.118999199498883, 0.119999268655243, 0.120999331929934, 0.121999389814826, 0.122999442762193, 0.123999491184829, 0.124999535463806, 0.125999575947988, 0.126999612957384, 0.127999646785496, 0.12899967770146, 0.129999705952036, 0.13099973176343, 0.131999755342970, 0.132999776880658, 0.133999796550584, 0.134999814512239, 0.135999830911716, 0.136999845882814, 0.137999859548057, 0.138999872019624, 0.139999883400211, 0.140999893783817, 0.141999903256468, 0.142999911896882, 0.143999919777082, 0.144999926962952, 0.145999933514754, 0.146999939487602, 0.147999944931889, 0.148999949893692, 0.149999954415129, 0.150999958534699, 0.151999962287943, 0.152999965706274, 0.153999968819446, 0.154999971654293, 0.155999974235324, 0.156999976584922, 0.157999978723527, 0.158999980669799, 0.159999982440775, 0.160999984052003, 0.161999985517674, 0.163000522714305, 0.164001257335553, 0.165001955709628, 0.166002619635127, 0.167003250824463, 0.168003850907805, 0.169004421443053, 0.170004963894409, 0.171005479673739, 0.17200597011836, 0.173006436500641, 0.174006880031024, 0.174993398219765, 0.175993761862996, 0.176994106194154, 0.177994440428791, 0.178994740610310, 0.179995032746045, 0.180995309240802, 0.181995570901728, 0.182995818495872, 0.183996052752091, 0.184996274362880, 0.185996483986112, 0.186996682428530, 0.187996869918613, 0.188997047203267, 0.189997214817756, 0.190997373270305, 0.191997523043414, 0.192997664595105, 0.193997798360121, 0.194997924751063, 0.195998044159472, 0.196998156956866, 0.198004064106562, 0.199004781577514, 0.200005456363768, 0.201006090989097, 0.202006687834809, 0.203007249147298, 0.203992879823315, 0.204993345345794, 0.205993781542165, 0.20699419018612, 0.207994572949000, 0.208994931405369, 0.209995267038304, 0.210995581244424, 0.211995875338658, 0.212996150558767, 0.213996408069636, 0.215000093310879, 0.216000369275620, 0.217000821976959, 0.218001445611404, 0.219002234487624, 0.220003183024853, 0.221004285751305, 0.222005537302608, 0.223006932420246, 0.223992987554550, 0.22499462733946, 0.225996395713614, 0.226998287825741, 0.227999977350380, 0.228999972825903, 0.229999967831223, 0.230999962364020, 0.231999956424305, 0.232999950014237, 0.233999943137955, 0.234999935801416, 0.235999928012238, 0.236999919779558, 0.237999911113890, 0.238999902026997, 0.23999989253177, 0.240999882642106, 0.241999872372804, 0.242999861739457, 0.243999850758354, 0.244999839446394, 0.245999827820992, 0.246999815900002, 0.247999803701641, 0.248999791244413, 0.249999778547048, 0.250999765628433, 0.251999752507560, 0.252999739203466, 0.253999725735183, 0.254999712121693, 0.255999698381881, 0.256999684534495, 0.257999670598112, 0.258999656591096, 0.259999642531572, 0.260999628437393, 0.261999614326116, 0.262999600214975, 0.263999586120861, 0.264999572060296, 0.265999558049426, 0.266999544103992, 0.267999530239325, 0.268999516470329, 0.269999502811470, 0.270999489276768, 0.271999475879788, 0.272999462633633, 0.273999449550939, 0.274999436643870, 0.275999423928137, 0.276999411406967, 0.277999399095057, 0.278999387002665, 0.279999375139568, 0.280999363515069, 0.281999352133693, 0.282999341012350, 0.283999330154682, 0.284999319568118, 0.285999309259627, 0.286999299235725, 0.287999289502482, 0.288999280065525, 0.289999270930049, 0.290999262100821, 0.291999253582187, 0.292999245378082, 0.293999237492035, 0.294999229927180, 0.295999222686262, 0.296999215771647, 0.297999209185332, 0.298999202928950, 0.299999197003782, 0.300999191410765, 0.301999186150503, 0.302999181223271, 0.303999176629033, 0.304999172367443, 0.305999168437859, 0.306999164839350, 0.307999161570707, 0.308999158630451, 0.309999156016846, 0.3109991537279, 0.311999151761384, 0.312999150114833, 0.313999148785561, 0.314999147770665, 0.315999147067038, 0.316999146671377, 0.317999146580187, 0.318999146789796, 0.319999147296359, 0.320999148095870, 0.321999149184165, 0.322999150556936, 0.323999152209734, 0.324999154137979, 0.325999156336969, 0.326999158801883, 0.327999161527793, 0.328999164509669, 0.329999167742386, 0.330999171220733, 0.331999174939416, 0.332999178893067, 0.333999183076251, 0.334999187483469, 0.335999192109171, 0.336999196947752, 0.337999201993567, 0.338999207240932, 0.33999921268413, 0.340999218317417, 0.341999224135028, 0.342999230131179, 0.343999236300076, 0.344999242635916, 0.345999249132897, 0.346999255785214, 0.347999262587073, 0.348999269532686, 0.349999276616284, 0.350999283832112, 0.351999291174441, 0.352999298637566, 0.353999306215812, 0.354999313903537, 0.355999321695133, 0.356999329585035, 0.357999337567717, 0.3589993456377, 0.359999353789552, 0.360999362017892, 0.361999370317391, 0.362999378682777, 0.363999387108836, 0.364999395590413, 0.365999404122415, 0.366999412699814, 0.367999421317649, 0.368999429971024, 0.369999438655116, 0.37099944736517, 0.371999456096506, 0.372999464844517, 0.373999473604672, 0.374999482372517, 0.375999491143676, 0.376999499913850, 0.377999508678821, 0.378999517434455, 0.379999526176695, 0.380999534901569, 0.381999543605189, 0.382999552283749, 0.383999560933529, 0.384999569550893, 0.38599957813229, 0.386999586674258, 0.387999595173416, 0.388999603626474, 0.389999612030226, 0.390999620381554, 0.391999628677426, 0.392999636914899, 0.393999645091113, 0.394999653203298, 0.395999661248771, 0.396999669224934, 0.397999677129276, 0.398999684959373, 0.399999692712886, 0.400999700387563, 0.401999707981236, 0.402999715491823, 0.403999722917325, 0.40499973025583, 0.405999737505508, 0.406999744664612, 0.407999751731479, 0.408999757699432, 0.409999764564645, 0.410999771332861, 0.411999778002731, 0.412999784572988, 0.413999792115251, 0.414999798496769, 0.415999804775648, 0.416999810950938, 0.417999817021771, 0.41899982298735, 0.419999828846956, 0.420999834599940, 0.421999840245729, 0.422999845783821, 0.423999851213786, 0.424999856535265, 0.425999861747966, 0.42699986685167, 0.427999871846223, 0.428999876731538, 0.429999881507595, 0.43099988617444, 0.431999890732181, 0.432999895180991, 0.433999899521106, 0.434999903752824, 0.435999907876499, 0.436999911892552, 0.437999915801457, 0.438999919603749, 0.439999923300017, 0.440999926890908, 0.441999930377125, 0.442999933759421, 0.443999937038606, 0.444999940215541, 0.445999943291138, 0.446999946266358, 0.447999949142211, 0.448999951919758, 0.449999954600106, 0.450999957184407, 0.45199995967386, 0.452999962069707, 0.453999964373235, 0.454999966585772, 0.455999968708689, 0.456999970743396, 0.457999972691344, 0.458999974554023, 0.45999997633296, 0.460999978029718, 0.461999979645896, 0.462999981183131, 0.46399998264309, 0.464999984027476, 0.465999985338022, 0.466999986576494, 0.467999987744687, 0.468999988844425, 0.469999989877562, 0.470999990845976, 0.471999991751573, 0.472999992596279, 0.473999993382044, 0.474999994110834, 0.47599999478463, 0.476999995405422, 0.477999995975202, 0.478999996495962, 0.479999996969683, 0.480999997398343, 0.481999997783931, 0.48299999812849, 0.483999998434203, 0.484999998703553, 0.485999998939509, 0.486999999145696, 0.487999999326349, 0.488999999485856, 0.489999999628004, 0.490999999755448, 0.49199999986999, 0.492999999973083, 0.494000000064158, 0.494999711104453, 0.495996057848887, 0.496992418350526, 0.49800732088262, 0.499003719695633, 0.499999999819624)), .Names = c("X", "Y"), row.names = c("1", "2", "3", "4", "5", "6", "7", "8", "9", "10", "11", "12", "13", "14", "15", "16", "17", "18", "19", "20", "21", "22", "23", "24", "25", "26", "27", "28", "29", "30", "31", "32", "33", "34", "35", "36", "37", "38", "39", "40", "41", "42", "43", "44", "45", "46", "47", "48", "49", "50", "51", "52", "53", "54", "55", "56", "57", "58", "59", "60", "61", "62", "63", "64", "65", "66", "67", "68", "69", "70", "71", "72", "73", "74", "75", "76", "77", "78", "79", "80", "81", "82", "83", "84", "85", "86", "87", "88", "89", "90", "91", "92", "93", "94", "95", "96", "97", "98", "99", "100", "101", "102", "103", "104", "105", "106", "107", "108", "109", "110", "111", "112", "113", "114", "115", "116", "117", "118", "119", "120", "121", "122", "123", "124", "125", "126", "127", "128", "129", "130", "131", "132", "133", "134", "135", "136", "137", "138", "139", "140", "141", "142", "143", "144", "145", "146", "147", "148", "149", "150", "151", "152", "153", "154", "155", "156", "157", "158", "159", "160", "161", "162", "163", "164", "165", "166", "167", "168", "169", "170", "171", "172", "173", "174", "175", "176", "177", "178", "179", "180", "181", "182", "183", "184", "185", "186", "187", "188", "189", "190", "191", "192", "193", "194", "195", "196", "197", "198", "199", "200", "201", "202", "203", "204", "205", "206", "207", "208", "209", "210", "211", "212", "213", "214", "215", "216", "217", "218", "219", "220", "221", "222", "223", "224", "225", "226", "227", "228", "229", "230", "231", "232", "233", "234", "235", "236", "237", "238", "239", "240", "241", "242", "243", "244", "245", "246", "247", "248", "249", "250", "251", "252", "253", "254", "255", "256", "257", "258", "259", "260", "261", "262", "263", "264", "265", "266", "267", "268", "269", "270", "271", "272", "273", "274", "275", "276", "277", "278", "279", "280", "281", "282", "283", "284", "285", "286", "287", "288", "289", "290", "291", "292", "293", "294", "295", "296", "297", "298", "299", "300", "301", "302", "303", "304", "305", "306", "307", "308", "309", "310", "311", "312", "313", "314", "315", "316", "317", "318", "319", "320", "321", "322", "323", "324", "325", "326", "327", "328", "329", "330", "331", "332", "333", "334", "335", "336", "337", "338", "339", "340", "341", "342", "343", "344", "345", "346", "347", "348", "349", "350", "351", "352", "353", "354", "355", "356", "357", "358", "359", "360", "361", "362", "363", "364", "365", "366", "367", "368", "369", "370", "371", "372", "373", "374", "375", "376", "377", "378", "379", "380", "381", "382", "383", "384", "385", "386", "387", "388", "389", "390", "391", "392", "393", "394", "395", "396", "397", "398", "399", "400", "401", "402", "403", "404", "405", "406", "407", "408", "409", "410", "411", "412", "413", "414", "415", "416", "417", "418", "419", "420", "421", "422", "423", "424", "425", "426", "427", "428", "429", "430", "431", "432", "433", "434", "435", "436", "437", "438", "439", "440", "441", "442", "443", "444", "445", "446", "447", "448", "449", "450", "451", "452", "453", "454", "455", "456", "457", "458", "459", "460", "461", "462", "463", "464", "465", "466", "467", "468", "469", "470", "471", "472", "473", "474", "475", "476", "477", "478", "479", "480", "481", "482", "483", "484", "485", "486", "487", "488", "489", "490", "491", "492", "493", "494", "495", "496", "497", "498", "499", "500"), class = "data.frame" ) ################################################################################ fCopulae/R/zzz.R0000644000176200001440000000340714265245633013207 0ustar liggesusers # 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 ############################################################################### .onAttach <- function(libname, pkgname) { # do whatever needs to be done when the package is loaded # some people use it to bombard users with # messages using # packageStartupMessage( "\n" ) # packageStartupMessage( "Rmetrics Package fCopulae" ) # packageStartupMessage( "Modeling Copulae" ) # packageStartupMessage( "Copyright (C) 2005-2014 Rmetrics Association Zurich" ) # packageStartupMessage( "Educational Software for Financial Engineering and Computational Science" ) # packageStartupMessage( "Rmetrics is free software and comes with ABSOLUTELY NO WARRANTY." ) # packageStartupMessage( "https://www.rmetrics.org --- Mail to: info@rmetrics.org" ) } ############################################################################### .onLoad <- function(libname, pkgname) { timeDate::setRmetricsOptions(.counter = NA) } ################################################################################ fCopulae/R/aaaCopulaeEnv.R0000644000176200001440000000275014265245633015056 0ustar liggesusers # 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 ############################################################################### .fCopulaeEnv <- new.env(hash = TRUE) .setfCopulaeEnv <- 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 = .fCopulaeEnv)) invisible() } .getfCopulaeEnv <- function(x = NULL, unset = "") { if (is.null(x)) x <- ls(all.names = TRUE, envir = .fCopulaeEnv) ### unlist(mget(x, envir = .fCopulaeEnv, mode = "any", ### ifnotfound = as.list(unset)), recursive = FALSE) get(x, envir = .fCopulaeEnv, mode = "any") } ############################################################################### fCopulae/R/ArchimedeanCopulae.R0000644000176200001440000007346714354775353016106 0ustar liggesusers # 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: ARCHIMEDEAN COPULAE RANDOM VARIATES: # rarchmCopula Generates Archimedean copula random variates # .rNo1Copula Generates rv's for copulae No 1 # .rNo2Copula Generates rv's for copulae No 2 # FUNCTION: ARCHIMEDEAN COPULAE PROBABILITY: # parchmCopula Computes Archimedean copula probability # .parchm1Copula Utility Function # .parchm2Copula Utility Function # FUNCTION: ARCHIMEDEAN COPULAE DENSITY: # darchmCopula Computes Archimedean copula density # .darchm1Copula Utility Function # .darchm2Copula Utility Function # FUNCTION: SPECIAL BIVARIATE COPULA: # rgumbelCopula Generates fast gumbel random variates # pgumbelCopula Computes bivariate Gumbel copula probability # dgumbelCopula Computes bivariate Gumbel copula density ################################################################################ ################################################################################ rarchmCopula <- function(n, alpha = NULL, type = archmList()) { # A function implemented by Diethelm Wuertz # Description: # Generates Archimedean copula random variate # FUNCTION: # Type: type = match.arg(type) Type = as.integer(type) # Alpha: if (is.null(alpha)) alpha = archmParam(type)$param # Check alpha: check = archmCheck(alpha, type) if (Type == 1) { # Use faster Algorithm: ans = .rNo1Copula(n, alpha) } else { # Generate rv's for the remaining Copulae: X = runif(n) Y = runif(n) t = .invK(Y, alpha, type) U = .invPhi(X*.Phi(t, alpha, type), alpha, type) V = .invPhi((1-X)*.Phi(t, alpha, type), alpha, type) ans = cbind(U, V) # Add Control Attribute: colnames(ans) = NULL } # Add Control List: control = list(alpha = alpha[[1]], copula = "archm", type = type) attr(ans, "control")<-unlist(control) # Return Value: ans } # ------------------------------------------------------------------------------ .rNo1Copula <- function(n, alpha = NULL, alternative = FALSE, doplot = FALSE) { # A function implemented by Diethelm Wuertz # Description: # Generates rv's for copula No 1 # Default Parameter: if (is.null(alpha)) alpha = archmParam(1)$param # Clayton Random Variate: if (alternative) { # Source: aas04.pdf X = rgamma(n, 1/alpha) V1 = runif(n) U = (1-log(V1)/X)^(-1/alpha) V2 = runif(n) V = (1-log(V2)/X)^(-1/alpha) ans = cbind(U, V) } else { # Source: armstrong03.pdf U = runif(n) W = runif(n) # W = C(V|U) => V = ( W^(-alpha/(alpha+1)) * U^(-alpha) - U^(-alpha) + 1 )^(-1/alpha) ans = cbind(U, V) } # Optional Plot: if (doplot) { plot(U, V, cex = 0.25, main = "Copula No. 1") } # Add Attribute: colnames(ans) = NULL control = list(alpha = alpha[[1]], copula = "archm", type = "1") attr(ans, "control")<-unlist(control) # Return Value: ans } # ------------------------------------------------------------------------------ .rNo2Copula <- function(n, alpha = NULL, doplot = FALSE) { # A function implemented by Diethelm Wuertz # HERE IS SOMETHING WRONG !!!! # Description: # Generates rv's for copula No 2 # Source: armstrong03.pdf # Default Parameter: if (is.null(alpha)) alpha = archmParam(2)$param # Random Variates: U = runif(n) W = runif(n) # W = C(V|U) => V = 1 - ( (1-U)^alpha * (W^(alpha/(1-alpha)) - 1 ) + 1 ) ^ (1/alpha) ans = cbind(U, V) # Optional Plot: if (doplot) { plot(U, V, cex = 0.25, main = "Copula No. 2") } # Add Attribute: colnames(ans) = NULL control = list(alpha = alpha[[1]], copula = "archm", type = "2") attr(ans, "control")<-unlist(control) # Return Value: ans } ################################################################################ parchmCopula <- function(u = 0.5, v = u, alpha = NULL, type = archmList(), output = c("vector", "list"), alternative = FALSE ) { # A function implemented by Diethelm Wuertz # Description: # Computes extreme value copula probability # Arguments: # u, v - two numeric values or vectors of the same length at # which the copula will be computed. If 'u' is a list then the # the '$x' and '$y' elements will be used as 'u' and 'v'. # If 'u' is a two column matrix then the first column will # be used as 'u' and the the second as 'v'. # alpha - a numeric value or vector of named parameters as # required by the copula specified by the variable 'type'. # If set to NULL, then the parameters will be taken as # specified by the function 'eparchParam'. # type - the type of the Archimedean copula. An integer or character # string selected from: "1", ..., "22". # output - a character string specifying how the output should # be formatted. By default a vector of the same length as # 'u' and 'v'. If specified as "list" then 'u' and 'v' are # expected to span a two-dimensional grid as outputted by the # function 'grid2d' and the function returns a list with # elements '$x', 'y', and 'z' which can be directly used # for example by 2D plotting functions. # alternative - Should the probability be computed alternatively # in a direct way from the probability formula or by default # via the dependency function? # Value: # returns a vector or list of probabilities depending on the # value of the "output" variable. # Example: # Diagonal Value: parchmCopula((0:10)/10) # persp(parchmCopula(u = grid2d(), output = "list")) # FUNCTION: # Copula: if (alternative) { ans <- .parchm2Copula(u, v, alpha, type, output) } else { ans <- .parchm1Copula(u, v, alpha, type, output) } # Return Value: ans } # ------------------------------------------------------------------------------ .parchm1Copula <- function(u = 0.5, v = u, alpha = NULL, type = archmList(), output = c("vector", "list") ) { # A function implemented by Diethelm Wuertz # Description: # Compute Maximum Extreme Value Copulae # Arguments: # see function: parchmCopula # Example: # Diagonal Value: .parchm1Copula((0:10)/10) # persp(.parchm1Copula(u = grid2d(), output = "list")) # FUNCTION: # Match Arguments: output = match.arg(output) # Type: type = match.arg(type) Type = as.integer(type) # Settings: if (is.null(alpha)) { alpha = archmParam(type)$param } if (is.list(u)) { v = u[[2]] u = u[[1]] } if (is.matrix(u)) { v = u[,1] u = u[,2] } # Consider Special Copulae: if (alpha == 0 & Type == 1) { C.uv = pfrechetCopula(u, v, type = "pi") } else if (alpha == 1 & Type == 3) { C.uv = pfrechetCopula(u, v, type = "psp") } else if (alpha == 0 & Type == 7) { C.uv = pfrechetCopula(u, v, type = "w") } else if (alpha == 1 & Type == 7) { C.uv = pfrechetCopula(u, v, type = "pi") } else if (alpha == 0 & Type == 9) { C.uv = pfrechetCopula(u, v, type = "pi") } else if (alpha == 0 & Type == 10) { C.uv = pfrechetCopula(u, v, type = "pi") } else if (alpha == 0 & Type == 11) { C.uv = pfrechetCopula(u, v, type = "pi") } else if (alpha == 1 & Type == 13) { C.uv = pfrechetCopula(u, v, type = "pi") } else if (alpha == 0 & Type == 19) { C.uv = pfrechetCopula(u, v, type = "psp") } else if (alpha == 0 & Type == 20) { C.uv = pfrechetCopula(u, v, type = "pi") } else if (alpha == 1 & Type == 21) { C.uv = pfrechetCopula(u, v, type = "w") } else if (alpha == 0 & Type == 22) { C.uv = pfrechetCopula(u, v, type = "pi") } else { C.uv = .invPhi(.Phi(u, alpha, type) + .Phi(v, alpha, type), alpha, type) } # Require special attention for No. 20: if (type == "20") { C.uv = C.uv + (1-sign(C.uv)) * pfrechetCopula(u, v, type = "m") } # Simulate max function: C.uv = (C.uv + abs(C.uv))/2 # Correct C(u,v) on Boundary of Unit Square: C.uv[is.na(C.uv)] = 0 C.uv[which(u == 0)] = 0 C.uv[which(u == 1)] = v[which(u == 1)] C.uv[which(v == 0)] = 0 C.uv[which(v == 1)] = u[which(v == 1)] C.uv[which(u*v == 1)] = 1 C.uv[which(u+v == 0)] = 0 # Add Control Attribute: control = list(alpha = alpha[[1]], copula = "archm", type = type) attr(C.uv, "control")<-unlist(control) # As List ? if (output == "list") { N = sqrt(length(u)) x = u[1:N] y = matrix(v, ncol = N)[1, ] C.uv = list(x = x, y = y, z = matrix(C.uv, ncol = N)) } # Return Value: C.uv } # ------------------------------------------------------------------------------ .parchm2Copula <- function(u = 0.5, v = u, alpha = NULL, type = archmList(), output = c("vector", "list") ) { # A function implemented by Diethelm Wuertz # Description: # Arguments: # see function: parchmCopula # Example: # Diagonal Value: .parchm2Copula((0:10)/10) # persp(.parchm2Copula(u = grid2d(), output = "list")) # FUNCTION: # Match Arguments: output = match.arg(output) # Type: type = match.arg(type) Type = as.integer(type) # Settings: if (is.null(alpha)) { alpha = archmParam(type)$param } if (is.list(u)) { v = u[[2]] u = u[[1]] } if (is.matrix(u)) { v = u[, 1] u = u[, 2] } # Consider Special Copulae: if (alpha == 0 & Type == 1) { C.uv = pfrechetCopula(u, v, type = "pi") } else if (alpha == 1 & Type == 3) { C.uv = pfrechetCopula(u, v, type = "psp") } else if (alpha == 0 & Type == 7) { C.uv = pfrechetCopula(u, v, type = "w") } else if (alpha == 1 & Type == 7) { C.uv = pfrechetCopula(u, v, type = "pi") } else if (alpha == 0 & Type == 9) { C.uv = pfrechetCopula(u, v, type = "pi") } else if (alpha == 0 & Type == 10) { C.uv = pfrechetCopula(u, v, type = "pi") } else if (alpha == 0 & Type == 11) { C.uv = pfrechetCopula(u, v, type = "pi") } else if (alpha == 1 & Type == 13) { C.uv = pfrechetCopula(u, v, type = "pi") } else if (alpha == 0 & Type == 19) { C.uv = pfrechetCopula(u, v, type = "psp") } else if (alpha == 0 & Type == 20) { C.uv = pfrechetCopula(u, v, type = "pi") } else { if (Type == 1) {# Clayton Copula C.uv = (u^(-alpha)+v^(-alpha)-1)^(-1/alpha) } if (Type == 2) { X = 1-((1-u)^alpha+(1-v)^alpha)^(1/alpha) Y = rep(0, times = length(X)) C.uv = apply(cbind(X, Y), 1, max) } if (Type == 3) { C.uv = u*v/(1-alpha*(1-u)*(1-v)) } if (Type == 4) { # Gumbel Copula C.uv = exp( -((-log(u))^(alpha)+(-log(v))^(alpha))^(1/alpha)) } if (Type == 5) { # Frank Copula C.uv = -1/alpha*log(1+(exp(-alpha*u)-1)* (exp(-alpha*v)-1)/(exp(-alpha)-1)) } if (Type == 6) { C.uv = 1-((1-u)^alpha+(1-v)^alpha-(1-u)^alpha* (1-v)^alpha)^(1/alpha) } if (Type == 7) { X = alpha*u*v+(1-alpha)*(u+v-1) Y = rep(0, times = length(X)) C.uv = apply(cbind(X, Y), 1, max) } if (Type == 8) { X = (alpha^2*u*v-(1-u)*(1-v))/(alpha^2-(alpha-1)^2*(1-u)*(1-v)) Y = rep(0, times = length(X)) C.uv = apply(cbind(X, Y), 1, max) } if (Type == 9) { C.uv = u*v*exp(-alpha*log(u)*log(v)) } if (Type == 10) { C.uv = u*v/(1+(1-u^alpha)*(1-v^alpha))^(1/alpha) } if (Type == 11) { X = (u^alpha*v^alpha-2*(1-u^alpha)*(1-v^alpha))^(1/alpha) Y = rep(0, times = length(X)) C.uv = apply(cbind(X, Y), 1, max) } if (Type == 12) { C.uv = (1+((u^(-1)-1)^alpha+(v^(-1)-1)^alpha)^(1/alpha))^(-1) } if (Type == 13) { C.uv = exp(1-((1-log(u))^alpha+(1-log(v))^alpha-1)^(1/alpha)) } if (Type == 14) { C.uv = (1+((u^(-1/alpha)-1)^alpha + (v^(-1/alpha)-1)^alpha)^(1/alpha))^(-alpha) } if (Type == 15) { X = (1-((1-u^(1/alpha))^alpha + (1-v^(1/alpha))^alpha )^(1/alpha) )^alpha Y = rep(0, times = length(X)) C.uv = apply(cbind(X, Y), 1, max) } if (Type == 16) { C.uv = 1/2*((u+v-1-alpha*(1/u+1/v-1))+ sqrt((u+v-1-alpha*(1/u+1/v-1))^2+4*alpha)) } if (Type == 17) { C.uv = (1+((1+u)^(-alpha)-1)* ((1+v)^(-alpha)-1)/(2^(-alpha)-1))^(-1/alpha)-1 } if (Type == 18) { eps = 1/10^8 u = u - eps*(1-sign(1-u)) v = v - eps*(1-sign(1-v)) X = 1+alpha/log(exp(alpha/(u-1))+exp(alpha/(v-1))) Y = rep(0, times = length(X)) C.uv = apply(cbind(X, Y), 1, max) } if (Type == 19) { C.uv = alpha/log(exp(alpha/u)+exp(alpha/v)-exp(alpha)) } if (Type == 20) { a.range = "(0, Inf)" C.uv = (log(exp(1/u^alpha)+exp(1/v^alpha)-exp(1)))^(-1/alpha) C.uv = C.uv + (1-sign(C.uv)) * pfrechetCopula(u, v, type = "m") } if (Type == 21) { # NOT YET IMPLEMENTED warning("No. 21 alternative not active") C.uv = NA # USE: C.uv = .parchm1Copula(u = u, v = v, alpha = alpha, type = type, output = output ) return(C.uv) } if (Type == 22) { # NOT YET IMPLEMENTED warning("No. 22 alternative not active") C.uv = NA # USE: C.uv = .parchm1Copula(u = u, v = v, alpha = alpha, type = type, output = output ) return(C.uv) } } # Simulate max function: C.uv = (C.uv + abs(C.uv))/2 # Correct C(u,v) on Boundary of Unit Square: C.uv[is.na(C.uv)] = 0 C.uv[which(u == 0)] = 0 C.uv[which(u == 1)] = v[which(u == 1)] C.uv[which(v == 0)] = 0 C.uv[which(v == 1)] = u[which(v == 1)] C.uv[which(u*v == 1)] = 1 C.uv[which(u+v == 0)] = 0 # Add Control Attribute: control = list(alpha = alpha[[1]], copula = "archm", type = type) attr(C.uv, "control")<-unlist(control) # As List ? if (output == "list") { N = sqrt(length(u)) x = u[1:N] y = matrix(v, ncol = N)[1, ] C.uv = list(x = x, y = y, z = matrix(C.uv, ncol = N)) } # Return Value: C.uv } ################################################################################ darchmCopula <- function(u = 0.5, v = u, alpha = NULL, type = archmList(), output = c("vector", "list"), alternative = FALSE ) { # A function implemented by Diethelm Wuertz # Description: # Computes extreme value copula density # Arguments: # u, v - two numeric values or vectors of the same length at # which the copula will be computed. If 'u' is a list then the # the '$x' and '$y' elements will be used as 'u' and 'v'. # If 'u' is a two column matrix then the first column will # be used as 'u' and the the second as 'v'. # alpha - a numeric value or vector of named parameters as # required by the copula specified by the variable 'type'. # If set to NULL, then the parameters will be taken as # specified by the function 'archmParam'. # type - the type of the Archimedean copula. An integer or character # string selected from: "1", ..., "22". # output - a character string specifying how the output should # be formatted. By default a vector of the same length as # 'u' and 'v'. If specified as "list" then 'u' and 'v' are # expected to span a two-dimensional grid as outputted by the # function 'grid2d' and the function returns a list with # elements '$x', 'y', and 'z' which can be directly used # for example by 2D plotting functions. # alternative - Should the probability be computed alternatively # in a direct way from the probability formula or by default # via the dependency function? # Value: # returns a vector or list of probabilities depending on the # value of the "output" variable. # Example: # Diagonal Value: darchmCopula((0:10)/10) # persp(darchmCopula(u=grid2d(), output="list"), theta=-40, phi=30, xlab="x") # FUNCTION: # Copula: if (alternative) { ans = .darchm2Copula(u, v, alpha, type, output) } else { ans = .darchm1Copula(u, v, alpha, type, output) } # Return Value: ans } # ------------------------------------------------------------------------------ .darchm1Copula = function(u = 0.5, v = u, alpha = NULL, type = archmList(), output = c("vector", "list")) { # A function implemented by Diethelm Wuertz # Description: # Computes Density of Maximum Extreme Value Copulae # References: # Nelsen # Matteis, Diploma Thesis # Carmona, Evanesce # FUNCTION: # Match Arguments: output = match.arg(output) # Type: type = match.arg(type) Type = as.integer(type) # Settings: if (is.null(alpha)) { alpha = archmParam(type)$param } if (is.list(u)) { v = u[[2]] u = u[[1]] } if (is.matrix(u)) { v = u[, 1] u = u[, 2] } # Density: c.uv = .invPhiSecondDer( .Phi(u, alpha, type) + .Phi(v, alpha, type), alpha, type ) / ( .invPhiFirstDer(.Phi(u, alpha, type), alpha, type) * .invPhiFirstDer(.Phi(v, alpha, type), alpha, type) ) # c.uv[which(u*v == 0 | u*v == 1)] = 0 # Replace NAs: # c.uv[is.na(c.uv)] = 0 # Add Control Attribute: control = list(alpha = alpha[[1]], copula = "archm", type = type) attr(c.uv, "control")<-unlist(control) # As List ? if (output == "list") { N = sqrt(length(u)) x = u[1:N] y = matrix(v, ncol = N)[1, ] c.uv = list(x = x, y = y, z = matrix(c.uv, ncol = N)) } # Return Value: c.uv } # ------------------------------------------------------------------------------ .darchm2Copula <- function(u = 0.5, v = u, alpha = NULL, type = archmList(), output = c("vector", "list")) { # A function implemented by Diethelm Wuertz # Description: # Extreme Value Copulae # References: # Carmona, Evanesce # Matteis, Diploma Thesis # Notes: # "4" Gumbel(alpha->1) -> m-Copula min(u,v) # Example: # persp(z = matrix(.darchm1Copula(.gridCoord()$x, .gridCoord()$y, 1.1, "4"), 101)) # FUNCTION: # Match Arguments: output = match.arg(output) # Type: type = match.arg(type) Type = as.integer(type) # Settings: if (is.null(alpha)) { alpha = archmParam(type)$param } a = alpha if (is.list(u)) { v = u[[2]] u = u[[1]] } if (is.matrix(u)) { v = u[, 1] u = u[, 2] } # Density: if (Type == 1) { c.uv = (1 + a)*u^(-1 - a)*v^(-1 - a) * (-1 + u^(-a) + v^(-a))^(-2 - a^(-1)) } if (Type == 2) { # NOT YET IMPLEMENTED! c.uv = NA # USE: warning("No 2 alternative not available") c.uv = .darchm1Copula(u = u, v = v, alpha = alpha, type = type, output = output) return(c.uv) } if (Type == 3) { c.uv = (-1 + a^2*(-1 + u + v - u*v) - a*(-2 + u + v + u*v)) / (-1 + a*(-1 + u)*(-1 + v))^3 } if (Type == 4) { # Matteis yields wrong results! # c.uv = ((-log(u))^(-1 + a)*(-1 + a + ((-log(u))^a + # (-log(v))^a)^a^(-1))*((-log(u))^a + # (-log(v))^a)^(-2 + a^(-1))*(-log(v))^(-1 + a))/ # (exp((-log(u))^a + (-log(v))^a)^a^(-1)*u*v) # Use instead: c.uv = exp(-((-log(u))^alpha+(-log(v))^alpha)^(1/alpha)) * (- (-log(u))^alpha*(-log(v))^alpha*((-log(u))^alpha + (-log(v))^alpha)^(1/alpha)+(-log(u))^alpha*(-log(v))^alpha * ( (-log(u))^alpha+(-log(v))^alpha)^(1/alpha)*alpha + (-log(u))^(3*alpha)*(-log(v))^alpha*((-log(u))^alpha + (-log(v))^alpha)^(-2*(alpha-1)/alpha)+2*(-log(u))^(2*alpha) * (-log(v))^(2*alpha)*((-log(u))^alpha + (-log(v))^alpha)^(-2*(alpha-1)/alpha)+(-log(u))^alpha * (-log(v))^(3*alpha)*((-log(u))^alpha + (-log(v))^alpha)^(-2*(alpha-1)/alpha))/log(v)/log(u)/v/u / ( (-log(u))^(2*alpha)+2*(-log(u))^alpha*(-log(v))^alpha + (-log(v))^(2*alpha)) } if (Type == 5) { c.uv = (a*exp(a*(1 + u + v))*(-1 + exp(a)))/(exp(a) - exp(a + a*u) + exp(a*(u + v)) - exp(a + a*v))^2 } if (Type == 6) { c.uv = (1 - u)^(-1 + a)*(a - (-1 + (1 - u)^a)*(-1 + (1 - v)^a)) * ((1 - u)^a + (1 - v)^a - (1 - u)^a * (1 - v)^a)^(-2 + a^(-1)) * (1 - v)^(-1 + a) } if (Type == 7) { # NOT YET IMPLEMENTED! c.uv = NA # USE: warning("No 7 alternative not available") c.uv = .darchm1Copula(u = u, v = v, alpha = alpha, type = type, output = output) return(c.uv) } if (Type == 8) { # NOT YET IMPLEMENTED! c.uv = NA # USE: warning("No 8 alternative not available") c.uv = .darchm1Copula(u = u, v = v, alpha = alpha, type = type, output = output) return(c.uv) } if (Type == 9) { c.uv = (1 - a - a*log(v) + a*log(u)*(-1 + a*log(v))) / exp(a*log(u)*log(v)) } if (Type == 10) { c.uv = (2 - v^a + u^a*(-1 + v^a))^(-2 - a^(-1)) * (4 - 2*v^a + u^a*(-2 - (-1 + a)*v^a)) } if (Type == 11) { # NOT YET IMPLEMENTED! c.uv = NA # USE: warning("No 11 alternative not available") c.uv = .darchm1Copula(u = u, v = v, alpha = alpha, type = type, output = output) return(c.uv) } if (Type == 12) { c.uv = ((-1+u^(-1))^a*(-1+a+((-1+u^(-1))^a + (-1+v^(-1))^a)^a^(-1)+a*((-1+u^(-1))^a + (-1+v^(-1))^a)^a^(-1))*((-1+u^(-1))^a + (-1+v^(-1))^a)^(-2+a^(-1))*(-1+v^(-1))^a)/ ((-1+u)*u*(1+((-1+u^(-1))^a + (-1+v^(-1))^a)^a^(-1))^3*(-1+v)*v) } if (Type == 13) { c.uv = (exp(1 - (-1 + (1 - log(u))^a + (1 - log(v))^a)^a^(-1)) * (1 - log(u))^(-1 + a)*(-1 + a + (-1 + (1 - log(u))^a + (1 - log(v))^a)^a^(-1))*(-1 + (1 - log(u))^a + (1 - log(v))^a)^(-2 + a^(-1)) * (1 - log(v))^(-1 + a))/(u*v) } if (Type == 14) { c.uv = ((-1+u^(-a^(-1)))^a*(-1+v^(-a^(-1)))^a * ((-1+u^(-a^(-1)))^a + (-1+v^(-a^(-1)))^a)^(-2+a^(-1)) * (1+((-1+u^(-a^(-1)))^a + (-1+v^(-a^(-1)))^a)^a^(-1))^(-2-a) * (-1+a+2*a*((-1+u^(-a^(-1)))^a + (-1+v^(-a^(-1)))^a)^a^(-1))) / (a*u*(-1+u^a^(-1))*v*(-1+v^a^(-1))) } if (Type == 15) { # NOT YET IMPLEMENTED! c.uv = NA # USE: warning("No 15 alternative not available") c.uv = .darchm1Copula(u = u, v = v, alpha = alpha, type = type, output = output) return(c.uv) } if (Type == 16) { c.uv = (2*a*(a^2 + u^2*v^2 + a*(u^2 + v^2))) / (sqrt(4*a + (-1 + u - a*(-1 + u^(-1) + v^(-1)) + v)^2) * (u^2*v^2*(-1 + u + v)^2 + a^2*(u + v - u*v)^2 + 2*a*u*v*(u^2*(-1 + v) - (-1 + v)*v + u*(1 - v + v^2)))) } if (Type == 17) { c.uv = (2^a*((-1 + 2^a)*a*(1 + u)^a*(1 + v)^a + 2^a*(-1 + (1 + u)^a) * (-1 + (1 + v)^a)))/((1 + u)*(1 + v)*(2^a - 2^a*(1 + u)^a - 2^a*(1 + v)^a + (1 + u)^a*(1 + v)^a)^2 * (1 + ((-1 + (1 + u)^(-a)) * (-1 + (1 + v)^(-a))) / (-1 + 2^(-a)))^a^(-1)) } if (Type == 18) { # NOT YET IMPLEMENTED! c.uv = NA # USE: warning("No 18 alternative not available") c.uv = .darchm1Copula(u = u, v = v, alpha = alpha, type = type, output = output) return(c.uv) } if (Type == 19) { c.uv = (a^3*exp(a*(u^(-1) + v^(-1)))*(2 + log(-exp(a) + exp(a/u) + exp(a/v))))/((-exp(a) + exp(a/u) + exp(a/v))^2*u^2*v^2*log(-exp(a) + exp(a/u) + exp(a/v))^3) } if (Type == 20) { c.uv = (exp(u^(-a) + v^(-a))*u^(-1 - a)*v^(-1 - a) * log(-exp(1) + exp(u^(-a)) + exp(v^(-a)))^(-2 - a^(-1)) * (1 + a + a*log(-exp(1) + exp(u^(-a)) + exp(v^(-a))))) / (-exp(1) + exp(u^(-a)) + exp(v^(-a)))^2 } if (Type == 21) { # NOT YET IMPLEMENTED! c.uv = NA # USE: warning("No 21 alternative not available") c.uv = .darchm1Copula(u = u, v = v, alpha = alpha, type = type, output = output) return(c.uv) } if (Type == 22) { # NOT YET IMPLEMENTED! c.uv = NA # USE: warning("No 22 alternative not available") c.uv = .darchm1Copula(u = u, v = v, alpha = alpha, type = type, output = output) return(c.uv) } # Replace NAs: # c.uv[is.na(c.uv)] = 0 # Add Control Attribute: control = list(alpha = alpha[[1]], copula = "archm", type = type) attr(c.uv, "control")<-unlist(control) # As List ? if (output == "list") { N = sqrt(length(u)) x = u[1:N] y = matrix(v, ncol = N)[1, ] c.uv = list(x = x, y = y, z = matrix(c.uv, ncol = N)) } # Return Value: c.uv } ################################################################################ rgumbelCopula <- function(n = 100, alpha = 2) { # A function implemented by Diethelm Wuertz # Description: # Generates fast gumbel random variates # FUNCTION: # Stable RVs: dim = 2 theta <- runif(n, 0, pi) w <- rexp(n) b = 1/alpha a <- sin((1-b)*theta)*(sin(b*theta))^(b/(1-b)) / (sin(theta))^(1/(1-b)) fr = (a/w)^((1-b)/b) fr <- matrix(fr, nrow = n, ncol = dim) val <- matrix(runif(dim * n), nrow = n) s = -log(val)/fr # Bivariate Gumbel RVs: ans = exp(-s^(1/alpha) ) # Return Value: ans } # ------------------------------------------------------------------------------ pgumbelCopula <- function(u = 0.5, v = u, alpha = 2, output = c("vector", "list")) { # A function implemented by Diethelm Wuertz # Description: # Computes bivariate Gumbel copula probability # FUNCTION: # Bivariate Gumbel Probability: ans = parchmCopula (u, v, alpha, type = "4", output = output, alternative = FALSE) # Return Value: ans } # ------------------------------------------------------------------------------ dgumbelCopula <- function(u = 0.5, v = u, alpha = 2, output = c("vector", "list")) { # A function implemented by Diethelm Wuertz # Description: # Computes bivariate Gumbel copula density # FUNCTION: # Bivariate Gumbel Density: ans <- darchmCopula (u, v, alpha, type = "4", output = output, alternative = FALSE) # Return Value: ans } fCopulae/R/ArchimedeanGenerator.R0000644000176200001440000023455014354776142016431 0ustar liggesusers # 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: ARCHIMEDEAN COPULAE PARAMETER: # archmList Returns list of implemented Archimedean copulae # archmParam Sets Default parameters for an Archimedean copula # archmRange Returns the range of valid alpha values # archmCheck Checks if alpha is in the valid range # FUNCTION: ARCHIMEDEAN COPULAE PHI GENERATOR: # Phi Computes Archimedean Phi, inverse and derivatives # PhiSlider Displays interactively generator function # .Phi Computes Archimedean generator Phi # .Phi0 Utility Function # .PhiFirstDer Computes first derivative of Phi # .PhiSecondDer Computes second derivative of Phi # .invPhi Computes inverse of Archimedean generator # .invPhiFirstDer Computes first derivative of inverse Phi # .invPhiSecondDer Computes second derivative of inverse Phi # FUNCTION: ARCHIMEDEAN DENSITY K GENERATOR: # Kfunc Computes Archimedean Density Kc and its Inverse # KfuncSlider Displays interactively the density and concordance # .Kfunc Computes Density for Archimedean Copulae # .invK Computes Inverse of Density # .invK2 Utility Function # .ALPHA Utility Function # .TAU Utility Function # .RHO Utility Function ################################################################################ ################################################################################ # FUNCTION: ARCHIMEDEAN COPULAE PARAMETER: # archmList Returns list of implemented Archimedean copulae # archmParam Sets default parameters for an Archimedean copula # archmCheck Checks if alpha is in the valid range # archmRange Returns the range of valid alpha values archmList <- function() { # A function implemented by Diethelm Wuertz # Description: # Returns list of implemented Archimedean copulae # Compose List: ans <- paste(1:22) # Return Value: ans } # ------------------------------------------------------------------------------ archmParam <- function(type = archmList()) { # A function implemented by Diethelm Wuertz # Description: # Sets default parameters for Archimedean copulae # Arguments: # type - a character string or integer value naming the copula. # By default the first copula will be chosen. # Value: # returns a list with two elements, 'param' sets the parameters # which may be a vector, 'range' the range with minimum and # maximum values for each of the parameters. # FUNCTION: # Type: type = match.arg(type) Type = as.integer(type) # Parameter Values: B = Inf lower=c(-1, 1,-1, 1,-B, 1, 0, 1, 0, 0, 0, 1, 0, 1, 1, 0,-B, 2, 0, 0, 1, 0) upper=c( B, B, 1, B, B, B, 1, B, 1, 1,.5, B, B, B, B, B, B, B, B, B, B, 1) Alpha=c( 1, 2,.5, 2, 1, 2, .5, 2,.5,.5,.2, 2, 1, 2, 2, 1,.5, 3, 1, 1, 2,.5) # Parameter List: ans = list(copula = type) ans$param = c(alpha = Alpha[Type]) ans$range = c(lower = lower[Type], upper = upper[Type]) # Return Value: ans } # ------------------------------------------------------------------------------ archmRange <- function(type = archmList(), B = Inf) { # A function implemented by Diethelm Wuertz # Description: # Returns the range of valid alpha values # FUNCTION: # Type: type = match.arg(type) Type = as.integer(type) # Range: lower = c(-1, 1,-1, 1,-B, 1, 0, 1, 0, 0, 0, 1, 0, 1, 1, 0,-B, 2, 0, 0, 1, 0) upper = c( B, B, 1, B, B, B, 1, B, 1, 1,.5, B, B, B, B, B, B, B, B, B, B, 1) # Return Value: ans = cbind(lower[Type], upper[Type]) rownames(ans) = type colnames(ans) = c("lower", "upper") ans } # ------------------------------------------------------------------------------ archmCheck <- function(alpha, type = archmList()) { # A function implemented by Diethelm Wuertz # Description: # Checks if alpha is in the valid range # FUNCTION: # Type: type = match.arg(type) # Check: ans = TRUE range = as.vector(archmRange(type)) if (alpha < range[1] | alpha > range[2]) { print(c(alpha = alpha)) print(c(range = range)) stop("alpha is out of range") } # Return Value: invisible(TRUE) } ################################################################################ # FUNCTION: ARCHIMEDEAN COPULAE PHI GENERATOR: # Phi Computes Archimedean Phi, inverse and derivatives # PhiSlider Displays interactively generator function # .Phi Computes Archimedean generator Phi # .Phi0 Utility Function # .PhiFirstDer Computes first derivative of Phi # .PhiSecondDer Computes second derivative of Phi # .invPhi Computes inverse of Archimedean generator # .invPhiFirstDer Computes first derivative of inverse Phi # .invPhiSecondDer Computes second derivative of inverse Phi Phi <- function(x, alpha = NULL, type = archmList(), inv = FALSE, deriv = paste(0:2)) { # A function implemented by Diethelm Wuertz # Type: type = match.arg(type) Type = as.integer(type) deriv = match.arg(deriv) # Default alpha: if (is.null(alpha)) alpha = archmParam(type)$param # Check alpha: check = archmCheck(alpha, type) # Phi Generator: if (inv) { if (deriv == "0") { ans = .invPhi(x, alpha, type) names(ans) = "invPhi" } if (deriv == "1") { ans = .invPhiFirstDer(x, alpha, type) names(ans) = "invPhiFirstDer" } if (deriv == "2") { ans = .invPhiSecondDer(x, alpha, type) names(ans) = "invPhiSecondDer" } } else { if (deriv == "0") { ans = .Phi(x, alpha, type) names(ans) = "Phi" } if (deriv == "1") { ans = .PhiFirstDer(x, alpha, type) names(ans) = "PhiFirstDer" } if (deriv == "2") { ans = .PhiSecondDer(x, alpha, type) names(ans) = "PhiSecondDer" } } # Add Control Attribute: attr(ans, "control")<-cbind.data.frame(alpha = alpha, type = type, inv = inv, deriv = deriv, row.names = "") # Return Value: ans } # ------------------------------------------------------------------------------ PhiSlider <- function(B = 5) { # A function implemented by Diethelm Wuertz # Description: # Displays interactively the dependence function # FUNCTION: # Graphic Frame: par(mfcol = c(2, 2), cex = 0.7) # Internal Function: refresh.code = function(...) { # Startup Counter: .counter <- getRmetricsOptions(".counter") + 1 setRmetricsOptions(.counter = .counter) if (.counter < 10) return () # Sliders: Copula = as.integer(.sliderMenu(no = 1)) Counter = c(1,2,3,2,4,2,5,2,5,5,6,2,7,2,2,7,4,8,7,7,2,5) No = Counter[Copula] N = .sliderMenu(no = 2) alpha = .sliderMenu(no = No+2) # Skip: if (Copula == 13 & alpha == 0) return(invisible()) # Do we have a strict Copula? strict = c( "Yes","No","Yes","Yes","Yes","Yes","No","No","Yes","Yes", "No","Yes","Yes","Yes","No","Yes","Yes","No","Yes","Yes", "No","Yes")[Copula] if (alpha < 0 & Copula == 1) strict[1] = "No" if (alpha == 0 & Copula == 16) strict[16] = "No" # What is the Range? RANGE = c( "-1|Inf", "1|Inf", "-1|1", "-Inf|inf", "0|1", "0|0.5", "0|Inf", "2|Inf")[No] # Which one is the Limit Copula? limitTitle = rep("NA", times = 22) if (alpha == -1) limitTitle = c( "W ", "NA", "NA", "NA", "NA", "NA", "NA", "NA", "NA", "NA", "NA", "NA", "NA", "NA", "NA", "NA", "Pi", "NA", "NA", "NA", "NA", "NA") if (alpha == 0) limitTitle = c( "Pi", "NA", "Pi", "NA", "Pi", "NA", "W ", "NA", "Pi", "Pi", "Pi", "NA", "NA", "NA", "NA", "W ", "NA", "NA", "L ", "Pi", "NA", "Pi") if (alpha == 1) limitTitle = c( "L ", "W ", "L ", "Pi", "NA", "Pi", "Pi", "W ", "NA", "NA", "NA", "L ", "Pi", "L ", "W ", "NA", "NA", "NA", "NA", "NA", "W ", "NA") limitTitle = limitTitle[Copula] if (limitTitle == "NA") { limitTitle = " " } else { limitTitle = paste(" Copula = ", limitTitle[1]) } # Plot phi: x = (0:N)/N Title = paste("Generator Phi - Copula No:", as.character(Copula), "\nalpha = ", as.character(alpha), " Strict = ", strict, limitTitle) phi.0 = .Phi(x = 0, alpha = alpha, type = as.character(Copula)) y = .Phi(x = x, alpha = alpha, type = as.character(Copula)) x = x[y < 1e6] y = y[y < 1e6] if (is.finite(y[1])) ylim = c(0, y[1]) else ylim = c(0, y[2]) plot(x = x, y = y, type = "l", ylim = ylim, main = Title[1], xlab = "t", ylab = paste("Phi |", RANGE)) if (N < 100) points(x = x, y = y, pch = 19, cex = 0.5) y.inv = .invPhi(x = y, alpha = alpha, type = as.character(Copula)) lines(x = y.inv, y = y, col = "red", lty = 3) abline(h = 0, lty = 3) points(0, phi.0, col = "red", pch = 19) # Plot phi first and second Derivative: y1 = .PhiFirstDer(x = x, alpha = alpha, type = as.character(Copula)) y2 = .PhiSecondDer(x = x, alpha = alpha, type = as.character(Copula)) r1 = max(abs(y1[is.finite(y1)])) r2 = max(abs(y2[is.finite(y2)])) if (r2 == 0) r2 = 1 plot(x = x, y = y1/r1, ylim = c(-1, 1), type = "l", xlab = "t", ylab = "Derivatives", main = "Phi first and second Derivative", col = "blue") if (N < 100) points(x = x, y = y1/r1, pch = 19, cex = 0.5) lines(x = x, y = y2/r2, col = "red") if (N < 100) points(x = x, y = y2/r2, pch = 19, cex = 0.5) abline(h = 0, lty = 3) mtext("First ", 4, col = "blue", cex = 0.75) mtext(" Second", 4, col = "red ", cex = 0.75) mtext(paste("x", as.character(round(r1, digits = 2))), 1, line = -2, col = "blue", cex = 0.75) mtext(paste("x", as.character(round(r2, digits = 2))), 3, line = -2, col = "red", cex = 0.75) # Plot invPhi: Title = paste( "Inverse Phi\n Phi(0) =", as.character(round(phi.0, digits = 3))) plot(x = y, y = y.inv, type = "l", main = Title, xlab = paste("Phi |", RANGE), ylab = "t") if (N < 100) points(x = y, y = y.inv, pch = 19, cex = 0.5) abline(h = 0, lty = 3) points(phi.0, 0, col = "red", pch = 19) # Plot invPhi first & second Derivative: y = y[y < .Phi0(alpha, Copula)] Title = "Inverse Phi 1st Derivative" y1.inv = .invPhiFirstDer(x = y, alpha = alpha, type = as.character(Copula)) y2.inv = .invPhiSecondDer(x = y, alpha = alpha, type = as.character(Copula)) r1 = max(abs(y1.inv[is.finite(y1.inv)])) r2 = max(abs(y2.inv[is.finite(y2.inv)])) if (r2 == 0) r2 = 1 plot(x = y, y = y1.inv/r1, ylim = c(-1, 1), type = "l", xlim = range(y), xlab = paste("Phi |", RANGE), ylab = "dewrivatives", main = "Inv Phi first and second Derivative", col = "blue") if (N < 100) points(x = y, y = y1.inv/r1, pch = 19, cex = 0.5) lines(x = y, y = y2.inv/r2, col = "red") if (N < 100) points(x = y, y = y2.inv/r2, pch = 19, cex = 0.5) abline(h = 0, lty = 3) mtext("First ", 4, col = "blue", cex = 0.75) mtext(" Second", 4, col = "red ", cex = 0.75) mtext(paste("x", as.character(round(r1, digits = 2))), 1, line = -2, col = "blue", cex = 0.75) mtext(paste("x", as.character(round(r2, digits = 2))), 3, line = -2, col = "red", cex = 0.75) # Reset Frame: par(mfcol = c(2, 2), cex = 0.7) } # Open Slider Menu: setRmetricsOptions(.counter = 10) C1 = "1: [-1,Inf]" C2 = "2-4-6-8-12-14-15-21: [1,Inf)" C3 = "3: [-1,1)" C4 = "5-17: (-Inf,Inf)|{0}" C5 = "7-9-10-22: (0,1]" C6 = "11: (0, 1/2]" C7 = "13-16-19-20: (0,Inf)" C8 = "18: [2, Inf)" C = c( C1, C2, C3, C4, C5, C6, C7, C8 ) L = c( -1, 1, -1, -B, 0, 0, 0, 2 ) U = c(3*B/5, B, 1, B, 1, 0.5, B/2, 2*B ) A = c( 0.5, 2, 0.5, 1, 0.5, 0.2, 1, 3 ) V = rep(0.01, 20) .sliderMenu(refresh.code, names = c("Copula", "N", C), minima = c( 1, 10, L), maxima = c( 22, 1000, U), resolutions = c( 1, 10, V), starts = c( 1, 100, A)) } # ------------------------------------------------------------------------------ .Phi <- function(x, alpha = NULL, type = archmList()) { # A function implemented by Diethelm Wuertz # Description: # Computes Archimedean generator "phi" # FUNCTION: # Type: type = match.arg(type) Type = as.integer(type) # Missing x: if (missing(x)) x = (0:10)/10 # Alpha: if (is.null(alpha)) alpha = archmParam(type)$param # Check alpha: check = archmCheck(alpha, type) # As listed in Nelsen: N = length(x) Type = "NA" if (type == 1) if (alpha == -1) Type = "W" else if (alpha == 0) Type = "Pi" else if (alpha == 1) Type = "L" else f = 1/alpha*(x^(-alpha)-1) # Clayton if (type == 2) if (alpha == 1) Type = "W" else f = (1-x)^alpha if (type == 3) if (alpha == 0) Type = "Pi" else if (alpha == 1) Type = "L" else f = log((1-alpha*(1-x))/x) # Ali-Mikhail-Haq if (type == 4) if (alpha == 1) Type = "Pi" else f = (-log(x))^alpha # Gumbel-Hougard if (type == 5) if (alpha == 0) Type = "Pi" else f = -log((exp(-alpha*x)-1)/(exp(-alpha)-1)) # Frank if (type == 6) if (alpha == 1) Type = "Pi" else f = -log(1-(1-x)^alpha) # Joe if (type == 7) if (alpha == 0) Type = "W" else if (alpha == 1) Type = "Pi" else f = -log(alpha*x+(1-alpha)) if (type == 8) if (alpha == 0) Type = "Pi" else f = (1-x)/(1+x*(alpha-1)) if (type == 9) if (alpha == 0) Type = "Pi" else f = log(1-alpha*log(x)) # Gumbel-Barnett if (type == 10) if (alpha == 0) Type = "Pi" else f = log(2*x^(-alpha)-1) if (type == 11) if (alpha == 0) Type = "Pi" else f = log(2-x^alpha) if (type == 12) if (alpha == 1) Type = "L" else f = (1/x-1)^alpha if (type == 13) if (alpha == 1) Type = "Pi" else f = (1-log(x))^alpha-1 if (type == 14) if (alpha == 1) Type = "L" else f = (x^(-1/alpha)-1)^alpha if (type == 15) if (alpha == 1) Type = "W" else f = (1-x^(1/alpha))^alpha if (type == 16) if (alpha == 0) Type = "W" else f = (alpha/x+1)*(1-x) if (type == 17) if (alpha == -1) Type = "Pi" else f = -log(((1+x)^(-alpha)-1)/(2^(-alpha)-1)) if (type == 18) f = exp(alpha/(x-1)) if (type == 19) if (alpha == 0) Type = "L" else f = exp(alpha/x)-exp(alpha) if (type == 20) if (alpha == 0) Type = "Pi" else f = exp(x^(-alpha))-exp(1) if (type == 21) if (alpha == 1) Type = "W" else f = (1-(1-(1-x)^alpha)^(1/alpha)) if (type == 22) if (alpha == 0) Type = "Pi" else f = asin(1-x^alpha) if (Type == "Pi") f = -log(x) if (Type == "W") f = 1-x if (Type == "L") f = 1/x - 1 f[x == 0] = .Phi0(alpha, type) # Return Value: f } # ------------------------------------------------------------------------------ .Phi0 <- function(alpha, type) { # A function implemented by Diethelm Wuertz # Phi(0): type <- as.integer(type) if (type == 1) phi0 = if (alpha < 0) -1/alpha else Inf else if (type == 2) phi0 = 1 else if (type == 3) phi0 = Inf else if (type == 4) phi0 = Inf else if (type == 5) phi0 = Inf else if (type == 6) phi0 = Inf else if (type == 7) phi0 = if (alpha == 0) 1 else -log(1 - alpha) else if (type == 8) phi0 = 1 else if (type == 9) phi0 = Inf else if (type == 10) phi0 = Inf else if (type == 11) phi0 = if (alpha == 0) Inf else log(2) else if (type == 12) phi0 = Inf else if (type == 13) phi0 = Inf else if (type == 14) phi0 = Inf else if (type == 15) phi0 = 1 else if (type == 16) phi0 = if (alpha == 0) 1 else Inf else if (type == 17) phi0 = Inf else if (type == 18) phi0 = exp(-alpha) else if (type == 19) phi0 = Inf else if (type == 20) phi0 = Inf else if (type == 21) phi0 = 1 else if (type == 22) phi0 = if (alpha == 0) Inf else pi/2 # Return Value: phi0 } # ------------------------------------------------------------------------------ .PhiFirstDer <- function(x, alpha = NULL, type = archmList()) { # A function implemented by Diethelm Wuertz # Description: # Computes Derivative of Archimedean generator. # FUNCTION: # Type: type = match.arg(type) Type = as.integer(type) # Missing x: if (missing(x)) x = (0:10)/10 # Alpha: if (is.null(alpha)) alpha = archmParam(type)$param # Check alpha: check = archmCheck(alpha, type) # FUNCTION: # The functions were created by MAPLE: N = length(x) cType = "NA" if (Type == 1) if (alpha == -1) cType = "W" else if (alpha == 0) cType = "Pi" else if (alpha == 1) cType = "L" else f1 = -x^(-alpha-1) if (Type == 2) if (alpha == 1) cType = "W" else f1 = -(1-x)^alpha*alpha/(1-x) if (Type == 3) if (alpha == 0) cType = "Pi" else if (alpha == 1) cType = "L" else f1 = (alpha/x-(1-alpha*(1-x))/x^2)/(1-alpha*(1-x))*x if (Type == 4) if (alpha == 1) cType = "Pi" else f1 = (-log(x))^alpha*alpha/x/log(x) if (Type == 5) if (alpha == 0) cType = "Pi" else f1 = alpha*exp(-alpha*x)/(exp(-alpha*x)-1) if (Type == 6) if (alpha == 1) cType = "Pi" else f1 = -(1-x)^alpha*alpha/(1-x)/(1-(1-x)^alpha) if (Type == 7) if (alpha == 0) cType = "W" else if (alpha == 1) cType = "Pi" else f1 = -alpha/(alpha*x+1-alpha) if (Type == 8) if (alpha == 1) cType = "W" else f1 = -1/(1+x*(-1+alpha))-(1-x)/(1+x*(-1+alpha))^2*(-1+alpha) if (Type == 9) if (alpha == 0) cType = "Pi" else f1 = -alpha/x/(1-alpha*log(x)) if (Type == 10) if (alpha == 0) cType = "Pi" else f1 = -2*x^(-alpha)*alpha/x/(2*x^(-alpha)-1) if (Type == 11) if (alpha == 0) cType = "Pi" else f1 = -x^alpha*alpha/x/(2-x^alpha) if (Type == 12) if (alpha == 1) cType = "L" else f1 = -(1/x-1)^alpha*alpha/x^2/(1/x-1) if (Type == 13) if (alpha == 1) cType = "Pi" else f1 = -(1-log(x))^alpha*alpha/x/(1-log(x)) if (Type == 14) if (alpha == 1) cType = "L" else f1 = -(x^(-1/alpha)-1)^alpha*x^(-1/alpha)/x/(x^(-1/alpha)-1) if (Type == 15) if (alpha == 1) cType = "W" else f1 = -(1-x^(1/alpha))^alpha*x^(1/alpha)/x/(1-x^(1/alpha)) if (Type == 16) if (alpha == 0) cType = "W" else f1 = -alpha/x^2*(1-x)-alpha/x-1 if (Type == 17) if (alpha == -1) cType = "Pi" else f1 = (1+x)^(-alpha)*alpha/(1+x)/((1+x)^(-alpha)-1) if (Type == 18) f1 = -alpha/(-1+x)^2*exp(alpha/(-1+x)) if (Type == 19) if (alpha == 0) cType = "L" else f1 = -alpha/x^2*exp(alpha/x) if (Type == 20) if (alpha == 0) cType = "Pi" else f1 = -x^(-alpha)*alpha/x*exp(x^(-alpha)) if (Type == 21) if (alpha == 1) cType = "W" else f1 = -(1-(1-x)^alpha)^(-(-1+alpha)/alpha)*(1-x)^(-1+alpha) if (Type == 22) if (alpha == 0) cType = "Pi" else f1 = -x^(-1+alpha)*alpha/(2*x^alpha-x^(2*alpha))^(1/2) if (cType == "Pi") f1 = -1/x if (cType == "W") f1 = rep(-1, times = N) if (cType == "L") f1 = -1/x^2 # Return Value: f1 } # ------------------------------------------------------------------------------ .PhiSecondDer <- function(x, alpha = NULL, type = archmList()) { # A function implemented by Diethelm Wuertz # Description: # Computes Derivative of Archimedean generator. # FUNCTION: # Type: type = match.arg(type) Type = as.integer(type) # Missing x: if (missing(x)) x = (0:10)/10 # Alpha: if (is.null(alpha)) alpha = archmParam(type)$param # Check alpha: check = archmCheck(alpha, type) # FUNCTION: # The functions were created by MAPLE: a = alpha N = length(x) cType = "NA" if (Type == 1) if (alpha == -1) cType = "W" else if (alpha == 0) cType = "Pi" else if (alpha == 1) cType = "L" else f2 = x^(-a-2)*a+x^(-a-2) if (Type == 2) if (alpha == 1) cType = "W" else f2 = (1-x)^(a-2)*a^2-(1-x)^(a-2)*a if (Type == 3) if (alpha == 0) cType = "Pi" else if (alpha == 1) Type = "L" else f2 = -1/x^2*(a-1)*(1-a+2*x)/(1-a+x)^2 if (Type == 4) if (alpha == 1) cType = "Pi" else f2 = a*((-log(x))^(a-2)*a+(-log(x))^(a-1)-(-log(x))^(a-2))/x^2 if (Type == 5) if (alpha == 0) cType = "Pi" else f2 = a^2*exp(-a*x)/(exp(-a*x)-1)^2 if (Type == 6) if (alpha == 1) cType = "Pi" else f2 = a*((1-x)^(a-2)*a-(1-x)^(a-2)+(1-x)^(2*a-2))/(-1+(1-x)^a)^2 if (Type == 7) if (alpha == 0) cType = "W" else if (alpha == 1) cType = "Pi" else f2 = alpha^2/(alpha*x+1-alpha)^2 if (Type == 8) if (alpha == 1) cType = "W" else f2 = 2*(a-1)*a/(1+a*x-x)^3 if (Type == 9) if (alpha == 0) cType = "Pi" else f2 = -a*(-1+a*log(x)+a)/x^2/(-1+a*log(x))^2 if (Type == 10) if (alpha == 0) cType = "Pi" else f2 = -2*a*(x^a*a-2+x^a)/(-2+x^a)^2/x^2 if (Type == 11) if (alpha == 0) cType = "Pi" else f2 = -a*(2*x^(a-2)*a-2*x^(a-2)+x^(2*a-2))/(-2+x^a)^2 if (Type == 12) if (alpha == 1) cType = "L" else f2 = -(-(x-1)/x)^a*a*(-a+2*x-1)/x^2/(x-1)^2 if (Type == 13) if (alpha == 1) cType = "Pi" else f2 = a*((1-log(x))^(a-2)*a+(1-log(x))^(a-1)-(1-log(x))^(a-2))/x^2 if (Type == 14) if (alpha == 1) cType = "L" else f2 = ((x^(-1/a)-1)^(a-2)*x^(-2*(a+1)/a)*a+(x^(-1/a)-1)^(a-1) * x^(-(1+2*a)/a)+(x^(-1/a)-1)^(a-1)*x^(-(1+2*a)/a) * a-(x^(-1/a)-1)^(a-2)*x^(-2*(a+1)/a))/a if (Type == 15) if (alpha == 1) cType = "W" else f2 = ((1-x^(1/a))^(a-2)*x^(-2*(a-1)/a)*a-(1-x^(1/a))^(a-1) * x^(-(-1+2*a)/a)+(1-x^(1/a))^(a-1)*x^(-(-1+2*a)/a) * a-(1-x^(1/a))^(a-2)*x^(-2*(a-1)/a))/a if (Type == 16) if (alpha == 0) cType = "W" else f2 = 2*a/x^3 if (Type == 17) if (alpha == -1) cType = "Pi" else f2 = a*((1+x)^(a-2)*a+2*(1+x)^(a-2)*a*x+(1+x)^(a-2)*a*x^2 - 1+(1+x)^(a-2)+2*(1+x)^(a-2)*x+(1+x)^(a-2)*x^2) / (-1+(1+x)^a)^2/(1+x)^2 if (Type == 18) f2 = a*exp(a/(x-1))*(2*x-2+a)/(x-1)^4 if (Type == 19) if (alpha == 0) cType = "L" else f2 = a*exp(a/x)*(2*x+a)/x^4 if (Type == 20) if (alpha == 0) cType = "Pi" else f2 = a*exp(x^(-a))*(x^(-a-2)*a+x^(-a-2)+x^(-2*a-2)*a) if (Type == 21) if (alpha == 1) cType = "W" else f2 = -(1-(1-x)^a)^(-(-1+2*a)/a)*(1-x)^(2*a-2) + (1-(1-x)^a)^(-(-1+a)/a)*(1-x)^(a-2)*a - (1-(1-x)^a)^(-(-1+a)/a)*(1-x)^(a-2) + (1-(1-x)^a)^(-(-1+2*a)/a)*(1-x)^(2*a-2)*a if (Type == 22) if (alpha == 0) cType = "Pi" else f2 = -a/x^2*(a*x^(2*a)-2*x^(2*a)+x^(3*a))/(2*x^a-x^(2*a))^(3/2) if (cType == "Pi") f2 = 1/x^2 if (cType == "W") f2 = rep(0, times = N) if (cType == "L") f2 = 2/x^3 # Return Value: f2 } # ------------------------------------------------------------------------------ .invPhi <- function(x, alpha = NULL, type = archmList()) { # A function implemented by Diethelm Wuertz # Description: # Computes inverse of Archimedean generator. # FUNCTION: # Type: type <- match.arg(type) Type <- as.integer(type) # Missing x: if (missing(x)) x = (0:10)/10 # Alpha: if (is.null(alpha)) alpha = archmParam(type)$param # Check alpha: check <- archmCheck(alpha, type) # Inverse Generator: N = length(x) cType = "NA" if (Type == 1) if (alpha == -1) cType = "W" else if (alpha == 0) cType = "Pi" else if (alpha == 1) cType = "L" else finv = exp(-log(1 + alpha*x)/alpha) if (Type == 2) if (alpha == 1) cType = "W" else finv = 1 - x^(1/alpha) if (Type == 3) if (alpha == 0) cType = "Pi" else if (alpha == 1) cType = "L" else finv = (1-alpha) / (exp(x)-alpha) if (Type == 4) if (alpha == 1) cType = "Pi" else finv = exp(-x^(1/alpha)) if (Type == 5) if (alpha == 0) cType = "Pi" else finv = -log(1+exp(-x)*( exp(-alpha)-1 ) ) / alpha if (Type == 6) if (alpha == 1) cType = "Pi" else finv = 1 - (1 - exp(-x))^(1/alpha) if (Type == 7) if (alpha == 0) cType = "W" else if (alpha == 1) Type = "Pi" else finv = (1-exp(x)+alpha*exp(x))/alpha/exp(x) if (Type == 8) if (alpha == 1) cType = "W" else finv = (1-x) / ((alpha-1)*x+1) if (Type == 9) if (alpha == 0) cType = "Pi" else finv = exp((1-exp(x))/alpha) if (Type == 10) if (alpha == 0) cType = "Pi" else finv = ((1+exp(x))/2 )^(-1/alpha) if (Type == 11) if (alpha == 0) cType = "Pi" else finv = (2-exp(x))^(1/alpha) if (Type == 12) if (alpha == 1) cType = "L" else finv = 1/(1+x^(1/alpha)) if (Type == 13) if (alpha == 1) cType = "Pi" else finv = exp(1-(1+x)^(1/alpha)) if (Type == 14) if (alpha == 1) cType = "L" else finv = (1+x^(1/alpha))^(-alpha) if (Type == 15) if (alpha == 1) cType = "W" else finv = (1-x^(1/alpha))^alpha if (Type == 16) if (alpha == 0) cType = "W" else finv = (1-alpha-x)/2 + sqrt(((1-alpha-x)^2)/4+alpha) if (Type == 17) if (alpha == -1) cType = "Pi" else finv = (exp(-x)*(2^(-alpha)-1)+1)^(-1/alpha) - 1 if (Type == 18) finv = 1+alpha/log(x) if (Type == 19) if (alpha == 0) cType = "L" else finv = alpha / log(x+exp(alpha)) if (Type == 20) if (alpha == 0) cType = "Pi" else finv = exp( -log((log(x+exp(1))))/alpha) if (Type == 21) if (alpha == 1) cType = "W" else finv = 1-(1-(1-x)^alpha)^(1/alpha) if (Type == 22) if (alpha == 0) cType = "Pi" else finv = (1-sin(x))^(1/alpha) if (cType == "Pi") finv = exp(-x) if (cType == "W") finv = 1 - x if (cType == "L") finv = 1 / (x+1) # Large x Limit: finv[which(x >= .Phi0(alpha, type))] = 0 # Return Value: finv } # ------------------------------------------------------------------------------ .invPhiFirstDer <- function(x, alpha = NULL, type = archmList()) { # A function implemented by Diethelm Wuertz # Description: # Computes first Derivative of inverse Archimedean generator. # FUNCTION: # Type: type = match.arg(type) Type = as.integer(type) # Missing x: if (missing(x)) x = (0:10)/10 # Alpha: if (is.null(alpha)) alpha = archmParam(type)$param # Check alpha: check = archmCheck(alpha, type) # Generator: N = length(x) cType = "NA" a = alpha y = x ln = log if (Type == 1) if (alpha == -1) cType = "W" else if (alpha == 0) cType = "Pi" else if (alpha == 1) cType = "L" else finv1 = -(1+y*a)^(-(a+1)/a) if (Type == 2) if (alpha == 1) cType = "W" else finv1 = -y^(-(a-1)/a)/a if (Type == 3) if (alpha == 0) cType = "Pi" else if (alpha == 1) cType = "L" else finv1 = (a-1)/(exp(y)-1)^2*exp(y) if (Type == 4) if (alpha == 1) cType = "Pi" else finv1 = -y^(-(a-1)/a)/a*exp(-y^(1/a)) if (Type == 5) if (alpha == 0) cType = "Pi" else finv1 = (-1+exp(a))/(-1+exp(a)-exp(y+a))/a if (Type == 6) if (alpha == 1) cType = "Pi" else finv1 = -exp(-(-ln(exp(y)-1)+y)/a)/(exp(y)-1)/a if (Type == 7) if (alpha == 0) cType = "W" else if (alpha == 1) Type = "Pi" else finv1 = (-exp(y)+a*exp(y))/a/exp(y)-(1-exp(y)+a*exp(y))/a/exp(y) if (Type == 8) if (alpha == 1) cType = "W" else finv1 = -a/(1+y*a-y)^2 if (Type == 9) if (alpha == 0) cType = "Pi" else finv1 = -1/a*exp((y*a-exp(y)+1)/a) if (Type == 10) if (alpha == 0) cType = "Pi" else finv1 = -1/(exp(y)+1)/a*exp((y*a+ln(2)-ln(exp(y)+1))/a) if (Type == 11) if (alpha == 0) cType = "Pi" else finv1 = -(-exp(y)+2)^(-(a-1)/a)/a*exp(y) if (Type == 12) if (alpha == 1) cType = "L" else finv1 = -1/(y^(1/a)+1)^2*y^(-(a-1)/a)/a if (Type == 13) if (alpha == 1) cType = "Pi" else finv1 = -(1+y)^(-(a-1)/a)/a*exp(-(1+y)^(1/a)+1) if (Type == 14) if (alpha == 1) cType = "L" else finv1 = -(y^(1/a)+1)^(-a-1)*y^(-(a-1)/a) if (Type == 15) if (alpha == 1) cType = "L" else finv1 = -(-y^(1/a)+1)^(a-1)*y^(-(a-1)/a) if (Type == 16) if (alpha == 0) cType = "W" else finv1 = -1/2+1/4/(a^2+2*a+2*a*y+1-2*y+y^2)^(1/2)*(2*a-2+2*y) if (Type == 17) if (alpha == -1) cType = "Pi" else finv1 = -(2^(-a)-1+exp(y))^(-1/a)*exp(1/a*y) * (-1+2^a)/a/(1-2^a+exp(y)*2^a) if (Type == 18) finv1 = -a/ln(y)^2/y if (Type == 19) if (alpha == 0) cType = "L" else finv1 = -a/ln(exp(a)+y)^2/(exp(a)+y) if (Type == 20) if (alpha == 0) cType = "Pi" else finv1 = -ln(exp(1)+y)^(-(a+1)/a)/a/(exp(1)+y) if (Type == 21) if (alpha == 1) cType = "W" else finv1 = -exp((log(1-y)*a^2+log(-(1-y)^a+1))/a)/(-1+y)/((1-y)^a-1) if (Type == 22) if (alpha == 0) cType = "Pi" else finv1 = -cos(y)*(1-sin(y))^(-(-1+a)/a)/a if (cType == "Pi") finv1 = -exp(-x) if (cType == "W") finv1 = rep(-1, times = N) if (cType == "L") finv1 = -1 / (x+1)^2 # Large x Limit: finv1[which(x >= .Phi0(a, type))] = 0 # Return Value: finv1 } # ------------------------------------------------------------------------------ .invPhiSecondDer <- function(x, alpha = NULL, type = archmList()) { # A function implemented by Diethelm Wuertz # Description: # Computes first Derivative of inverse Archimedean generator. # FUNCTION: # Type: type = match.arg(type) Type = as.integer(type) # Missing x: if (missing(x)) x = (0:10)/10 # Alpha: if (is.null(alpha)) alpha = archmParam(type)$param # Check alpha: check = archmCheck(alpha, type) # Generator: N = length(x) cType = "NA" a = alpha y = x ln = log if (Type == 1) if (alpha == 0) finv2 = exp(-y) else finv2 = finv2 = (1+y*a)^(-(2*a+1)/a)*(a+1) if (Type == 2) if (alpha == 1) cType = "W" else finv2 = y^(-(2*a-1)/a)*(a-1)/a^2 if (Type == 3) if (alpha == 0) cType = "Pi" else if (alpha == 1) Type = "L" else finv2 = -(a-1)*exp(y)*(exp(y)+1)/(exp(y)-1)^3 if (Type == 4) if (alpha == 1) cType = "Pi" else finv2 = exp(-y^(1/a))*(y^(-(2*a-1)/a)*a-y^(-(2*a-1)/a) + y^(-2*(a-1)/a))/a^2 if (Type == 5) if (alpha == 0) cType = "Pi" else finv2 = (-1+exp(a))/(-1+exp(a)-exp(y+a))^2/a*exp(y+a) if (Type == 6) if (alpha == 1) cType = "Pi" else finv2 = (-exp(-(-ln(exp(y)-1)+y)/a) + exp((ln(exp(y)-1)-y+y*a)/a)*a) / (exp(y)-1)^2/a^2 if (Type == 7) if (alpha == 0) cType = "W" else if (alpha == 1) Type = "Pi" else finv2 = -(-exp(y)+a*exp(y))/a/exp(y)+(1-exp(y)+a*exp(y))/a/exp(y) if (Type == 8) if (alpha == 1) cType = "W" else finv2 = 2*a/(1+y*a-y)^3*(a-1) if (Type == 9) if (alpha == 0) cType = "Pi" else finv2 = -1/a^2*(a-exp(y))*exp((y*a-exp(y)+1)/a) if (Type == 10) if (alpha == 0) cType = "Pi" else finv2 = -(exp((y*a+ln(2)-ln(exp(y)+1))/a)*a-exp((2*y*a+ln(2) - ln(exp(y)+1))/a))/(exp(y)+1)^2/a^2 if (Type == 11) if (alpha == 0) cType = "Pi" else finv2 = -exp(y)*((-exp(y)+2)^(-(2*a-1)/a)*exp(y)*a - (-exp(y)+2)^(-(2*a-1)/a)*exp(y)+(-exp(y)+2)^(-(a-1)/a)*a)/a^2 if (Type == 12) if (alpha == 1) cType = "L" else finv2 = (y^(-2*(a-1)/a)+y^(-2*(a-1)/a)*a+y^(-(2*a-1)/a)*a - y^(-(2*a-1)/a))/(y^(1/a)+1)^3/a^2 if (Type == 13) if (alpha == 1) cType = "Pi" else finv2 = exp(-(1+y)^(1/a)+1)*((1+y)^(1/a)*a-(1+y)^(1/a) + (1+y)^(-2*(a-1)/a)+2*(1+y)^(-2*(a-1)/a)*y + (1+y)^(-2*(a-1)/a)*y^2)/a^2/(1+2*y+y^2) if (Type == 14) if (alpha == 1) cType = "L" else finv2 = ((y^(1/a)+1)^(-a-2)*y^(-2*(a-1)/a)*a + (y^(1/a)+1)^(-a-2)*y^(-2*(a-1)/a)+(y^(1/a)+1)^(-a-1) * y^(-(2*a-1)/a)*a-(y^(1/a)+1)^(-a-1)*y^(-(2*a-1)/a))/a if (Type == 15) if (alpha == 1) cType = "L" else finv2 = (a-1)*((-y^(1/a)+1)^(a-2)*y^(-2*(a-1)/a) + (-y^(1/a)+1)^(a-1)*y^(-(2*a-1)/a))/a if (Type == 16) if (alpha == 0) cType = "W" else finv2 = 2*a/(a^2+2*a+2*a*y+1-2*y+y^2)^(3/2) if (Type == 17) if (alpha == -1) cType = "Pi" else finv2 = (2^(-a)-1+exp(y))^(-1/a)*(exp(y*(a+1)/a) - 2^(a+1)*exp(y*(a+1)/a)+exp(y*(a+1)/a)*4^a + exp(1/a*y)*2^(-a)-3*exp(1/a*y)+3*exp(1/a*y)*2^a - exp(1/a*y)*4^a-exp(y*(a+1)/a)*a+2^(a+1) * exp(y*(a+1)/a)*a- exp(y*(2*a+1)/a)*a*2^a - exp(y*(a+1)/a)*a*4^a+exp(y*(2*a+1)/a)*a*4^a)/a^2/(2^(-a)-1 + exp(y))/(1-2^a+exp(y)*2^a)^2 if (Type == 18) finv2 = a*(2+ln(y))/ln(y)^3/y^2 if (Type == 19) if (alpha == 0) cType = "L" else finv2 = a*(2+ln(exp(a)+y))/ln(exp(a)+y)^3/(exp(a)+y)^2 if (type == 20) if (alpha == 0) cType = "Pi" else finv2 = (ln(exp(1)+y)^(-(2*a+1)/a)*a + ln(exp(1)+y)^(-(2*a+1)/a) + ln(exp(1)+y)^(-(a+1)/a)*a)/a^2/(exp(1)+y)^2 if (Type == 21) if (alpha == 1) cType = "W" else finv2 = -(-(1-y)^a+1)^(1/a)*((1-y)^(2*a)-(1-y)^a - a*(1-y)^(2*a)+a*(1-y)^a+(1-y)^(2*a-2)*a - 2*(1-y)^(2*a-2)*a*y+(1-y)^(2*a-2)*a*y^2 -( 1-y)^(2*a-2)+2*(1-y)^(2*a-2)*y-(1-y)^(2*a-2)*y^2) / (-1+y)^2/(-(1-y)^(2*a)+2*(1-y)^a-1) if (Type == 22) if (alpha == 0) cType = "Pi" else finv2 = -(1-sin(y))^(1/a)*(cos(y)^2 + a*sin(y)-2*sin(y)+a-2)/cos(y)^2/a^2 if (cType == "Pi") finv2 = exp(-x) if (cType == "W") finv2 = rep(0, times = N) if (cType == "L") finv2 = 2 / (x+1)^3 # Large x Limit: finv2[which(x>=.Phi0(a, type))] = 0 # Return Value: finv2 } ################################################################################ # FUNCTION: ARCHIMEDEAN DENSITY K GENERATOR: # Kfunc Computes Archimedean Density Kc and its Inverse # KfuncSlider Displays interactively the density and concordance # .Kfunc Computes Density for Archimedean Copulae # .invK Computes Inverse of Density # .invK2 Utility Function # .ALPHA Utility Function # .TAU Utility Function # .RHO Utility Function Kfunc <- function(x, alpha = NULL, type = archmList(), inv = FALSE, lower = 1.0e-8) { # A function implemented by Diethelm Wuertz # Description: # Computes density and its inverse for Archimedean Copulae # FUNCTION: # Type: type = match.arg(type) Type = as.integer(type) # Default alpha: if (is.null(alpha)) alpha = archmParam(type)$param # Check alpha: check = archmCheck(alpha, type) # Density or its inverse: if (!inv) { ans = .Kfunc(x, alpha, type) names(ans)<-"Kfunc" } else { ans = .invK(x, alpha, type, lower) names(ans)<-"invK" } # Add Control Attribute: attr(ans, "control")<-cbind.data.frame(alpha = alpha, type = type, inv = inv, lower = lower, row.names = "") # Return Value: ans } # ------------------------------------------------------------------------------ KfuncSlider <- function(B = 5) { # A function implemented by Diethelm Wuertz # Description: # Displays interactively the density and concordance # FUNCTION: # Graphic Frame: par(mfcol = c(2, 2), cex = 0.7) # Internal Function: refresh.code = function(...) { # Startup Counter: .counter <- getRmetricsOptions(".counter") + 1 setRmetricsOptions(.counter = .counter) if (.counter < 10) return () # Sliders: Copula = as.integer(.sliderMenu(no = 1)) Counter = c(1,2,3,2,4,2,5,2,5,5,6,2,7,2,2,7,4,8,7,7,2,5) No = Counter[Copula] N = .sliderMenu(no = 2) alpha = .sliderMenu(no = No+2) # Skip: if (Copula == 13 & alpha == 0) return(invisible()) # Do we have a strict Copula? strict = c( "Yes","No","Yes","Yes","Yes","Yes","No","No","Yes","Yes", "No","Yes","Yes","Yes","No","Yes","Yes","No","Yes","Yes", "No","Yes")[Copula] if (alpha < 0 & Copula == 1) strict[1] = "No" if (alpha == 0 & Copula == 16) strict[16] = "No" # What is the Range? RANGE = c( "-1|Inf", "1|Inf", "-1|1", "-Inf|inf", "0|1", "0|0.5", "0|Inf", "2|Inf")[No] # Which one is the Limit Copula? limitTitle = rep("NA", times = 22) if (alpha == -1) limitTitle = c( "W ", "NA", "NA", "NA", "NA", "NA", "NA", "NA", "NA", "NA", "NA", "NA", "NA", "NA", "NA", "NA", "Pi", "NA", "NA", "NA", "NA", "NA") if (alpha == 0) limitTitle = c( "Pi", "NA", "Pi", "NA", "Pi", "NA", "W ", "NA", "Pi", "Pi", "Pi", "NA", "NA", "NA", "NA", "W ", "NA", "NA", "L ", "Pi", "NA", "Pi") if (alpha == 1) limitTitle = c( "L ", "W ", "L ", "Pi", "NA", "Pi", "Pi", "W ", "NA", "NA", "NA", "L ", "Pi", "L ", "W ", "NA", "NA", "NA", "NA", "NA", "W ", "NA") limitTitle = limitTitle[Copula] if (limitTitle == "NA") { limitTitle = " " } else { limitTitle = paste(" Copula = ", limitTitle[1]) } # Plot 1 - Kfunc: x = (0:N)/N y = .Kfunc(x = x, alpha = alpha, type = as.character(Copula)) plot(x = x, y = y, ylim = c(0, 1), type = "l", xlab = "t", ylab = "K") title(main = paste("K - Archimedean Copula No:", as.character(Copula), "\nalpha = ", as.character(alpha), " Strict = ", strict, limitTitle)) if (N < 100) points(x = x, y = y, pch = 19, cex = 0.5) y10 = .Kfunc(x = (0:10)/10, alpha = alpha, type = as.character(Copula)) invK10 = .invK2(y10, alpha = alpha, type = as.character(Copula)) points(invK10, y10, col = "red") text(x = 0.8, y = 0.075, labels = "Test: invK[invK]", col = "red") # Plot 2 - archmTau: tau = .archmTau(alpha = alpha, type = as.character(Copula)) rho = approx(.ALPHA[, Copula], .RHO[, Copula], xout = alpha)$y plot(x = .ALPHA[, Copula], y = .TAU[, Copula], ylim = c(-1, 1), type = "l", col = "red", xlab = paste("alpha: ", RANGE, sep = ""), ylab = "Tau") # points(x = .ALPHA[, Copula], y = .TAU[, Copula], pch = 19, cex = 0.5) lines(x = .ALPHA[, Copula], y = .RHO[, Copula], col = "blue") # points(x = .ALPHA[, Copula], y = .RHO[, Copula], pch = 19, cex = 0.5) points(x = alpha, y = tau, pch = 19, col = "red") abline(h = .archmTauRange(type = as.character(Copula))[1], lty =3, col = "steelblue") abline(h = .archmTauRange(type = as.character(Copula))[2], lty =3, col = "steelblue") points(x = alpha, y = rho, col = "blue", pch = 19) mtext("rho ", 4, col = "blue", cex = 0.75) mtext(" tau", 4, col = "red ", cex = 0.75) title(main = paste("Concordance Measures", "\ntau = ", as.character(round(tau, digits = 2)), "rho = ", as.character(round(rho, digits = 2)) ) ) plot(x = y, y = x, xlim = c(0, 1), type = "l", xlab = "K", ylab = "t") title(main = "Inverse K") # Plot 3 - lambda U: # xTail = 1 - (1/2)^(1:20) # Tail = .archmTail(alpha = alpha, type = as.character(Copula)) # plot(x = xTail, y = Tail$lambdaU.Cuv, col = "blue", # xlim = c(0, 1), ylim = c(0, 1), main = "Tail Dependence") # points(x = xTail, y = Tail$lambdaU.Phi, col = "red", pch = 3) # Rho: # Rho = NULL # for ( a in Alpha) # Rho = c(Rho, archmRho(alpha = a, type = as.character(Copula))) # lines(x = Alpha, y = Rho, type = "l", col = "blue") # rho = archmRho(alpha = alpha, type = as.character(Copula)) # points(x = alpha, y = rho, col = "red", pty = 19) # plot(rnorm(100)) # plot(rnorm(100)) # Reset Frame: par(mfcol = c(2, 2), cex = 0.7) } # Open Slider Menu: setRmetricsOptions(.counter = 0) C1 = "1: [-1,Inf]" C2 = "2-4-6-8-12-14-15-21: [1,Inf)" C3 = "3: [-1,1)" C4 = "5-17: (-Inf,Inf)|{0}" C5 = "7-9-10-22: (0,1]" C6 = "11: (0, 1/2]" C7 = "13-16-19-20: (0,Inf)" C8 = "18: [2, Inf)" C = c( C1, C2, C3, C4, C5, C6, C7, C8 ) L = c( -1, 1, -1, -B, 0, 0, 0, 2 ) U = c( B, 5*B, 1, 5*B, 1, 0.5, B, B ) A = c( 0.5, 2, 0.5, 1, 0.5, 0.2, 1, 3 ) V = rep(0.01, 20) .sliderMenu(refresh.code, names = c("Copula", "N", C), minima = c( 1, 10, L), maxima = c( 22, 1000, U), resolutions = c( 1, 10, V), starts = c( 1, 100, A)) } # ------------------------------------------------------------------------------ .Kfunc <- function(x, alpha = NULL, type = archmList()) { # A function implemented by Diethelm Wuertz # Description: # Computes Density for Archimedean Copulae # Arguments: # x - a numeric vector # FUNCTION: # Type: type = match.arg(type) Type = as.integer(type) # Missing x: if (missing(x)) x = (0:10)/10 # Alpha: if (is.null(alpha)) alpha = archmParam(type)$param # Check alpha: check = archmCheck(alpha, type) # Density: Kfunc = x - .Phi(x, alpha, type) / .PhiFirstDer(x, alpha, type) # Take care from divergencies: Kfunc[is.na(Kfunc)] = 0 Kfunc[x == 1] = 1 # Return Value: Kfunc } # ------------------------------------------------------------------------------ .invK <- function(x, alpha = NULL, type = archmList(), lower = 1.0e-8) { # A function implemented by Diethelm Wuertz # Description: # Computes Inverse of Density for Archimedean Copulae # FUNCTION: # Type: type = match.arg(type) Type = as.integer(type) # Alpha: if (is.null(alpha)) alpha = archmParam(type)$param # Check alpha: check = archmCheck(alpha, type) # Compute Inverse: .fKC = function(x, p, alpha, type) { .Kfunc (x, alpha, type) - p } p = x z = NULL for (P in p) { if (P >= 1){ ## - lower/2) { res = 1 } else if (P <= .Kfunc(0, alpha, type)){ ## + lower/2 ) { res = 0 } else { ## for small values of P (e.g. 1e-5) uniroot can return ## values of 0 despite then above catch due to the numerical precision ## try a cascading increase in precsion to catch this for(pwr in c(0.25,0.5,1)){ res = uniroot(.fKC, c(0,1), p = P, alpha = alpha, type = type,tol=.Machine$double.eps^pwr) if( (res$root - 2*res$estim.prec) > 0 & (res$root + 2*res$estim.prec) < 1 ){ break } } if( (res$root - 2*res$estim.prec < 0) & res$root==0 ){ warning(paste("Inversion close to 0, using default lower value",lower)) res <- lower }else if ( (res$root + 2*res$estim.prec > 1) & res$root==1 ){ warning(paste("Inversion close to 1, using default upper value",1-lower)) res <- 1-lower }else{ res <- res$root } } z = c(z, res) } # Return Value: z } # ------------------------------------------------------------------------------ .invK2 <- function(x, alpha, type = archmList()) { # A function implemented by Diethelm Wuertz # Description: # Computes from tabulated values # FUNCTION: # Type: type = match.arg(type) Type = as.integer(type) # Tabulated Values: iK = NULL for (i in 1:length(x)) { Ord = order(abs(.Kfunc((0:1000)/1000, alpha, type)-x[i]))[1]/1000 iK = c(iK, Ord) } # Return Value: iK } # ------------------------------------------------------------------------------ .makeConcordanceTable <- function(B = 5, dump = FALSE) { # A function implemented by Diethelm Wuertz # Make Table: Counter <- c(1,2,3,2,4,2,5,2,5,5,6,2,7,2,2,7,4,8,7,7,2,5) L = c( -1, +1, -1, -5*B, 0, 0, 0, 2 ) U = c( B, 5*B, 1, 5*B, 1, 0.5, B, B ) Tau = Alpha = Rho = NULL for (i in 1:22) { print(i) No = Counter[i] lower = L[No] upper = U[No] alpha = seq(lower, upper, length = 25) Alpha = cbind(Alpha, alpha) tau = archmTau(alpha = alpha, type = i) rho = archmRho(alpha = alpha, type = i) Tau = cbind(Tau, tau) Rho = cbind(Rho, rho) } .ALPHA = data.frame(Alpha) .TAU = data.frame(Tau) .RHO = data.frame(Rho) colnames(.ALPHA) = colnames(.TAU) = colnames(.RHO) = as.character(1:22) # Dump: if (dump) { dump(".ALPHA", "alpha.R") dump(".TAU", "tau.R") dump(".RHO", "rho.R") } # Return Value: list(ALPHA = .ALPHA, TAU = .TAU, RHO = .RHO) } # ------------------------------------------------------------------------------ ".ALPHA" <- structure(list( "1" = c(-1, -0.75, -0.5, -0.25, 0, 0.25, 0.5, 0.75, 1, 1.25, 1.5, 1.75, 2, 2.25, 2.5, 2.75, 3, 3.25, 3.5, 3.75, 4, 4.25, 4.5, 4.75, 5), "2" = c(1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, 25), "3" = c(-1, -0.916666666666667, -0.833333333333333, -0.75, -0.666666666666667, -0.583333333333333, -0.5, -0.416666666666667, -0.333333333333333, -0.25, -0.166666666666667, -0.0833333333333334, 0, 0.0833333333333333, 0.166666666666667, 0.25, 0.333333333333333, 0.416666666666667, 0.5, 0.583333333333333, 0.666666666666667, 0.75, 0.833333333333333, 0.916666666666667, 1), "4" = c(1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, 25), "5" = c(-25, -22.9166666666667, -20.8333333333333, -18.75, -16.6666666666667, -14.5833333333333, -12.5, -10.4166666666667, -8.33333333333333, -6.25, -4.16666666666666, -2.08333333333333, 0, 2.08333333333334, 4.16666666666667, 6.25, 8.33333333333334, 10.4166666666667, 12.5, 14.5833333333333, 16.6666666666667, 18.75, 20.8333333333333, 22.9166666666667, 25), "6" = c(1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, 25), "7" = c(0, 0.0416666666666667, 0.0833333333333333, 0.125, 0.166666666666667, 0.208333333333333, 0.25, 0.291666666666667, 0.333333333333333, 0.375, 0.416666666666667, 0.458333333333333, 0.5, 0.541666666666667, 0.583333333333333, 0.625, 0.666666666666667, 0.708333333333333, 0.75, 0.791666666666667, 0.833333333333333, 0.875, 0.916666666666667, 0.958333333333333, 1), "8" = c(1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, 25), "9" = c(0, 0.0416666666666667, 0.0833333333333333, 0.125, 0.166666666666667, 0.208333333333333, 0.25, 0.291666666666667, 0.333333333333333, 0.375, 0.416666666666667, 0.458333333333333, 0.5, 0.541666666666667, 0.583333333333333, 0.625, 0.666666666666667, 0.708333333333333, 0.75, 0.791666666666667, 0.833333333333333, 0.875, 0.916666666666667, 0.958333333333333, 1), "10" = c(0, 0.0416666666666667, 0.0833333333333333, 0.125, 0.166666666666667, 0.208333333333333, 0.25, 0.291666666666667, 0.333333333333333, 0.375, 0.416666666666667, 0.458333333333333, 0.5, 0.541666666666667, 0.583333333333333, 0.625, 0.666666666666667, 0.708333333333333, 0.75, 0.791666666666667, 0.833333333333333, 0.875, 0.916666666666667, 0.958333333333333, 1), "11" = c(0, 0.0208333333333333, 0.0416666666666667, 0.0625, 0.0833333333333333, 0.104166666666667, 0.125, 0.145833333333333, 0.166666666666667, 0.1875, 0.208333333333333, 0.229166666666667, 0.25, 0.270833333333333, 0.291666666666667, 0.3125, 0.333333333333333, 0.354166666666667, 0.375, 0.395833333333333, 0.416666666666667, 0.4375, 0.458333333333333, 0.479166666666667, 0.5), "12" = c(1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, 25), "13" = c(0, 0.208333333333333, 0.416666666666667, 0.625, 0.833333333333333, 1.04166666666667, 1.25, 1.45833333333333, 1.66666666666667, 1.875, 2.08333333333333, 2.29166666666667, 2.5, 2.70833333333333, 2.91666666666667, 3.125, 3.33333333333333, 3.54166666666667, 3.75, 3.95833333333333, 4.16666666666667, 4.375, 4.58333333333333, 4.79166666666667, 5), "14" = c(1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, 25), "15" = c(1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, 25), "16" = c(0, 0.208333333333333, 0.416666666666667, 0.625, 0.833333333333333, 1.04166666666667, 1.25, 1.45833333333333, 1.66666666666667, 1.875, 2.08333333333333, 2.29166666666667, 2.5, 2.70833333333333, 2.91666666666667, 3.125, 3.33333333333333, 3.54166666666667, 3.75, 3.95833333333333, 4.16666666666667, 4.375, 4.58333333333333, 4.79166666666667, 5), "17" = c(-25, -22.9166666666667, -20.8333333333333, -18.75, -16.6666666666667, -14.5833333333333, -12.5, -10.4166666666667, -8.33333333333333, -6.25, -4.16666666666666, -2.08333333333333, 0, 2.08333333333334, 4.16666666666667, 6.25, 8.33333333333334, 10.4166666666667, 12.5, 14.5833333333333, 16.6666666666667, 18.75, 20.8333333333333, 22.9166666666667, 25), "18" = c(2, 2.125, 2.25, 2.375, 2.5, 2.625, 2.75, 2.875, 3, 3.125, 3.25, 3.375, 3.5, 3.625, 3.75, 3.875, 4, 4.125, 4.25, 4.375, 4.5, 4.625, 4.75, 4.875, 5), "19" = c(0, 0.208333333333333, 0.416666666666667, 0.625, 0.833333333333333, 1.04166666666667, 1.25, 1.45833333333333, 1.66666666666667, 1.875, 2.08333333333333, 2.29166666666667, 2.5, 2.70833333333333, 2.91666666666667, 3.125, 3.33333333333333, 3.54166666666667, 3.75, 3.95833333333333, 4.16666666666667, 4.375, 4.58333333333333, 4.79166666666667, 5), "20" = c(0, 0.208333333333333, 0.416666666666667, 0.625, 0.833333333333333, 1.04166666666667, 1.25, 1.45833333333333, 1.66666666666667, 1.875, 2.08333333333333, 2.29166666666667, 2.5, 2.70833333333333, 2.91666666666667, 3.125, 3.33333333333333, 3.54166666666667, 3.75, 3.95833333333333, 4.16666666666667, 4.375, 4.58333333333333, 4.79166666666667, 5), "21" = c(1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, 25), "22" = c(0, 0.0416666666666667, 0.0833333333333333, 0.125, 0.166666666666667, 0.208333333333333, 0.25, 0.291666666666667, 0.333333333333333, 0.375, 0.416666666666667, 0.458333333333333, 0.5, 0.541666666666667, 0.583333333333333, 0.625, 0.666666666666667, 0.708333333333333, 0.75, 0.791666666666667, 0.833333333333333, 0.875, 0.916666666666667, 0.958333333333333, 1)), .Names = c("1", "2", "3", "4", "5", "6", "7", "8", "9", "10", "11", "12", "13", "14", "15", "16", "17", "18", "19", "20", "21", "22"), row.names = c("1", "2", "3", "4", "5", "6", "7", "8", "9", "10", "11", "12", "13", "14", "15", "16", "17", "18", "19", "20", "21", "22", "23", "24", "25"), class = "data.frame") # ------------------------------------------------------------------------------ ".TAU" <- structure(list( "1" = c(-1, -0.6, -0.333333333333333, -0.142857142857143, 0, 0.111111111111111, 0.2, 0.272727272727273, 0.333333333333333, 0.384615384615385, 0.428571428571429, 0.466666666666667, 0.5, 0.529411764705882, 0.555555555555556, 0.578947368421053, 0.6, 0.619047619047619, 0.636363636363636, 0.652173913043478, 0.666666666666667, 0.68, 0.692307692307692, 0.703703703703704, 0.714285714285714 ), "2" = c(-1, 0, 0.333333333333333, 0.5, 0.6, 0.666666666666667, 0.714285714285714, 0.75, 0.777777777777778, 0.8, 0.818181818181818, 0.833333333333333, 0.846153846153846, 0.857142857142857, 0.866666666666667, 0.875, 0.88235294117647, 0.888888888888889, 0.894736842105263, 0.9, 0.904761904761905, 0.909090909090909, 0.91304347826087, 0.916666666666667, 0.92), "3" = c(-0.181725814826518, -0.168930151452714, -0.155798192853549, -0.142309156210049, -0.128440099024957, -0.114165590552606, -0.0994573153156502, -0.0842835904937131, -0.068608772818993, -0.0523925219034918, -0.0355888743571007, -0.0181450645517658, 0, 0.0189177438301371, 0.0386926132325796, 0.0594257680440222, 0.0812402882884418, 0.104288760957381, 0.128764787039966, 0.154921339236023, 0.183102048111355, 0.21379958230518, 0.247780252512751, 0.286418218456134, 0.333333333333333), "4" = c(0, 0.5, 0.666666666666667, 0.75, 0.8, 0.833333333333333, 0.857142857142857, 0.875, 0.888888888888889, 0.9, 0.909090909090909, 0.916666666666667, 0.923076923076923, 0.928571428571429, 0.933333333333333, 0.9375, 0.941176470588235, 0.944444444444444, 0.947368421052632, 0.95, 0.952380952380952, 0.954545454545455, 0.956521739130435, 0.958333333333333, 0.96), "5" = c(-0.85052757802554, -0.837983233335134, -0.823159712179848, -0.805382359321779, -0.78368703586404, -0.756652338202137, -0.722109024177686, -0.676626253020113, -0.61461896491917, -0.527006789744252, -0.400406496234527, -0.222118698154441, 0, 0.222118698154449, 0.400406496234539, 0.527006789744276, 0.614618964919029, 0.676626253020132, 0.722109024177453, 0.756652338200781, 0.783687035871101, 0.805382359356256, 0.823159712267863, 0.837983231749698, 0.850527554271354), "6" = c(0, 0.355065933151777, 0.517962498229816, 0.613705638974404, 0.677220914237255, 0.722592092430507, 0.756685017415291, 0.783274098241282, 0.80461673005689, 0.822148933158253, 0.836832638206725, 0.84932812611196, 0.860110789048376, 0.869526200860125, 0.877832575748863, 0.885224248904, 0.891855111133839, 0.897842192832803, 0.903279485909824, 0.90824351995753, 0.912795085448852, 0.91698501728904, 0.920858299365945, 0.924445190119985, 0.927779794217425), "7" = c(1, 0.971927944913947, 0.943246768509585, 0.913923522796783, 0.88392216030227, 0.853203097878133, 0.821722695867944, 0.789432631089395, 0.756279135134686, 0.722202059745913, 0.687133717127867, 0.65099742284623, 0.613705638880109, 0.575157568479307, 0.535235982291939, 0.493802937831557, 0.450693855665945, 0.40570906309108, 0.358601253084469, 0.309055967047944, 0.256659242461756, 0.200839120747762, 0.140745344631603, 0.0749411953484011, 0), "8" = c(-1, -0.333333333333333, -0.111111111111111, 0, 0.0666666666666667, 0.111111111111111, 0.142857142857143, 0.166666666666667, 0.185185185185185, 0.2, 0.212121212121212, 0.222222222222222, 0.230769230769231, 0.238095238095238, 0.244444444444444, 0.25, 0.254901960784314, 0.259259259259259, 0.263157894736842, 0.266666666666667, 0.26984126984127, 0.272727272727273, 0.275362318840580, 0.277777777777778, 0.28), "9" = c(0, -0.0204163452169608, -0.0400596555238257, -0.0590081036085306, -0.0773261331388824, -0.0950679058715638, -0.112279639253442, -0.129001262402105, -0.145267629233813, -0.161109431296128, -0.176553899922191, -0.191625356399165, -0.206345649900960, -0.220734510872628, -0.234809839618285, -0.24858794447726, -0.262083740255211, -0.275310914946985, -0.288282070892981, -0.301008845122611, -0.313502012606631, -0.325771575362601, -0.337826839765094, -0.349676483955214, -0.361328616888101), "10" = c(0, -0.0196066744396921, -0.0370221472721557, -0.0525703541709941, -0.0665070136005856, -0.0790393052012712, -0.0903383149316412, -0.100547418134766, -0.109788190716896, -0.118164725554978, -0.125766872846962, -0.132672728007605, -0.138950577833938, -0.144660447061511, -0.149855344023087, -0.154582275706178, -0.158883083359664, -0.162795136572255, -0.166351914405464, -0.16958349544035, -0.172516973673804, -0.175176813539516, -0.177585154568996, -0.179762074101597, -0.181725814826518), "11" = c(0, -0.0208398943709387, -0.0417175967562695, -0.0626672066307008, -0.083719725295789, -0.104903822366714, -0.126246401393688, -0.147773031839223, -0.169508288800322, -0.191476027240807, -0.213699608737601, -0.236202093256811, -0.259006404912340, -0.282135478276679, -0.305612390180847, -0.329460480799121, -0.353703467003579, -0.378365550391214, -0.403471521964720, -0.429046865142757, -0.455117858555391, -0.481711679925032, -0.50885651222745, -0.536581653261374, -0.564917629721708), "12" = c(0.333333333333333, 0.666666666666667, 0.777777777777778, 0.833333333333333, 0.866666666666667, 0.888888888888889, 0.904761904761905, 0.916666666666667, 0.925925925925926, 0.933333333333333, 0.93939393939394, 0.944444444444444, 0.948717948717949, 0.952380952380952, 0.955555555555556, 0.958333333333333, 0.96078431372549, 0.962962962962963, 0.964912280701754, 0.966666666666667, 0.968253968253968, 0.96969696969697, 0.971014492753623, 0.972222222222222, 0.973333333333333), "13" = c(-0.3613289, -0.269528030161219, -0.187585190523704, -0.114164377378166, -0.048139718340646, 0.0114414518639374, 0.0653882965033201, 0.114390646561491, 0.159038737349337, 0.199839382405940, 0.237229274320303, 0.271585960700895, 0.303236932556452, 0.332467174993497, 0.359525461142416, 0.384629615561405, 0.407970929923072, 0.42971787915222, 0.450019258484065, 0.469006839692804, 0.486797626862941, 0.503495777648588, 0.519194244288641, 0.533976179166497, 0.547916141985897), "14" = c(0.333333333333333, 0.6, 0.714285714285714, 0.777777777777778, 0.818181818181818, 0.846153846153846, 0.866666666666667, 0.88235294117647, 0.894736842105263, 0.904761904761905, 0.91304347826087, 0.92, 0.925925925925926, 0.93103448275862, 0.935483870967742, 0.93939393939394, 0.942857142857143, 0.945945945945946, 0.948717948717949, 0.951219512195122, 0.953488372093023, 0.955555555555556, 0.957446808510638, 0.959183673469388, 0.96078431372549), "15" = c(-1, 0.333333333333333, 0.6, 0.714285714285714, 0.777777777777778, 0.818181818181818, 0.846153846153846, 0.866666666666667, 0.88235294117647, 0.894736842105263, 0.904761904761905, 0.91304347826087, 0.92, 0.925925925925926, 0.93103448275862, 0.935483870967742, 0.93939393939394, 0.942857142857143, 0.945945945945946, 0.948717948717949, 0.951219512195122, 0.953488372093023, 0.955555555555556, 0.957446808510638, 0.959183673469388), "16" = c(-1, 0.0199469096156091, 0.129575836560517, 0.180662881950351, 0.210821233719316, 0.230868290892863, 0.245206353296857, 0.255989120788036, 0.264401763304115, 0.271152717969063, 0.276692429117510, 0.281321400174802, 0.285247984614676, 0.288621292351708, 0.291550902234041, 0.294119177987248, 0.296389240808115, 0.298410289410793, 0.300221244635643, 0.301853304387547, 0.303331771457812, 0.304677385016165, 0.305907306382662, 0.307035859574841, 0.308075095038758), "17" = c(-0.505322479883461, -0.495828713697966, -0.48454639378008, -0.470935203584076, -0.454226630515362, -0.433303941761343, -0.406516652894873, -0.371413076160088, -0.324429660012302, -0.26078346047423, -0.175313467887867, -0.0654880362471264, 3, 0.198425450290705, 0.322606327311886, 0.426990238062425, 0.510371695749375, 0.575835676725875, 0.627386508234144, 0.668494514582698, 0.701798032118806, 0.729213683422655, 0.752120712677402, 0.771518248976997, 0.78813985427463), "18" = c(0.333333333333333, 0.372549019607843, 0.407407407407407, 0.43859649122807, 0.466666666666667, 0.492063492063492, 0.515151515151515, 0.536231884057971, 0.555555555555556, 0.573333333333333, 0.58974358974359, 0.604938271604938, 0.619047619047619, 0.632183908045977, 0.644444444444444, 0.655913978494624, 0.666666666666667, 0.676767676767677, 0.686274509803922, 0.695238095238095, 0.703703703703704, 0.711711711711712, 0.719298245614035, 0.726495726495726, 0.733333333333333), "19" = c(0, 0.429836470415013, 0.492561142661991, 0.539699842175544, 0.577243238619945, 0.608200347675897, 0.634340746150618, 0.656827513885057, 0.676426663266239, 0.693706733577166, 0.709084640531406, 0.722877931761809, 0.735333844361156, 0.746648476889695, 0.756979782729611, 0.766456689701118, 0.775185755847842, 0.783255888758933, 0.790741999213658, 0.797707696363886, 0.80420742554753, 0.810288035370101, 0.815990188618369, 0.821349301247486, 0.826396408325272), "20" = c(0.333333333333333, 0.187581702849446, 0.336923464258114, 0.453621153661734, 0.544347004922251, 0.615306486593428, 0.671462346739915, 0.716591196240161, 0.753556906539465, 0.784548776018356, 0.811245341187264, 0.834925230324345, 0.856550987713366, 0.87682562788058, 0.896293707460173, 0.915293066771852, 0.934084281673088, 0.952832982671359, 0.97164182521641, 0.99056793780414, 1.00963608457645, 1.02884861875661, 1.04819318064612, 1.06764664223826, 1.0871818991606), "21" = c(-0.9999999996, 0.227411277761033, 0.475707247837903, 0.594420704044238, 0.666780283574186, 0.716296479239256, 0.752597708588034, 0.780474107458171, 0.80263551556664, 0.820709018127606, 0.835799583394556, 0.848581734688507, 0.859631891238008, 0.869228393597159, 0.877745364348898, 0.885267593021253, 0.8921031172938, 0.89816522529609, 0.903767761397344, 0.908803416914886, 0.913503328379058, 0.917746442778645, 0.921749156268669, 0.925374342563027, 0.92882540945077), "22" = c(8.88178419700125e-16, -0.0204403642205317, -0.0402325966459149, -0.0595398315924127, -0.0784852878388032, -0.09716610551268, -0.115661428244375, -0.134037489701166, -0.152350993933844, -0.170651459100329, -0.18898289917049, -0.207385066034675, -0.225894390250444, -0.244544709719205, -0.263367845858735, -0.282394068127122, -0.301652475612564, -0.321171316316645, -0.340978259249309, -0.361100630626295, -0.381565622756077, -0.402400482266088, -0.423632682913976, -0.445290087203517, -0.467401100271068)), .Names = c("1", "2", "3", "4", "5", "6", "7", "8", "9", "10", "11", "12", "13", "14", "15", "16", "17", "18", "19", "20", "21", "22"), row.names = c("1", "2", "3", "4", "5", "6", "7", "8", "9", "10", "11", "12", "13", "14", "15", "16", "17", "18", "19", "20", "21", "22", "23", "24", "25"), class = "data.frame") # ------------------------------------------------------------------------------ ".RHO" <- structure(list( "1" = c(-1.00148148148148, -0.738747613322986, -0.466622048681987, -0.211687707079451, 0, 0.165652020595619, 0.294857841987463, 0.396806275669875, 0.478390117460797, 0.544587799346395, 0.598994031361846, 0.644231561135091, 0.682240753560612, 0.714478294671625, 0.742053406185035, 0.765822053649082, 0.786452951364207, 0.80447447147138, 0.820308460074897, 0.83429494974631, 0.846710452420334, 0.85778166343474, 0.867695842924806, 0.876608762194626, 0.884650845307784), "2" = c(-1.00148148148148, 0.141567825309872, 0.533448886027939, 0.708244460527527, 0.800738510405266, 0.855438151990562, 0.89038551287057, 0.913977650156251, 0.930840822487669, 0.943140720229384, 0.952367340916965, 0.959636846016786, 0.965337805120064, 0.969884351339425, 0.973637657583298, 0.976727483348096, 0.979298582357153, 0.98146084822125, 0.983296560480555, 0.984868310083549, 0.986245587058835, 0.987459252328268, 0.988521705438795, 0.989457189777394, 0.990285276373145), "3" = c(-0.271064557642169, -0.252157028402899, -0.232714526887962, -0.212705548849901, -0.19209555265805, -0.170846533523001, -0.148916516723668, -0.12625894982673, -0.102821967656877, -0.078547495149129, -0.0533701410712804, -0.0272158181938728, 1.38263885937115e-18, 0.0283745141601889, 0.0580205123349336, 0.0890702417932126, 0.121680672987631, 0.156040852661039, 0.192382519137300, 0.230996069414554, 0.272255880785214, 0.316663434022027, 0.36492869505212, 0.418151365908671, 0.478390117460797), "4" = c(1.38263885937115e-18, 0.682189978639204, 0.848820654347913, 0.912515206140176, 0.943205695413621, 0.960245155358946, 0.970657019434397, 0.977474770619668, 0.982178751195054, 0.985559960479453, 0.98807177913133, 0.989989026203176, 0.99148606893177, 0.99267782385585, 0.993642497101149, 0.994434794399345, 0.99509390407114, 0.995648488592752, 0.996119899908012, 0.996524305455528, 0.99687412690816, 0.997179034157432, 0.99744664490479, 0.997683025382027, 0.997893054234396), "5" = c(-0.972111584358926, -0.967209491068637, -0.960903114161494, -0.952607108183223, -0.941402673140619, -0.925789337989117, -0.903206982408158, -0.869086491837814, -0.814968529644537, -0.725140930480804, -0.573066256464247, -0.328659597722, 1.38263885937115e-18, 0.328659597722, 0.573066256464246, 0.725140930480804, 0.814968529644528, 0.86908649183787, 0.903206982408021, 0.92578933798917, 0.941402673149305, 0.95260710822185, 0.960903114203512, 0.967209491448638, 0.972111584081945), "6" = c(1.38263885937115e-18, 0.504193253656214, 0.700093384009142, 0.798178467968907, 0.854636457142996, 0.890208596051013, 0.914104060707307, 0.930945457506372, 0.943268127871861, 0.952561541134428, 0.95968871558049, 0.966247582643763, 0.970782114931405, 0.976498903835584, 0.979560788569006, 0.98205552457824, 0.993861933959956, 0.99558219645679, 1.00597796784080, 1.00765676774247, 1.03633645236535, 1.03732862637663, 1.03805548919961, 1.05932394767550, 1.06079424267615), "7" = c(-1.00148148148148, -0.979072702331951, -0.956663923182448, -0.934255144032922, -0.910476817558297, -0.885980795610422, -0.86087901234568, -0.834111385459534, -0.806575582990396, -0.777481481481482, -0.747489711934157, -0.715582990397804, -0.682232098765431, -0.646978326474623, -0.60966803840878, -0.570271604938272, -0.528215089163238, -0.482955281207133, -0.434469135802469, -0.381630727023320, -0.323950617283951, -0.259980246913580, -0.187865020576132, -0.104024142661180, 1.38263885937115e-18), "8" = c(-1.00148148148148, -0.382286405036925, -0.114601585715482, 0.0310996982933278, 0.121547108159812, 0.182711347208507, 0.226564943368020, 0.259498634290694, 0.28500277910381, 0.305383082451978, 0.321951896975906, 0.335684240420725, 0.347297689031008, 0.35716340065043, 0.365682214112401, 0.373072635634355, 0.379610561045101, 0.385393549400538, 0.390535446981844, 0.395136786179741, 0.399301204243857, 0.403072768984719, 0.406501170036244, 0.409631031685417, 0.412499583816874), "9" = c(0, -0.0306009955864517, -0.0600171715566712, -0.0883435022143309, -0.115662851324462, -0.14204808424762, -0.167563722488530, -0.192267256145817, -0.216210197252217, -0.239438934387163, -0.261995433039874, -0.283917814885177, -0.305240840989756, -0.325996318037027, -0.346213442292882, -0.365919092784125, -0.385138082715462, -0.403893376291347, -0.422206276681155, -0.440096589759673, -0.457582767389748, -0.474682033331841, -0.4914104943232, -0.507783238435509, -0.523814422470025), "10" = c(0, -0.029390926055108, -0.0554838410175942, -0.0787567884244303, -0.0995948147001642, -0.118312849424028, -0.135171965480742, -0.150391128987132, -0.164155854619207, -0.176624701885803, -0.187934236009538, -0.198202876118343, -0.207533922658104, -0.216017969401489, -0.223734847121171, -0.230755205988202, -0.237141815823774, -0.24295064350982, -0.248231752581214, -0.253030059585575, -0.257385974070141, -0.261335943265486, -0.264912918148678, -0.268146754209015, -0.271064557642169), "11" = c(0, -0.0312337307463261, -0.0624885635341056, -0.0937774571924054, -0.125109119631511, -0.156488211337586, -0.187915529826987, -0.219388201730151, -0.250899897834131, -0.282441141124533, -0.313999597626781, -0.345560474009285, -0.377106883941072, -0.408620285268396, -0.440080745221534, -0.471467680629385, -0.502759810642414, -0.533935835408547, -0.564973896022694, -0.595854502689236, -0.626555877382724, -0.657058974751787, -0.687347683323, -0.717399152001416, -0.747202834006994), "12" = c(0.478390117460797, 0.847457484412861, 0.929514118116192, 0.959770189940577, 0.974091289816988, 0.98196494553155, 0.98674930920016, 0.989872618006014, 0.992024786623663, 0.99357184100672, 0.994722476491513, 0.995602679183581, 0.99629212083331, 0.996843164325584, 0.99729136172679, 0.99766153224032, 0.997971424587865, 0.998234001133303, 0.998458905801764, 0.998653432689402, 0.998823180355318, 0.998972503148868, 0.99910482845359, 0.99922288351134, 0.999328860123071), "13" = c(8.60444444444445, -0.396927340010433, -0.279041044592502, -0.170790656731972, -0.0721889092723266, 0.0171559644885065, 0.0978612488308676, 0.170645482690321, 0.236250585187531, 0.295396788789730, 0.34875879445432, 0.396954947814539, 0.440544088483541, 0.480026728592929, 0.515848521579894, 0.548404801961588, 0.578045482558421, 0.605079904444685, 0.629781421965416, 0.652391617354311, 0.673124105746233, 0.692167929492244, 0.709690561612045, 0.725840548723069, 0.740749828053321), "14" = c(0.478390117460797, 0.78697038487367, 0.88669651583035, 0.930158273783357, 0.952781313104883, 0.966001646844378, 0.97438037870724, 0.98001921761715, 0.983993663292466, 0.98689971728531, 0.989089008338032, 0.990779746538743, 0.992113107410875, 0.99318367420424, 0.99405672549771, 0.994778481699574, 0.995382405409204, 0.995893200807138, 0.996329424259493, 0.996705230895822, 0.9970315690086, 0.997317013020675, 0.99756835474172, 0.997791029818825, 0.997989429828517), "15" = c(-1.00148148148148, 0.483330421553014, 0.788592827249555, 0.887213491121673, 0.930351139068034, 0.952863855394297, 0.966040941166183, 0.974400661352683, 0.980030344652669, 0.984000050201677, 0.98690350529195, 0.989091305340107, 0.990781156959334, 0.992113975575947, 0.993184203332592, 0.99405703905789, 0.994778656516628, 0.995382490232112, 0.99589322707115, 0.996329412502773, 0.996705194678632, 0.9970315173572, 0.997316951978555, 0.997568288369395, 0.997790960846676), "16" = c(-1.00148148148148, 0.0399918107572716, 0.196922447742505, 0.269217972641498, 0.311479910536255, 0.339361834072764, 0.359187127162052, 0.374027186155748, 0.385561510047341, 0.394788531585647, 0.402340078994373, 0.408635928417183, 0.41396608392397, 0.418537431930041, 0.422501583532575, 0.425972210130218, 0.429036230512499, 0.431761254762484, 0.434200670669304, 0.436397200953502, 0.438385442597004, 0.440193712932073, 0.441845413865275, 0.443360054973381, 0.444754031079707), "17" = c(-0.644683937053512, -0.638242233699325, -0.63002248705626, -0.619327391403488, -0.605102498262373, -0.585717699732245, -0.558611529498344, -0.519748499835421, -0.462935375218991, -0.379451494373527, -0.259494676315209, -0.0980201065759068, -2.86814814814815, 0.294555695013013, 0.469764827999549, 0.606508141811551, 0.705924049580753, 0.776198676767287, 0.825867405611722, 0.86149149285161, 0.887580315101809, 0.907115201815617, 0.922057497657996, 0.933711847666972, 0.942961892529542), "18" = c(0.579165030761005, 0.612486124687689, 0.641987920637447, 0.668204867084776, 0.691471975626513, 0.712672417787934, 0.731485428240074, 0.748541425177017, 0.763998843765579, 0.7781439158238, 0.79107000000924, 0.802825120690881, 0.81347401988651, 0.823349095595444, 0.832637848646758, 0.841114775574677, 0.848922542682376, 0.85620758378877, 0.862952434000152, 0.869158594153996, 0.87492608635104, 0.880415774029804, 0.885630004240057, 0.890455816493047, 0.894963682434538), "19" = c(0.478390117460797, 0.593310952911897, 0.663998561233565, 0.71419945722106, 0.752174890526936, 0.782049472476609, 0.806205285404551, 0.826145083754451, 0.842875473608911, 0.857101027367348, 0.869331955302181, 0.87994792140256, 0.889237849471334, 0.897425790062242, 0.904688304851229, 0.911166484840908, 0.916974461375408, 0.922205560262668, 0.926936833441981, 0.931232450014748, 0.935146270324233, 0.938723825147773, 0.942003855222286, 0.9450195214372, 0.947799365319983), "20" = c(0, 0.276598221109225, 0.480091816919932, 0.62207813892774, 0.720105357077801, 0.788404490421694, 0.83684648649206, 0.871903512170082, 0.897785391284217, 0.917254967437719, 0.932155415374907, 0.94373844195542, 0.952871658197302, 0.960166062946691, 0.96606101324546, 0.970874376612312, 0.974843755028167, 0.978145796062885, 0.98091616915103, 0.983256097985314, 0.985247325406535, 0.986952155066644, 0.988421752891467, 0.98969341361155, 0.990800873367999), "21" = c(-1.00148148148148, 0.347129116118547, 0.65564069685479, 0.780803624460825, 0.846443027861398, 0.885838814250034, 0.911560842980429, 0.929365274007805, 0.942234840854385, 0.951833301777067, 0.96008770231504, 0.965881283889428, 0.97252949040583, 0.97634531326702, 0.979070799707118, 0.99154650629721, 0.993599496406914, 1.00432643751157, 1.00555767252712, 1.03505473383290, 1.03618596470961, 1.05759086565101, 1.05873221403231, 1.11481166665537, 1.11507652990229), "22" = c(0, -0.0306367173028787, -0.0602746511903028, -0.0891338848924438, -0.117379804930934, -0.145140408516369, -0.172516725392443, -0.199589475575909, -0.226423523248459, -0.253070965533168, -0.279573384360126, -0.30596355638433, -0.332266726350362, -0.358501732266778, -0.384681876941774, -0.410815779550173, -0.436907762333632, -0.462959276965944, -0.488968041367581, -0.514929666432483, -0.540839175128809, -0.566687136331552, -0.592466001518449, -0.618164814543992, -0.643774208533738)), .Names = c("1", "2", "3", "4", "5", "6", "7", "8", "9", "10", "11", "12", "13", "14", "15", "16", "17", "18", "19", "20", "21", "22"), row.names = c("1", "2", "3", "4", "5", "6", "7", "8", "9", "10", "11", "12", "13", "14", "15", "16", "17", "18", "19", "20", "21", "22", "23", "24", "25"), class = "data.frame") ################################################################################ fCopulae/R/EllipticalModelling.R0000644000176200001440000001363614265245633016274 0ustar liggesusers # 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: ELLIPTICAL COPULAE PARAMETER FITTING: # ellipticalCopulaSim Simulates bivariate elliptical copula # ellipticalCopulaFit Fits the paramter of an elliptical copula ################################################################################ ################################################################################ # FUNCTION: ELLIPTICAL COPULAE PARAMETER FITTING: # ellipticalCopulaSim Simulates bivariate elliptical copula # ellipticalCopulaFit Fits the paramter of an elliptical copula ellipticalCopulaSim <- function (n, rho = 0.75, param = NULL, type = c("norm", "cauchy", "t")) { # A function implemented by Diethelm Wuertz # Description: # Simulates bivariate elliptical Copula # Match Arguments: type = match.arg(type) # "norm" Random Deviates: if (type == "norm") { ans = .rnormCopula(n = n, rho = rho) } # "cauchy" Random Deviates: if (type == "cauchy") { ans = .rcauchyCopula(n = n, rho = rho) } # "t" Random Deviates: if (type == "t") { if (is.null(param)) { param = c(nu = 4) } else { param = c(nu = param[1]) } ans = .rtCopula(n = n, rho = rho, nu = param) } # "logistic" Random Deviates: # NOT YET IMPLEMENTED ... # "laplace" Random Deviates: # NOT YET IMPLEMENTED ... # "kotz" Random Deviates: # NOT YET IMPLEMENTED ... # "epower" Random Deviates: # NOT YET IMPLEMENTED ... # Control: control = list(rho = rho, param = param, type = type) attr(ans, "control") = unlist(control) # Return Value: ans } # ------------------------------------------------------------------------------ ellipticalCopulaFit <- function(u, v = NULL, type = c("norm", "cauchy", "t"), ...) { # A function implemented by Diethelm Wuertz # Description: # Fits the paramter of an elliptical copula # Note: # The upper limit for nu is 100 # FUNCTION: # Match Arguments: type = match.arg(type) # Settings: U = u V = v if (is.list(u)) { u = u[[1]] v = u[[2]] } if (is.matrix(u)) { U = u[, 1] V = u[, 2] } U <<- u V <<- v # Estimate Rho from Kendall's tau for all types of Copula: tau = cor(x = U, y = V, method = "kendall") #[1, 2] Rho = rho = sin((pi*tau/2)) # Specify Bounds to be < and > instead of <= and >= upper <- 1-.Machine$double.eps lower <- -upper # Estimate "norm" Copula: if (type == "norm") { fun = function(x) { -mean( log(.dnormCopula(u = U, v = V, rho = x)) ) } fit = nlminb(start = rho, objective = fun, lower = lower, upper = upper, control = list(trace=TRUE), ...) } # Estimate "cauchy" Copula: if (type == "cauchy") { fun = function(x) { -mean( log(.dcauchyCopula(u = U, v = V, rho = x)) ) } fit = nlminb(start = rho, objective = fun, lower = lower, upper = upper, ...) } # Estimate "t" Copula: if (type == "t") { fun = function(x) { -mean( log(.dtCopula(u = U, v = V, rho = x[1], nu = x[2])) ) } fit = nlminb(start = c(rho = rho, nu = 4), objective = fun, lower = c(lower, upper), upper = c(upper, Inf), ...) fit$Nu = 4 } # Estimate "logistic" Copula: if (type == "logistic") { # NOT YET IMPLEMENTED ... fun = function(x) { -mean( log(dellipticalCopula(u = U, v = V, ...)) ) } fit = nlminb(start = c(), objective = fun, lower = c(rho = lower, NA), upper = c(rho = upper, NA), ...) } # Estimate "laplace" Copula: if (type == "laplace") { # NOT YET IMPLEMENTED ... fun = function(x) { -mean( log(dellipticalCopula(u = U, v = V, ...)) ) } fit = nlminb(start = c(), objective = fun, lower = c(rho = lower, NA), upper = c(rho = upper, NA), ...) } # Estimate "kotz" Copula: if (type == "kotz") { # NOT YET IMPLEMENTED ... fun = function(x) { -mean( log(dellipticalCopula(u = U, v = V, ...)) ) } fit = nlminb(start = c(), objective = fun, lower = c(rho = lower, NA), upper = c(rho = upper, NA), ...) } # Estimate "epower" Copula: if (type == "epower") { # NOT YET IMPLEMENTED ... fun = function(x) { -mean( log(dellipticalCopula(u = U, v = V, ...)) ) } fit = nlminb(start = c(), objective = fun, lower = c(rho = lower, NA), upper = c(rho = upper, NA), ...) } # Keep Start Value: # fit$Rho = Rho # Return Value: fit } ################################################################################ fCopulae/R/ArchimedeanModelling.R0000644000176200001440000000610414354770370016402 0ustar liggesusers # 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: ARCHIMEDEAN COPULAE PARAMETER FITTING: # archmCopulaSim Simulates bivariate elliptical copula # archmCopulaFit Fits the paramter of an elliptical copula ################################################################################ ################################################################################ # FUNCTION: ARCHIMEDEAN COPULAE PARAMETER FITTING: # archmCopulaSim Simulates bivariate elliptical copula # archmCopulaFit Fits the paramter of an elliptical copula archmCopulaSim <- function (n, alpha = NULL, type = archmList()) { # A function implemented by Diethelm Wuertz # Description: # Simulates bivariate elliptical Copula # Match Arguments: type <- match.arg(type) Type <- as.integer(type) # Settings: if (is.null(alpha)) alpha = archmParam(type)$param # Random Variates: ans <- rarchmCopula(n = n, alpha = alpha, type = type) # Control: control = list(alpha = alpha[[1]], copula = "archm", type = type) attr(ans, "control")<-unlist(control) # Return Value: ans } # ------------------------------------------------------------------------------ archmCopulaFit <- function(u, v = NULL, type = archmList(), ...) { # A function implemented by Diethelm Wuertz # Description: # Fits the paramter of an elliptical copula # Note: # The upper limit for nu is 100 # FUNCTION: # Match Arguments: type = match.arg(type) Type = as.integer(type) # Settings: U = u V = v if (is.list(u)) { U = u[[1]] V = u[[2]] } if (is.matrix(u)) { U = u[, 1] V = u[, 2] } # Estimate Rho from Kendall's tau for all types of Copula: alpha = archmParam(type)$param # Estimate Copula: fun = function(x, type, U, V) { -mean( log(darchmCopula(u = U, v = V, alpha = x, type = type)) ) } range = archmRange(type) fit = nlminb(start = alpha, objective = fun, lower = range[1], upper = range[2], type = type, U = U, V = V, ...) # Return Value: fit } ################################################################################ fCopulae/R/aaaCopulaeClass.R0000644000176200001440000001657214265245633015402 0ustar liggesusers # 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: COPULA SPECIFICATION: # fCOPULA S4 class representation # show S4 print method for copula specification # FUNCTION: FRECHET COPULA: # pfrechetCopula Computes Frechet copula probability # FUNCTION: SPEARMAN'S RHO: # .copulaRho Spearman's rho by integration for "ANY" copula ################################################################################ ################################################################################ setClass("fCOPULA", # Description: # Specifying and creating copula objects # Copula Representation: representation( call = "call", copula = "character", param = "list", title = "character", description = "character") ) # ------------------------------------------------------------------------------ setMethod("show", "fCOPULA", function(object) { # A function implemented by Diethelm Wuertz # Description: # Print and Summary method for fCOPULA # Source: # This function copies code from base:print.htest # FUNCTION: # Unlike print the argument for show is 'object'. x = object # Title: cat("\nTitle:\n ", x@title, "\n", sep = "") # Call: cat("\nCall:\n ") cat(paste(deparse(x@call), sep = "\n", collapse = "\n"), "\n", sep = "") # Copula Type: cat("\nCopula:\n ", x@copula, "\n", sep = "") # Model Parameter: if (length(x@param) != 0) { cat("\nModel Parameter(s):\n ") print(unlist(x@param), quote = FALSE) } # Description: cat("\nDescription:\n ", x@description, sep = "") cat("\n\n") # Return Value: invisible(object) }) ################################################################################ # Frechet Copulae: pfrechetCopula <- function(u = 0.5, v = u, type = c("m", "pi", "w"), output = c("vector", "list")) { # A function implemented by Diethelm Wuertz # Description: # Computes Frechet copula probability # Arguments: # u, v - two numeric values or vectors of the same length at # which the copula will be computed. If 'u' is a list then the # the '$x' and '$y' elements will be used as 'u' and 'v'. # If 'u' is a two column matrix then the first column will # be used as 'u' and the the second as 'v'. # type - the type of the Frechet copula. A character # string selected from: "m", "pi", or "w". # output - a character string specifying how the output should # be formatted. By default a vector of the same length as # 'u' and 'v'. If specified as "list" then 'u' and 'v' are # expected to span a two-dimensional grid as outputted by the # function 'grid2d' and the function returns a list with # elements '$x', 'y', and 'z' which can be directly used # for example by 2D plotting functions. # Examples: # persp(pfrechetCopula(u=grid2d(), output="list", type = "m")) # persp(pfrechetCopula(u=grid2d(), output="list", type = "pi")) # persp(pfrechetCopula(u=grid2d(), output="list", type = "w")) # FUNCTION: # Match Arguments: type = type[1] # Allow for "psp" ... # type = match.arg(type) output = match.arg(output) # Settings: if (is.list(u)) { v = u[[2]] u = u[[1]] } if (is.matrix(u)) { v = u[, 1] u = u[, 2] } # Compute Copula Probability: if (type == "m") { # C(u,v) = min(u,v) C.uv = apply(cbind(u, v), 1, min) } if (type == "pi") { # C(u, v) = u * v C.uv = u * v } if (type == "w") { # C(u,v) = max(u+v-1, 0) C.uv = apply(cbind(X = u+v-1, Y = rep(0, length = length(u))), 1, max) } if (type == "psp") { # C(u,v) = u*v/(u+v-u*v) C.uv = u*v/(u+v-u*v) } # Add Control: attr(C.uv, "control") <- unlist(list(type = type)) # As List ? if (output == "list") { N = sqrt(length(u)) x = u[1:N] y = matrix(v, ncol = N)[1, ] C.uv = list(x = x, y = y, z = matrix(C.uv, ncol = N)) } # Return Value: C.uv } ################################################################################ .copulaRho = function(rho = NULL, alpha = NULL, param = NULL, family = c("elliptical", "archm", "ev", "archmax"), type = NULL, error = 1e-3, ...) { # A function implemented by Diethelm Wuertz # Description: # Spearman's rho by integration for "ANY" copula # Notes: # pellipticalCopula(u, v, rho, param, type, output, border) # parchmCopula (u, v, alpha, type, output, alternative) # pevCopula (u, v, param, type, output, alternative) # parchmaxCopula (u, v, param, type, output ) # Examples: # .copulaRho(rho = 0.5, family = "elliptical", type = "norm") # .copulaRho(alpha = 1, family = "archm", type = "1") # .copulaRho(param = 2, family = "ev", type = "galambos") # FUNCTION: # Match Arguments: family = match.arg(family) # Type: if (is.null(type)) { family = "elliptical" type = "norm" } else { type = as.character(type) } # 2D Function to be integrated: rho <<- rho alpha <<- alpha param <<- param type <<- type if (family == "elliptical") { dCopulaRho <- function(x, y) { C = pellipticalCopula(x, y, rho = rho, param = param, type = type) 12 * (C - x*y ) } } else if (family == "archm") { if (is.null(alpha)) alpha <<- archmParam(type)$param check = archmCheck(alpha, type) dCopulaRho <- function(x, y) { C = parchmCopula(x, y, alpha = alpha, type = type) 12 * (C - x*y ) } } else if (family == "ev") { dCopulaRho <- function(x, y) { C = pevCopula(x, y, param = param, type = type) 12 * (C - x*y ) } } # else if (family == "archmax") { # dCopulaRho <- function(x, y) { # C = parchmaxCopula(x, y, param = param, type = type) # 12 * (C - x*y ) # } # } # Integrate: ans = integrate2d(dCopulaRho, error = error) Rho = ans$value error = ans$error # Result: control = list(rho = rho, alpha = alpha, param = param, family = family, type = type, error = signif(error, 3)) attr(Rho, "control") <- unlist(control) # Return Value: Rho } ################################################################################ fCopulae/R/ExtremeValueGenerator.R0000644000176200001440000006046314265245633016634 0ustar liggesusers # 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: EXTREME VALUE COPULAE PARAMETER: # evList Returns list of implemented extreme value copulae # evParam Sets Default parameters for an extreme value copula # evCheck Checks if parameters are in the valid range # evRange Returns the range of valid parameter values # FUNCTION: EXTREME VALUE COPULAE GENERATOR FUNCTION: # Afunc Computes Dependence function # AfuncSlider Displays interactively dependence function # .AfuncFirstDer Computes Derivative of dependence function # .AfuncSecondDer Computes 2nd Derivative of dependence function ################################################################################ ################################################################################ # FUNCTION: EXTREME VALUE COPULAE PARAMETER: # evList Returns list of implemented extreme value copulae # evParam Sets parameters for an extreme value copula # evRange Returns the range of valid parameter values # evCheck Checks if parameters are in the valid range evList = function() { # A function implemented by Diethelm Wuertz # Description: # Returns list of implemented extreme value copulae # Compose List: ans = c("gumbel", "galambos", "husler.reiss", "tawn", "bb5") # Return Value: ans } # ------------------------------------------------------------------------------ evParam = function(type = evList()) { # A function implemented by Diethelm Wuertz # Description: # Sets default parameters for extreme value copulae # Arguments: # type - a character string naming the copula. By default the # "gumbel" copula will be chosen. # Value: # returns a list with two elements, 'param' sets the parameters # which may be a vector, 'range' the range with minimum and # maximum values for each of the parameters. For the "pi" and # "m" copula NULL will be returned. # FUNCTION: # Settings: type = match.arg(type) ans = list(copula = type) # Select: if ( type == "gumbel" ) { ans$param = c(delta = 2) ans$range = c(1, Inf) } if ( type == "galambos" ) { ans$param = c(delta = 2) ans$range = c(0, Inf) } if ( type == "husler.reiss" ) { ans$param = c(delta = 2) ans$range = c(0, Inf) } if ( type == "tawn" ) { ans$param = c(alpha = 2, beta = 1/2, r = 2) ans$range = c(0, 1, 0, 1, 1, Inf) } if ( type == "bb5" ) { ans$param = c(delta = 2, theta = 2) ans$range = c(0, Inf, 0, Inf) } # Some more, yet untested and undocumented: if ( type == "gumbelII" ) { ans$param = c(alpha = 2) ans$range = NULL } if ( type == "marshall.olkin" ) { ans$param = c(alpha1 = 2, alpha2 = 2) ans$range = NULL } if ( type == "pi" ) { ans$param = NULL ans$range = NULL } if ( type == "m" ) { ans$param = NULL ans$range = NULL } # Return Value: ans } # ------------------------------------------------------------------------------ evRange = function(type = evList()) { # A function implemented by Diethelm Wuertz # Description: # Returns the range of valid parameter values # Examples: # evRange("galambos") # evRange("bb5") # FUNCTION: # Type: type = match.arg(type) # Range: ans = evParam(type)$range Names1 = rep(c("lower", "upper"), times = length(ans)/2) Names2 = rep(names(evParam(type)$param), each = 2) names(ans) = paste(Names1, Names2, sep = ".") attr(ans, "control")<-type # Return Value: ans } # ------------------------------------------------------------------------------ evCheck = function(param, type = evList()) { # A function implemented by Diethelm Wuertz # Description: # Checks if parameters are in the valid range # FUNCTION: # Type: type = match.arg(type) # Check range = evRange(type) nParam = length(range)/2 j = -1 J = 0 for (i in 1:nParam) { j = j + 2 J = J + 2 if (param[i] < range[j] | param[i] > range[J]) { print(c(param = param[i])) print(c(range = c(range[j], range[J]))) stop("param is out of range") } } # Return Value: invisible(TRUE) } ################################################################################ # FUNCTION: EXTREME VALUE COPULAE GENERATOR FUNCTION: # Afunc Computes Dependence function # AfuncSlider Displays interactively dependence function # .AfuncFirstDer Computes Derivative of dependence function # .AfuncSecondDer Computes 2nd Derivative of dependence function Afunc = function(x, param = NULL, type = evList()) { # A function implemented by Diethelm Wuertz # Description: # Computes dependence function for extreme value copulae # Arguments: # x - a numeric vector, with values ranging between # zero and one # param - numeric parameter vector, if set to NULL then # default values are taken # type - character string naming the type of copula, # by default "gumbel" # Details: # Extreme Value Copulae can be represented in the form # # C(u,v) = exp { log(uv)*A[log(u)/log(uv)] } # # where A:[0,1] -> [1/2,1] is a convex function # such that max(x,1-x) < A(x) < 1 for all x in [0,1]. # Notes: # Copulae included also in EVANESCE: # gumbel, galambos, husler.reiss, tawn, bb5 # Additionally - not yet tested and documented # gumbelII, marshall.olkin, pi[Cperp], m[Cplus] # References: # Bouye E. (2000), Copulas for Finance: A Reading Guide and # Some Applications, (see the Table on page 49). # Insightful Corp, EVANESCE Implementation in S-PLUS # FinMetrics Module. # FUNCTION: # Missing x: if (missing(x)) x = (0:10)/10 # Type: type = type[1] if (is.null(param)) param = evParam(type)$param names(param) = names(evParam(type)$param) # Compute Dependence Function: if (type == "gumbel") { # 1 <= alpha < Inf alpha = param[1] if (alpha == 1) A = rep(1, times = length(x)) else A = (x^alpha + (1-x)^alpha)^(1/alpha) } if (type == "galambos") { # 0 <= alpha < Inf alpha = param[1] A = 1 - (x^(-alpha) + (1-x)^(-alpha))^(-1/alpha) } if (type == "husler.reiss") { # 0 <= alpha <= Inf alpha = param[1] A = x * pnorm(1/alpha + 0.5*alpha*log(x/(1-x))) + (1-x) * pnorm(1/alpha - 0.5*alpha*log(x/(1-x))) } if (type == "tawn") { # 0 <= alpha <=1 # 0 <= beta <= 1 # 1 <= r < Inf alpha = param[1] beta = param[2] r = param[3] if (alpha == 0 | beta == 0 | r == 1) A = rep(1, times = length(x)) else A = 1 - beta +(beta-alpha)*x + ( (alpha*x)^r + (beta*(1-x))^r )^(1/r) } if (type == "bb5") { # 0 < delta < Inf # 1 <= theta Inf delta = param[1] theta = param[2] if (theta == 1) return(Afunc(x, param, "galambos")) else A = ( x^theta + (1-x)^theta - ( x^(-delta*theta) + (1-x)^(-delta*theta) )^(-1/delta))^(1/theta) } # Some more, yet untested and undocumented: if (type == "gumbelII") { # 0 <= alpha < Inf alpha = param[1] A = alpha*x^2 - alpha*x + 1 } if (type == "marshall.olkin") { alpha1 = param[1] alpha2 = param[2] A = NULL for (i in 1:length(x)) A = c(A, max(1-alpha1*x[i], 1-alpha2*(1-x[i]))) } if (type == "pi" || type == "Cperp") { # No parameters A = rep(1, times = length(x)) } if (type == "m" || type == "Cplus") { # No parameters A = NULL for (i in 1:length(x)) A = c(A, max(x[i], 1-x[i])) } # Result: attr(A, "control") <- unlist(list(param = param, type = type)) # Return Value: A } # ------------------------------------------------------------------------------ AfuncSlider = function() { # A function implemented by Diethelm Wuertz # Description: # Displays interactively the dependence function # Graphic Frame: par(mfrow = c(2, 2), cex = 0.7) # Internal Function: refresh.code = function(...) { # Startup Counter: .counter <- getRmetricsOptions(".counter") + 1 setRmetricsOptions(.counter = .counter) if (.counter < 10) return () # Sliders: Type = evList() Copula = .sliderMenu(no = 1) N = .sliderMenu(no = 2) if (Copula <= 3) param = c(delta = .sliderMenu(no = Copula + 2)) if (Copula == 4) param = c(alpha = .sliderMenu(no = 6), beta = .sliderMenu(no = 7), r = .sliderMenu(no = 8)) if (Copula == 5) param = c(delta = .sliderMenu(no = 9), theta = .sliderMenu(no = 10)) # Title: type = Type[Copula] subTitle = paste(paste(names(param) , "="), param, collapse = " | " ) Title = paste(" ", type, "\n", subTitle) # Plot A: plot(x = (0:N)/N, Afunc(x = (0:N)/N, param = param, type = type), ylim = c(0.5, 1), type = "l", xlab = "x", ylab = "A", main = Title) lines(c(0.0, 1.0), c(1.0, 1.0), col = "steelblue", lty = 3) lines(c(0.0, 0.5), c(1.0, 0.5), col = "steelblue", lty = 3) lines(c(0.5, 1.0), c(0.5, 1.0), col = "steelblue", lty = 3) points(x = c(0, 1), Afunc(x = c(0, 1), param = param, type = type), col = "red") # Plot A': plot(x = (0:N)/N, .AfuncFirstDer(x = (0:N)/N, param = param, type = type), type = "l", xlab = "x", ylab = "A'", main = Title) points(x = c(0, 1), .AfuncFirstDer(x = c(0, 1), param = param, type = type), col = "red") # Plot A'': plot(x = (0:N)/N, .AfuncSecondDer(x = (0:N)/N, param = param, type = type), type = "l", xlab = "x", ylab = "A''", main = Title) points(x = c(0, 1), .AfuncSecondDer(x = c(0, 1), param = param, type = type), col = "red") # Reset Frame: par(mfrow = c(2, 2), cex = 0.7) } # Open Slider Menu: setRmetricsOptions(.counter = 0) C = c("Gumbel: delta", "Galambos: delta", "Husler-Reis: delta", "Tawn: alpha", "... beta", "... r", "BB5: delta", "... theta") .sliderMenu(refresh.code, names = c("Copula", "N", C), #gal hr tawn bb5 minima = c(1, 100, 1.0, 0.00, 0.00, 0.00, 0.00, 1.0, 0.0, 1.0), maxima = c(5, 10000, 10.0, 10.0, 10.0, 1.00, 1.00, 10., 10., 10.), resolutions = c(1, 100, 0.05, 0.05, 0.05, 0.01, 0.01, 0.1, 0.1, 0.1), starts = c(1, 5000, 1.00, 0.00, 0.00, 0.00, 0.00, 1.0, 0.0, 1.0)) } # ------------------------------------------------------------------------------ .AfuncFirstDer = function(x, param = NULL, type = evList(), eps = 1.0e-6 ) { # A function implemented by Diethelm Wuertz # Description: # # Computes derivaive of dependence function # Arguments: # x - a numeric vector, with values ranging between # zero and one # param - numeric parameter vector, if set to NULL then # default values are taken # type - character string naming the type of copula, # by default "gumbel" # Details: # Extreme Value Copulae can be represented in the form # # C(u,v) = exp { log(uv)*A[log(u)/log(uv)] } # # where A:[0,1] -> [1/2,1] is a convex function # such that max(x,1-x) < A(x) < 1 for all x in [0,1]. # Notes: # Copulae included also in EVANESCE: # gumbel, galambos, husler.reiss, tawn, bb5 # Additionally - not yet tested and documented # gumbelII, marshall.olkin, pi[Cperp], m[Cplus] # References: # Bouye E. (2000), Copulas for Finance: A Reading Guide and # Some Applications, (see the Table on page 49). # Insightful Corp, EVANESCE Implementation in S-PLUS # FinMetrics Module. # FUNCTION: # Missing x: if (missing(x)) x = (0:10)/10 # Type: type = type[1] if (is.null(param)) param = evParam(type)$param names(param) = names(evParam(type)$param) # Settings for Maple Output: Pi = pi ln = function(x) { log(x) } erf = function (x) { 2*pnorm(sqrt(2)*x)-1 } # Compute Derivative: if (type == "gumbel") { # alpha >= 1 alpha = param[1] # Maple Generated Output: if (alpha == 1) A1 = rep(0, times = length(x)) else { A1 = (x^alpha+(1-x)^alpha)^(1/alpha)/alpha*(x^alpha*alpha/x-(1-x)^alpha* alpha/(1-x))/(x^alpha+(1-x)^alpha) A1[x < eps] = -1 A1[x > 1-eps] = 1 } } if (type == "galambos") { # 0 <= alpha < Inf alpha = param[1] # Maple Generated Output: if (alpha == 0) A1 = rep(1, times = length(x)) else { A1 = (x^(-alpha)+(1-x)^(-alpha))^(-1/alpha)/alpha*(-x^(-alpha)*alpha/x+( 1-x)^(-alpha)*alpha/(1-x))/(x^(-alpha)+(1-x)^(-alpha)) A1[x < eps] = -1 A1[x > 1-eps] = 1 } } if (type == "husler.reiss") { # 0 <= alpha <= Inf alpha = param[1] # Maple Generated Output: if (alpha == 0) A1 = rep(1, times = length(x)) else { A1 = .5*erf(1/2*(1/alpha+.5*alpha*ln(x/(1-x)))*2^(1/2))+.2500000000/Pi^( 1/2)*exp(-1/2*(1/alpha+.5*alpha*ln(x/(1-x)))^2)*alpha*(1/(1-x)+x/(1 -x)^2)*(1-x)*2^(1/2)-.5*erf(1/2*(1/alpha-.5*alpha*ln(x/(1-x)))*2^(1 /2))-.2500000000*(1-x)^2/Pi^(1/2)*exp(-1/2*(1/alpha-.5*alpha*ln(x/( 1-x)))^2)*alpha*(1/(1-x)+x/(1-x)^2)/x*2^(1/2) A1[x < eps] = -1 A1[x > 1-eps] = 1 } } if (type == "tawn") { # 0 <= alpha < Inf # beta <= 1 # 1 <= r < Inf alpha = param[1] beta = param[2] r = param[3] # Maple Generated Output: if (alpha == 0 | beta == 0 | r == 1) A1 = rep(0, length(x)) else { A1 = beta-alpha+((alpha*x)^r+(beta*(1-x))^r)^(1/r)/r*((alpha*x)^r*r/x-( beta*(1-x))^r*r/(1-x))/((alpha*x)^r+(beta*(1-x))^r) A1[x < eps] = -alpha A1[x > 1-eps] = beta } } if (type == "bb5") { # 0 < delta < Inf # 1 <= theta < Inf delta = param[1] theta = param[2] # Maple Generated Output: if (theta == 1) return(.AfuncFirstDer(x, param, "galambos")) else A1 = (x^theta+(1-x)^theta-(x^(-delta*theta)+(1-x)^(-delta*theta))^(-1/ delta))^(1/theta)/theta*(x^theta*theta/x-(1-x)^theta*theta/(1-x)+(x ^(-delta*theta)+(1-x)^(-delta*theta))^(-1/delta)/delta*(-x^(-delta* theta)*delta*theta/x+(1-x)^(-delta*theta)*delta*theta/(1-x))/(x^(- delta*theta)+(1-x)^(-delta*theta)))/(x^theta+(1-x)^theta-(x^(-delta *theta)+(1-x)^(-delta*theta))^(-1/delta)) A1[x < eps] = -1 A1[x > 1-eps] = 1 } # Some more, yet untested and undocumented: if (type == "gumbelII") { # 0 <= alpha < Inf alpha = param[1] A1 = 2*alpha*x-alpha } if (type == "marshall.olkin") { alpha1 = param[1] alpha2 = param[2] A1 = NULL for (i in 1:length(x)) { if (x[i] < 0) A1 = c(A1, -alpha1) if (x[i] > 0) A1 = c(A1, alpha2) if (x[i] == 0) A1 = c(A1, NA) } } if (type == "pi" || type == "Cperp") { A1 = rep(0, times = length(x)) } if (type == "m" || type == "Cplus") { A1 = sign(x-1/2) } # Result: attr(A1, "control") <- unlist(list(param = param, type = type)) # Return Value: A1 } # ------------------------------------------------------------------------------ .AfuncSecondDer = function(x, param = NULL, type = evList()) { # A function implemented by Diethelm Wuertz # Description: # Computes 2nd derivative of dependence function # Arguments: # x - a numeric vector, with values ranging between # zero and one # param - numeric parameter vector, if set to NULL then # default values are taken # type - character string naming the type of copula, # by default "gumbel" # Details: # Extreme Value Copulae can be represented in the form # # C(u,v) = exp { log(uv)*A[log(u)/log(uv)] } # # where A:[0,1] -> [1/2,1] is a convex function # such that max(x,1-x) < A(x) < 1 for all x in [0,1]. # Note: # The five Copulae considered in EVANESCE are: # gumbel, galambos, husler.reis, tawn, bb5 # Furthermore, added are: # pi|Cperp, gumbelII, marshall.olkin, m|Cplus # References: # Bouye E. (2000), Copulas for Finance: A Reading Guide and # Some Applications, (see the Table on page 49). # Insightful Corp, EVANESCE Implementation in S-PLUS # FinMetrics Module. # FUNCTION: # Missing x: if (missing(x)) x = (0:10)/10 # Type: type = type[1] if (is.null(param)) param = evParam(type)$param names(param) = names(evParam(type)$param) # Settings for Maple Output: Pi = pi ln = function(x) { log(x) } erf = function (x) { 2*pnorm(sqrt(2)*x)-1 } # Compute 2nd Derivative: if (type == "gumbel") { # alpha >= 1 alpha = param[1] # Maple Generated Output: if (alpha == 1) A2 = rep(0, times = length(x)) else A2 = (x^alpha+(1-x)^alpha)^(1/alpha)/alpha^2*(x^alpha*alpha/x-(1-x)^ alpha*alpha/(1-x))^2/(x^alpha+(1-x)^alpha)^2+(x^alpha+(1-x)^alpha)^ (1/alpha)/alpha*(x^alpha*alpha^2/x^2-x^alpha*alpha/x^2+(1-x)^alpha* alpha^2/(1-x)^2-(1-x)^alpha*alpha/(1-x)^2)/(x^alpha+(1-x)^alpha)-(x ^alpha+(1-x)^alpha)^(1/alpha)/alpha*(x^alpha*alpha/x-(1-x)^alpha* alpha/(1-x))^2/(x^alpha+(1-x)^alpha)^2 } if (type == "galambos") { # 0 <= alpha < Inf alpha = param[1] # Maple Generated Output: if (alpha == 0) A2 = rep(0, times = length(x)) else if (alpha == 1) A2 = rep(2, times = length(x)) else A2 = -(x^(-alpha)+(1-x)^(-alpha))^(-1/alpha)/alpha^2*(-x^(-alpha)*alpha/ x+(1-x)^(-alpha)*alpha/(1-x))^2/(x^(-alpha)+(1-x)^(-alpha))^2+(x^(- alpha)+(1-x)^(-alpha))^(-1/alpha)/alpha*(x^(-alpha)*alpha^2/x^2+x^( -alpha)*alpha/x^2+(1-x)^(-alpha)*alpha^2/(1-x)^2+(1-x)^(-alpha)* alpha/(1-x)^2)/(x^(-alpha)+(1-x)^(-alpha))-(x^(-alpha)+(1-x)^(- alpha))^(-1/alpha)/alpha*(-x^(-alpha)*alpha/x+(1-x)^(-alpha)*alpha/ (1-x))^2/(x^(-alpha)+(1-x)^(-alpha))^2 } if (type == "husler.reiss") { # 0 <= alpha <= Inf alpha = param[1] # Maple Generated Output: if (alpha == 0) A2 = rep(0, times = length(x)) else A2 = .2500000000/Pi^(1/2)*exp(-1/2*(1/alpha+.5*alpha*ln(x/(1-x)))^2)* alpha*(1/(1-x)+x/(1-x)^2)/x*(1-x)*2^(1/2)-.1250000000/Pi^(1/2)*(1/ alpha+.5*alpha*ln(x/(1-x)))*alpha^2*(1/(1-x)+x/(1-x)^2)^2/x*(1-x)^2* exp(-1/2*(1/alpha+.5*alpha*ln(x/(1-x)))^2)*2^(1/2)+.2500000000/Pi^( 1/2)*exp(-1/2*(1/alpha+.5*alpha*ln(x/(1-x)))^2)*alpha*(2/(1-x)^2+2 *x/(1-x)^3)*(1-x)*2^(1/2)-.2500000000/Pi^(1/2)*exp(-1/2*(1/alpha+.5 *alpha*ln(x/(1-x)))^2)*alpha*(1/(1-x)+x/(1-x)^2)*2^(1/2)+.75000000/ Pi^(1/2)*exp(-1/2*(1/alpha-.5*alpha*ln(x/(1-x)))^2)*alpha*(1/(1-x )+x/(1-x)^2)/x*(1-x)*2^(1/2)-.1250000000*(1-x)^3/Pi^(1/2)*(1/alpha- .5*alpha*ln(x/(1-x)))*alpha^2*(1/(1-x)+x/(1-x)^2)^2/x^2*exp(-1/2*(1 /alpha-.5*alpha*ln(x/(1-x)))^2)*2^(1/2)-.2500000000*(1-x)^2/Pi^(1/2 )*exp(-1/2*(1/alpha-.5*alpha*ln(x/(1-x)))^2)*alpha*(2/(1-x)^2+2*x/( 1-x)^3)/x*2^(1/2)+.2500000000*(1-x)^2/Pi^(1/2)*exp(-1/2*(1/alpha-.5* alpha*ln(x/(1-x)))^2)*alpha*(1/(1-x)+x/(1-x)^2)/x^2*2^(1/2) } if (type == "tawn") { # 0 <= alpha, beta <= 1, 1 <= r < Inf alpha = param[1] beta = param[2] r = param[3] # Maple Generated Output: if (alpha == 0 | beta == 0 | r == 1) A2 = rep(0, length(x)) else A2 = ((alpha*x)^r+(beta*(1-x))^r)^(1/r)/r^2*((alpha*x)^r*r/x-(beta*(1-x) )^r*r/(1-x))^2/((alpha*x)^r+(beta*(1-x))^r)^2+((alpha*x)^r+(beta*(1 -x))^r)^(1/r)/r*((alpha*x)^r*r^2/x^2-(alpha*x)^r*r/x^2+(beta*(1-x)) ^r*r^2/(1-x)^2-(beta*(1-x))^r*r/(1-x)^2)/((alpha*x)^r+(beta*(1-x))^ r)-((alpha*x)^r+(beta*(1-x))^r)^(1/r)/r*((alpha*x)^r*r/x-(beta*(1-x ))^r*r/(1-x))^2/((alpha*x)^r+(beta*(1-x))^r)^2 # A2[x<1e-12] = 0 # A2[x>1-1e-12] = 0 } if (type == "bb5") { # delta > 0, theta >= 1 delta = param[1] theta = param[2] # Maple Generated Output: if (theta == 1) return(.AfuncSecondDer(x, param, "galambos")) else A2 = (x^theta+(1-x)^theta-(x^(-delta*theta)+(1-x)^(-delta*theta))^(-1/ delta))^(1/theta)/theta^2*(x^theta*theta/x-(1-x)^theta*theta/(1-x)+ (x^(-delta*theta)+(1-x)^(-delta*theta))^(-1/delta)/delta*(-x^(- delta*theta)*delta*theta/x+(1-x)^(-delta*theta)*delta*theta/(1-x))/ (x^(-delta*theta)+(1-x)^(-delta*theta)))^2/(x^theta+(1-x)^theta-(x^ (-delta*theta)+(1-x)^(-delta*theta))^(-1/delta))^2+(x^theta+(1-x)^ theta-(x^(-delta*theta)+(1-x)^(-delta*theta))^(-1/delta))^(1/theta)/ theta*(x^theta*theta^2/x^2-x^theta*theta/x^2+(1-x)^theta*theta^2/( 1-x)^2-(1-x)^theta*theta/(1-x)^2-(x^(-delta*theta)+(1-x)^(-delta* theta))^(-1/delta)/delta^2*(-x^(-delta*theta)*delta*theta/x+(1-x)^( -delta*theta)*delta*theta/(1-x))^2/(x^(-delta*theta)+(1-x)^(-delta* theta))^2+(x^(-delta*theta)+(1-x)^(-delta*theta))^(-1/delta)/delta* (x^(-delta*theta)*delta^2*theta^2/x^2+x^(-delta*theta)*delta*theta/ x^2+(1-x)^(-delta*theta)*delta^2*theta^2/(1-x)^2+(1-x)^(-delta* theta)*delta*theta/(1-x)^2)/(x^(-delta*theta)+(1-x)^(-delta*theta)) -(x^(-delta*theta)+(1-x)^(-delta*theta))^(-1/delta)/delta*(-x^(- delta*theta)*delta*theta/x+(1-x)^(-delta*theta)*delta*theta/(1-x))^ 2/(x^(-delta*theta)+(1-x)^(-delta*theta))^2)/(x^theta+(1-x)^theta-( x^(-delta*theta)+(1-x)^(-delta*theta))^(-1/delta))-(x^theta+(1-x)^ theta-(x^(-delta*theta)+(1-x)^(-delta*theta))^(-1/delta))^(1/theta)/ theta*(x^theta*theta/x-(1-x)^theta*theta/(1-x)+(x^(-delta*theta)+( 1-x)^(-delta*theta))^(-1/delta)/delta*(-x^(-delta*theta)*delta* theta/x+(1-x)^(-delta*theta)*delta*theta/(1-x))/(x^(-delta*theta)+( 1-x)^(-delta*theta)))^2/(x^theta+(1-x)^theta-(x^(-delta*theta)+(1-x )^(-delta*theta))^(-1/delta))^2 } # Some more, yet untested and undocumented: if (type == "gumbelII") { alpha = param[1] A2 = rep(2*alpha, times = length(x)) } if (type == "marshall.olkin") { alpha1 = param[1] alpha2 = param[2] A2 = rep(0, times = length(x)) } if (type == "pi" || type == "Cperp") { A2 = rep(0, times = length(x)) } if (type == "m" || type == "Cplus") { A2 = rep(0, times = length(x)) } # Result: attr(A2, "control") <- unlist(list(param = param, type = type)) # Return Value: A2 } ################################################################################ fCopulae/R/ExtremeValueDependency.R0000644000176200001440000002425614265245633016764 0ustar liggesusers # 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 KENDALL'S TAU AND SPEARMAN'S RHO: # evTau Returns Kendall's tau for extreme value copulae # .ev1Tau Computes Kendall's tau from dependency function # .ev2Tau Computes Kendall's tau from integration # evRho Returns Spearman's rho for extreme value copulae # .ev1Rho Computes Spearman's rho from dependency function # .ev2Rho Computes Spearman's rho from integration # FUNCTION: EXTREME VALUE COPULAE TAIL DEPENDENCE: # evTailCoeff Computes tail dependence for extreme value copulae # evTailCoeffSlider Plots extreme value tail dependence function ################################################################################ ################################################################################ # FUNCTION KENDALL'S TAU AND SPEARMAN'S RHO: # evTau Returns Kendall's tau for extreme value copulae # evRho Returns Spearman's rho for extreme value copulae evTau = function(param = NULL, type = evList(), alternative = FALSE) { # A function implemented by Diethelm Wuertz # Description: # Computes Kendall's tau for an extreme value copula # Example: # evTau(alternative = FALSE) # evTau(alternative = TRUE) # FUNCTION: # Kendall's Tau: if (!alternative) { # Default Method: ans = .ev1Tau(param, type) } else { # Alternative Method: ans = .ev2Tau(param, type) } # Return Value: ans } # ------------------------------------------------------------------------------ .ev1Tau = function(param = NULL, type = evList()) { # A function implemented by Diethelm Wuertz # Description: # Computes Kendall's tau from dependency function # FUNCTION: # Type: type = match.arg(type) # Default Parameters: if (is.null(param)) param = evParam(type)$param # Kendall's Tau Integrand: fun = function(x, param, type) { # To be integrated from 0 to 1 ... A = Afunc(x = x, param = param, type = type) A2 = .AfuncSecondDer(x, param, type) f = (x*(1-x)/A) * A2 f } # Get control attribute from: attribute = Afunc(0.5, param, type) # Integrate: ans = integrate(fun, 0, 1, param = param, type = type) Tau = c(Tau = ans[[1]]) # Add Control Attribute: attr(Tau, "control")<-attr(attribute, "control") # Return Value: Tau } # ------------------------------------------------------------------------------ .ev2Tau = function(param = NULL, type = evList()) { # A function implemented by Diethelm Wuertz # Description: # Computes Kendall's tau from integration # Example: # .ev2Tau() # FUNCTION: # Type: type = match.arg(type) # Default Parameters: if (is.null(param)) param = evParam(type)$param # Kendall's Tau Minus Rho/3 Double Integrand: fun = function(x, y, ...) { D = devCopula(x, y, alternative = FALSE, ...) D[is.na(D)] = 0 f = 4 * ( pevCopula(x, y, alternative = FALSE, ...) - x*y) * D f } # Get control attribute from: attribute = Afunc(0.5, param, type) # Integrate: ans = integrate2d(fun, param = param, type = type, error = 1e-8) Tau = c(Tau = ans[[1]] + .ev2Rho(param, type)/3) # Add Control Attribute: attr(Tau, "control")<-attr(attribute, "control") # Return Value: Tau } # ------------------------------------------------------------------------------ evRho = function(param = NULL, type = evList(), alternative = FALSE) { # A function implemented by Diethelm Wuertz # Description: # Computes Spearman's rho for an extreme value copula # Example: # evRho(alternative = FALSE) # evRho(alternative = TRUE) # FUNCTION: # Spearman's Rho: if (!alternative) { # Default Method: ans = .ev1Rho(param, type) } else { # Alternative Method: ans = .ev2Rho(param, type) } # Return Value: ans } # ------------------------------------------------------------------------------ .ev1Rho = function(param = NULL, type = evList()) { # A function implemented by Diethelm Wuertz # Description: # Computes Spearman's rho from dependency function # Example: # .ev1Rho() # FUNCTION: # Type: type = match.arg(type) # Default Parameters: if (is.null(param)) param = evParam(type)$param # Spearman's Rho Integrand: fun = function(x, param, type) { # To be integrated from 0 to 1 ... A = Afunc(x = x, param = param, type = type) f = ( 12 / (A+1)^2 ) - 3 f } # Get control attribute from: attribute = Afunc(0.5, param, type) # Integrate: ans = integrate(fun, 0, 1, param = param, type = type) Rho = c(Rho = ans[[1]]) # Add Control Attribute: attr(Rho, "control")<-attr(attribute, "control") # Return Value: Rho } # ------------------------------------------------------------------------------ .ev2Rho = function(param = NULL, type = evList()) { # A function implemented by Diethelm Wuertz # Description: # Computes Spearman's rho from integration # Example: # .ev2Rho() # FUNCTION: # Type: type = match.arg(type) # Default Parameters: if (is.null(param)) param = evParam(type)$param # Spearman's Rho Integrand: fun = function(x, y, ...) { f = 12 * pevCopula(x, y, ...) - 3 f } # Get control attribute from: attribute = Afunc(0.5, param, type) # Integrate: ans = integrate2d(fun, param = param, type = type) Rho = c(Rho = ans[[1]]) # Add Control Attribute: attr(Rho, "control")<-attr(attribute, "control") # Return Value: Rho } ################################################################################ # FUNCTION: EXTREME VALUE COPULAE TAIL DEPENDENCE: # evTailCoeff Computes tail dependence for extreme value copulae # evTailCoeffSlider Plots extreme value tail dependence function evTailCoeff = function(param = NULL, type = evList()) { # A function implemented by Diethelm Wuertz # Description: # Tail Dependence for extreme value copulae # Example: # evTailCoeff() # FUNCTION: # Type: type = match.arg(type) # Default Parameters: if (is.null(param)) param = evParam(type)$param # Limit: lambdaU = 2-2*Afunc(0.5, param, type)[[1]] lambdaL = 0 ans = c(lower = lambdaL, upper = lambdaU) # Add Control Attribute: attr(ans, "control") <- unlist(list(copula = "ev", param = param, type = type)) # Return Value: ans } # ------------------------------------------------------------------------------ evTailCoeffSlider = function(B = 10) { # A function implemented by Diethelm Wuertz # Description: # Displays interactively perspective plots of tail coefficient # Example: # evTailCoeffSlider() # FUNCTION: # Graphic Frame: par(mfrow = c(1, 1)) # Internal Function: refresh.code = function(...) { # Startup: .counter <- getRmetricsOptions(".counter") + 1 setRmetricsOptions(.counter = .counter) if (.counter < 10) return() # Sliders: Type = evList() Copula = .sliderMenu(no = 1) N = .sliderMenu(no = 2) if (Copula <= 3) param = c(delta = .sliderMenu(no = Copula + 2)) if (Copula == 4) param = c(alpha = .sliderMenu(no = 6), beta = .sliderMenu(no = 7), r = .sliderMenu(no = 8)) if (Copula == 5) param = c(delta = .sliderMenu(no = 9), theta = .sliderMenu(no = 10)) # Title: type = Type[Copula] subTitle = paste(paste(names(param) , "="), param, collapse = " | " ) Title = paste(" ", type, "\n", subTitle) # Plot: u = seq(0, 0.5, length = N+1)[-1] C.uu = pevCopula(u, u, param, type) lambda = C.uu/u v = seq(0.5, 1, length = N+1)[-(N+1)] C.uu = pevCopula(v, v, param, type) lambda = c(lambda, (1-2*v+C.uu)/(1-v)) x = c(u, v) plot(x, lambda, xlim = c(0, 1), ylim = c(0, 1), pch = 19, col = "steelblue", xlab = "u") title(main = Title) grid() # Add Points: points(x = 0, y = 0, pch = 19, col = "red") points(x = 1, y = 2-2*Afunc(0.5, param, type), pch = 19, col = "red") # Lines: abline(h = 0, col = "grey") abline(v = 0.5, col = "grey") # Reset Frame: par(mfrow = c(1, 1)) } setRmetricsOptions(.counter = 0) # Open Slider Menu: C = c("1 Gumbel: delta", "2 Galambos: delta", "3 Husler-Reis: delta", "4 Tawn: alpha", "... beta", "... r", "5 BB5: delta", "... theta") .sliderMenu(refresh.code, names = c("Copula", "N", C), # N gumbel galamb h.r tawn-tawn-tawn bb5-bb5 minima = c(1, 10, 1, 0, 0, 0, 0, 1, 0, 1), maxima = c(5, 100, B, B, B, 1, 1, B, B, B), resolutions = c(1, 10, .05, .05, .05, .01, .01, .1, .1, .1), starts = c(1, 20, 2, 1, 1, .5, .5, 2, 1, 2)) } ################################################################################ fCopulae/R/EllipticalDependency.R0000644000176200001440000002605314265245633016435 0ustar liggesusers # 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: ELLIPTICAL COPULAE DEPENDENCE MASURES: # ellipticalTau Computes Kendall's tau for elliptical copulae # ellipticalRho Computes Spearman's rho for elliptical copulae # FUNCTION: ELLIPTICAL COPULAE TAIL COEFFICIENT: # ellipticalTailCoeff Computes tail dependence for elliptical copulae # ellipticalTailPlot Plots tail dependence function ################################################################################ ################################################################################ # FUNCTION: ELLIPTICAL COPULAE DEPENDENCE MASURES: # ellipticalTau Computes Kendall's tau for elliptical copulae # ellipticalRho Computes Spearman's rho for elliptical copulae ellipticalTau <- function(rho) { # A function implemented by Diethelm Wuertz # Description: # Computes Kendall's tau for elliptical copulae # Arguments: # rho - a numeric value setting the coorelation strength, ranging # between minus one and one. # FUNCTION: # Compute Kendall's Tau: ans = 2 * asin(rho) / pi if (length(rho) == 1) { names(ans) = "Tau" } else { names(ans) = paste("Tau", 1:length(rho), sep = "") } # Add Control Attribute: attr(ans, "control") = c(rho = rho) # Return Value: ans } # ------------------------------------------------------------------------------ .ellipticalRho <- function(rho, param = NULL, type = ellipticalList(), subdivisions = 500) { # A function implemented by Diethelm Wuertz # Description: # Computes Spearman's rho for elliptical copulae # Arguments: # rho - a numeric value setting the coorelation strength, ranging # between minus one and one. # FUNCTION: # Settings: Type = c("Normal Copula", "Cauchy Copula", "Student-t Copula", "Logistic Copula", "Laplace Copula", "Kotz Copula", "Exponential Power Copula") names(Type) = c("norm", "cauchy", "t", "logistic", "laplace", "kotz", "epower") type = type[1] Type = Type[type] # Compute Spearman's Rho: ans.norm = round(6 * asin(rho/2) / pi, 2) # Spearman's Rho: N = subdivisions Pi = pfrechetCopula(u = grid2d((1:(N-1))/N), type = "pi", output = "list") D = .dellipticalCopulaGrid(N = N, rho = rho, param = param, type = type, border = FALSE) ans = round(12*mean(Pi$z*D$z)-3, 2) names(ans) = NULL # Return Value: ans } # ------------------------------------------------------------------------------ ellipticalRho <- function(rho, param = NULL, type = ellipticalList(), subdivisions = 500) { # A function implemented by Diethelm Wuertz # Description: # Computes Spearman's rho for elliptical copulae # Arguments: # rho - a numeric value setting the coorelation strength, ranging # between minus one and one. # FUNCTION: # Match Arguments: type = match.arg(type) # For all Values of rho: ans = NULL for (i in 1:length(rho)) { ans = c(ans, .ellipticalRho(rho[i], param, type, subdivisions)) } # Add Control Attribute: control = c( rho = rho, param = param, type = type, tau = round(2*asin(rho)/pi, 4)) attr(ans, "control")<-unlist(control) if (length(rho) == 1) { names(ans) = "Rho" } else { names(ans) = paste("Rho", 1:length(rho), sep = "") } # Return Value: ans } ################################################################################ # FUNCTION: ELLIPTICAL COPULAE TAIL COEFFICIENT: # ellipticalTailCoeff Computes tail dependence for elliptical copulae # ellipticalTailPlot Plots tail dependence function ellipticalTailCoeff <- function(rho, param = NULL, type = c("norm", "cauchy", "t")) { # A function implemented by Diethelm Wuertz # Description: # Computes tail dependence for elliptical copulae # Arguments: # rho - a numeric value setting the coorelation strength, ranging # between minus one and one. # Note: # type = c("logistic", "laplace", "kotz", "epower") # not yet implemented # FUNCTION: # Check: stopifnot(length(rho) == 1) # Match Arguments: type = match.arg(type) # Compute Tail Dependence: if (type == "norm") { lambda = 0 param = NULL } if (type == "cauchy") { nu = 1 arg = sqrt(nu+1) * sqrt(1-rho) / sqrt(1+rho) lambda = 2 * (1 - pt(arg, df = nu+1)) param = NULL } if (type == "t") { nu = param if (is.null(nu)) nu = 4 arg = sqrt(nu+1) * sqrt(1-rho) / sqrt(1+rho) lambda = 2 * (1 - pt(arg, df = nu+1)) param = c(nu = nu) } if (type == "logistic") { lambda = NA param = NULL } if (type == "laplace") { lambda = NA param = NULL } if (type == "kotz") { lambda = NA param = NULL } if (type == "epower") { lambda = NA param = NULL } # Result: ans = c(lambda = lambda) attr(ans, "control") = c(rho = rho, type = type, param = param) # Return Value: ans } # ------------------------------------------------------------------------------ ellipticalTailPlot <- function(param = NULL, type = c("norm", "cauchy", "t"), tail = c("Lower", "Upper")) { # A function implemented by Diethelm Wuertz # Description: # Plots tail dependence for elliptical copulae # Arguments: # rho - a numeric value setting the coorelation strength, ranging # between minus one and one. # Note: # type = c("logistic", "laplace", "kotz", "epower") # not yet implemented # FUNCTION: # Match Arguments: type = match.arg(type) tail = match.arg(tail) # Settings: Title = c("Normal", "Cauchy", "Student-t", "Logistic", "Laplace", "Kotz", "Exponential Power") Title = paste(Title, "Copula") names(Title) = c("norm", "cauchy", "t", "logistic", "laplace", "kotz", "epower") Title = Title[type] tail = tail[1] N = 1000; Points = 20 # don't change these values! u = (0:N)/N SHOW = N+1 # Parameters: if (type == "t" & is.null(param)) { param = c(nu = 4) } if (type == "kotz" & is.null(param)) { param = c(r = 1) } if (type == "epower" & is.null(param)) { param = c(r = 1, s = 1) } # Plot Frame: if (type == "t") Title = paste(Title, "| nu =", as.character(param)) if (type == "t") Title = paste(Title, "| r =", as.character(param)) if (type == "epower") Title = paste(Title, "| r =", as.character(param[1]), " s =", as.character(param[2])) plot(c(0,1), c(0,1), type = "n", main = Title, xlab = "u", ylab = paste(tail, "Tail Dependence")) # Cauchy Tail dependence: if (type == "cauchy") { type = "t" param = c(nu = 1) } # Iterate rho: Rho = c(-0.99, seq(-0.9, 0.9, by = 0.3), 0.99) for (rho in Rho) { # Compute Tail Coefficient: lambda = ellipticalTailCoeff(rho = rho, param = param, type = type) # Compute Copula Cross Section C(u,u)" if (type == "norm") C.uu = pellipticalCopula(u, rho = rho, type = type) if (type == "t") C.uu = .ptCopula(u = u, v = u, rho = rho, nu = param) if (type == "logistic" | type == "laplace" | type == "kotz" | type == "epower") C.uu = .pellipticalCopulaDiag(N, rho = rho, param = param, type = type)$y # Compute Copula Tail dependence lambda: if (tail == "Upper") { lambdaTail = (1-2*u+C.uu)/(1-u) } else if (tail == "Lower") { lambdaTail = C.uu/u } # Define Plot Elements: if (abs(rho) < 0.05) { color = "black" linetype = 1 } else if (abs(rho) > 0.95) { color = "blue" linetype = 1 } else { color = "black" linetype = 3 } # Normal Tail Dependence: if (type == "norm") { lines(u, lambdaTail, lty = linetype, col = color) } # Cauchy and Student-t Tail Dependence: if (type == "t") { if (tail == "Upper") lines(u[u < 0.99], lambdaTail[u < 0.99], lty = linetype, col = color) if (tail == "Lower") lines(u[u > 0.01], lambdaTail[u > 0.01], lty = linetype, col = color) } # Logistic Tail dependence: if (type == "logistic" | type == "laplace" | type == "kotz") { if (tail == "Lower") { SHOW = which.min(lambdaTail[-1]) ## lines(u[SHOW:(N+1)], lambdaTail[SHOW:(N+1)], type = "l", lty = linetype, col = color) } if (tail == "Upper") { SHOW = which.min(lambdaTail[-(N+1)]) lines(u[1:SHOW], lambdaTail[1:SHOW], type = "l", lty = linetype, col = color) } } # Add rho Labels text(x = 0.5, y = lambdaTail[floor(N/2)]+0.05, col = "red", cex = 0.7, labels = as.character(round(rho, 2))) # Add Points to Curves: if (tail == "Upper") { M = min(SHOW, N) Index = seq(1, M, by = Points) X = 1 } else if (tail == "Lower") { M = max(51, SHOW) Index = rev(seq(N+1, M, by = -Points)) X = 0 } points(u[Index], lambdaTail[Index], pch = 19, cex = 0.7) # Add Tail Coefficient: points(x = X, y = lambda[1], pch = 19, col = "red") } points(1, 0, pch = 19, col = "red") abline(h = 0, lty = 3, col = "grey") abline(v = X, lty = 3, col = "grey") # Return Value: invisible() } ################################################################################ fCopulae/R/ExtremeValueCopulae.R0000644000176200001440000011274614265245633016300 0ustar liggesusers # 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: EXTREME VALUE COPULAE RANDOM VARIATES: # revCopula Generates extreme value copula random variates # revSlider isplays interactively plots of random variates # FUNCTION: EXTREME VALUE COPULAE PROBABILIY: # pevCopula Computes extreme value copula probability # pevSlider Displays interactively plots of probability # .pev1Copula EV copula probability via dependence function # .pev2Copula EV copula probability direct computation # .pevContourSlider Interactive contour plots of EV probability # .pevPerspSlider Interactive perspective plots of EV probability # FUNCTION: EXTREME VALUE COPULAE DENSITY: # devCopula Computes extreme value copula density # devSlider Displays interactively plots of density # .dev1Copula EV copula density via dependence function # .dev2Copula EV copula density direct computation # .devContourSlider Interactive contour plots of EV density # .devPerspSlider Interactive perspective plots of EV density ################################################################################ ################################################################################ # FUNCTION: EXTREME VALUE COPULAE RANDOM VARIATES: # revCopula Generates extreme value copula random variates # revSlider Displays interactively plots of random variates revCopula <- function(n, param = NULL, type = evList()) { # Default Settings: subintervals = 100 u = runif(n) # Match Arguments: type = match.arg(type) # Check Parameters: if (is.null(param)) param = evParam(type)$param # Random Variates: q = runif(n) v = u Y = seq(0, 1, length = subintervals) for (i in 1:n) { U = rep(u[i], times = subintervals) C.uv = pevCopula(u = U, v = Y, param, type) / U x = log(U)/log(U*Y) A = Afunc(x, param, type) Aderiv = .AfuncFirstDer(x, param, type) X = C.uv * (A + Aderiv * log(Y)/log(U*Y)) v[i] = approx(X, Y, xout = q[i])$y } ans = cbind(u = u, v = v) # Add Control List: control = list(param = param, copula = "ev", type = type) attr(ans, "control")<-unlist(control) # Return Value: ans } # ------------------------------------------------------------------------------ revSlider <- function(B = 10) { # A function implemented by Diethelm Wuertz # Description: # Displays interactively perspective plots of random variates # FUNCTION: # Graphic Frame: par(mfrow = c(1, 1)) # Internal Function: refresh.code = function(...) { # Startup Counter: .counter <- getRmetricsOptions(".counter") + 1 setRmetricsOptions(.counter = .counter) if (.counter < 10) return () # Sliders: Type = evList() Copula = .sliderMenu(no = 1) N = .sliderMenu(no = 2) if (Copula <= 3) param = c(delta = .sliderMenu(no = Copula + 2)) if (Copula == 4) param = c(alpha = .sliderMenu(no = 6), beta = .sliderMenu(no = 7), r = .sliderMenu(no = 8)) if (Copula == 5) param = c(delta = .sliderMenu(no = 9), theta = .sliderMenu(no = 10)) # Title: type = Type[Copula] subTitle = paste(paste(names(param) , "="), param, collapse = " | " ) Title = paste(" ", type, "\n", subTitle) # Plot: R = revCopula(N, param = param, type = type) plot(R, pch = 19, col = "steelblue") grid() title(main = Title) # Reset Frame: par(mfrow = c(1, 1)) } # Open Slider Menu: setRmetricsOptions(.counter = 0) C = c("1 Gumbel: delta", "2 Galambos: delta", "3 Husler-Reis: delta", "4 Tawn: alpha", "... beta", "... r", "5 BB5: delta", "... theta") .sliderMenu(refresh.code, names = c("Copula", "N", C), # gumbel galamb h.r tawn-tawn-tawn bb5-bb5 minima = c(1, 100, 1, 0, 0, 0, 0, 1, 0, 1), maxima = c(5,5000, B, B, B, 1, 1, B, B, B), resolutions = c(1, 100, .05, .05, .05, .01, .01, .1, .1, .1), starts = c(1, 100, 2, 1, 1, .5, .5, 2, 1, 2)) } ################################################################################ # FUNCTION: EXTREME VALUE COPULAE PROBABILIY: # pevCopula Computes extreme value copula probability # pevSlider Displays interactively plots of probability # .pev1Copula EV copula probability via dependence function # .pev2Copula EV copula probability direct computation # .pevContourSlider Interactive contour plots of EV probability # .pevPerspSlider Interactive perspective plots of EV probability pevCopula <- function(u = 0.5, v = u, param = NULL, type = evList(), output = c("vector", "list"), alternative = FALSE ) { # A function implemented by Diethelm Wuertz # Description: # Computes extreme value copula probability # Arguments: # u, v - two numeric values or vectors of the same length at # which the copula will be computed. If 'u' is a list then the # the '$x' and '$y' elements will be used as 'u' and 'v'. # If 'u' is a two column matrix then the first column will # be used as 'u' and the the second as 'v'. # param - a numeric value or vector of named parameters as # required by the copula specified by the variable 'type'. # If set to NULL, then the parameters will be taken as # specified by the function 'evParam'. # type - the type of the maximum extreme value copula. A character # string selected from: "gumbel", "galambos", "husler.reiss", # "tawn", or "bb5". # output - a character string specifying how the output should # be formatted. By default a vector of the same length as # 'u' and 'v'. If specified as "list" then 'u' and 'v' are # expected to span a two-dimensional grid as outputted by the # function 'grid2d' and the function returns a list with # elements '$x', 'y', and 'z' which can be directly used # for example by 2D plotting functions. # alternative - Should the probability be computed alternatively # in a direct way from the probability formula or by default # via the dependency function? # Value: # returns a vector or list of probabilities depending on the # value of the "output" variable. # Example: # Diagonal Value: pevCopula((0:10)/10) # persp(pevCopula(u=grid2d(), output="list"), theta=-40, phi=30, xlab="x") # FUNCTION: # Select Type: type = match.arg(type) # Compute Copula: if (!alternative) { ans = .pev1Copula(u, v, param, type, output) } else { ans = .pev2Copula(u, v, param, type, output) } # Return Value: ans } # ------------------------------------------------------------------------------ pevSlider <- function(type = c("persp", "contour"), B = 10) { # A function implemented by Diethelm Wuertz # Description: # Displays interactively plots of probability # Arguments: # type - a character string specifying the plot type. # Either a perspective plot which is the default or # a contour plot with an underlying image plot will # be created. # B - the maximum slider menu value when the boundary # value is infinite. By default this is set to 10. # Match Arguments: type = match.arg(type) # Plot: if (type == "persp") .pevPerspSlider(B = B) if (type == "contour") .pevContourSlider(B = B) # Return Value: invisible() } # ------------------------------------------------------------------------------ .pev1Copula <- function(u = 0.5, v = u, param = NULL, type = evList(), output = c("vector", "list") ) { # A function implemented by Diethelm Wuertz # Description: # Computes extreme value copula probability via dependency function # FUNCTION: # Match Arguments: type = match.arg(type) output = match.arg(output) # Settings: if (is.null(param)) { param = evParam(type)$param } if (is.list(u)) { v = u$y u = u$x } if (is.matrix(u)) { v = u[, 2] u = u[, 1] } # Settings: log.u = log(u) log.v = log(v) x = log.u/(log.u+log.v) # Copula Probability: A = Afunc(x, param = param, type = type) C = exp((log.u+log.v) * A) names(C) = NULL # Simulates Max function: C = (C + abs(C))/2 # On Boundary: C[is.na(C)] = 0 C[which(u == 0)] = 0 C[which(u == 1)] = v[which(u == 1)] C[which(v == 0)] = 0 C[which(v == 1)] = u[which(v == 1)] C[which(u*v == 1)] = 1 C[which(u+v == 0)] = 0 # Result: attr(C, "control") <- unlist(list(param = param, type = type)) # As List ? if (output == "list") { N = sqrt(length(u)) x = u[1:N] y = matrix(v, ncol = N)[1, ] C = list(x = x, y = y, z = matrix(C, ncol = N)) } # Return Value: C } # ------------------------------------------------------------------------------ .pev2Copula <- function(u = 0.5, v = u, param = NULL, type = evList(), output = c("vector", "list") ) { # A function implemented by Diethelm Wuertz # Description: # Computes extreme value copula probability directly # FUNCTION: # Match Arguments: type = match.arg(type) output = match.arg(output) # Settings: if (is.null(param)) { param = evParam(type)$param } if (is.list(u)) { v = u$y u = u$x } if (is.matrix(u)) { v = u[, 2] u = u[, 1] } # Compute Probability: if (type == "gumbel") { alpha = param[1] C = exp(-((-log(u))^alpha + (-log(v))^alpha)^(1/alpha)) } if (type == "galambos") { alpha = param[1] u.tilde = -log(u) v.tilde = -log(v) C = u*v*exp(((u.tilde)^(-alpha) + (v.tilde)^(-alpha))^(-1/alpha)) } if (type == "husler.reiss") { alpha = param[1] u.tilde = -log(u) v.tilde = -log(v) C = exp(- u.tilde * pnorm(1/alpha + 0.5*alpha*log(u.tilde/v.tilde)) - v.tilde * pnorm(1/alpha + 0.5*alpha*log(v.tilde/u.tilde)) ) } if (type == "tawn") { b = param[1] a = param[2] r = param[3] log.uv = log(u*v) t = log(u)/log.uv A = 1-b+(b-a)*t+(a^r*t^r+b^r*(1-t)^r)^(1/r) C = exp(log.uv*A) } if (type == "bb5") { delta = param[1] theta = param[2] u.tilde = -log(u) v.tilde = -log(v) C = exp(-( u.tilde^theta + v.tilde^theta - ( u.tilde^(-theta*delta) + v.tilde^(-theta*delta) )^(-1/delta))^(1/theta)) } # Some more, yet untested and undocumented: if (type == "gumbelII") { alpha = param[1] C = u*v*exp(alpha*log(u)*log(v)/(log(u)+log(v))) } if (type == "marshall.olkin") { a = param[1] b = param[2] C = apply(cbind(v*u^(1-a), u*v^(1-b)), 1, min) } if (type == "pi" || type == "Cperp") { C = u*v } if (type == "m" || type == "Cplus") { C = apply(cbind(u, v), 1, min) } # Simulates Max function: C = (C + abs(C))/2 # On Boundary: C[is.na(C)] = 0 C[which(u == 0)] = 0 C[which(u == 1)] = v[which(u == 1)] C[which(v == 0)] = 0 C[which(v == 1)] = u[which(v == 1)] C[which(u*v == 1)] = 1 C[which(u+v == 0)] = 0 # Result: attr(C, "control") <- unlist(list(param = param, type = type)) # As List ? if (output == "list") { N = sqrt(length(u)) x = u[1:N] y = matrix(v, ncol = N)[1, ] C = list(x = x, y = y, z = matrix(C, ncol = N)) } # Return Value: C } # ------------------------------------------------------------------------------ .pevContourSlider <- function(B = 10) { # A function implemented by Diethelm Wuertz # Description: # Displays interactively contour plots of probability #FUNCTION: # Graphic Frame: par(mfrow = c(1, 1)) # Internal Function: refresh.code = function(...) { # Startup Counter: .counter <- getRmetricsOptions(".counter") + 1 setRmetricsOptions(.counter = .counter) if (.counter < 10) return () # Sliders: Type = evList() Copula = .sliderMenu(no = 1) N = .sliderMenu(no = 2) if (Copula <= 3) param = c(delta = .sliderMenu(no = Copula + 2)) if (Copula == 4) param = c(alpha = .sliderMenu(no = 6), beta = .sliderMenu(no = 7), r = .sliderMenu(no = 8)) if (Copula == 5) param = c(delta = .sliderMenu(no = 9), theta = .sliderMenu(no = 10)) nlev = .sliderMenu(no = 11) ncol = .sliderMenu(no = 12) # Title: type = Type[Copula] subTitle = paste(paste(names(param) , "="), param, collapse = " | " ) Title = paste(" ", type, "\n", subTitle) # Plot: uv = grid2d(x = (0:N)/N) D = .pev1Copula(u = uv, type = type, param = param, output = "list") image(D, col = heat.colors(ncol) ) contour(D, nlevels = nlev, add = TRUE) title(main = Title) # Reset Frame: par(mfrow = c(1, 1)) } # Open Slider Menu: setRmetricsOptions(.counter = 0) C = c("1 Gumbel: delta", "2 Galambos: delta", "3 Husler-Reis: delta", "4 Tawn: alpha", "... beta", "... r", "5 BB5: delta", "... theta", "Plot - levels", "... colors") .sliderMenu(refresh.code, names = c("Copula","N", C), #gal hr tawn bb5 nlev ncol minima = c(1, 10, 1, 0, 0, 0, 0, 1, 0, 1, 5, 12), maxima = c(5, 100, B, B, B, 1, 1, B, B, B, 100, 256), resolutions = c(1, 1, .05, .05, .05, .01, .01, .1, .1, .1, 5, 1), starts = c(1, 25, 2, 1, 1, .5, .5, 2, 1, 2, 10, 12)) } # ------------------------------------------------------------------------------ .pevPerspSlider <- function(B = 10) { # A function implemented by Diethelm Wuertz # Description: # Displays interactively perspective plots of probability #FUNCTION: # Graphic Frame: par(mfrow = c(1, 1)) # Internal Function: refresh.code = function(...) { # Startup Counter: .counter <- getRmetricsOptions(".counter") + 1 setRmetricsOptions(.counter = .counter) if (.counter < 12) return () # Sliders: Type = evList() Copula = .sliderMenu(no = 1) N = .sliderMenu(no = 2) if (Copula <= 3) param = c(delta = .sliderMenu(no = Copula + 2)) if (Copula == 4) param = c(alpha = .sliderMenu(no = 6), beta = .sliderMenu(no = 7), r = .sliderMenu(no = 8)) if (Copula == 5) param = c(delta = .sliderMenu(no = 9), theta = .sliderMenu(no = 10)) theta = .sliderMenu(no = 11) phi = .sliderMenu(no = 12) # Title: type = Type[Copula] subTitle = paste(paste(names(param) , "="), param, collapse = " | " ) Title = paste(" ", type, "\n", subTitle) # Plot: uv = grid2d(x = (0:N)/N) D = .pev1Copula(u = uv, type = type, param = param, output = "list") #D2 = .pev2Copula(u = uv, type = type, param = param, output = "list") persp(D, theta = theta, phi = phi, col = "steelblue", shade = 0.5, ticktype = "detailed", cex = 0.5) title(main = Title) # Reset Frame: par(mfrow = c(1, 1)) } # Open Slider Menu: setRmetricsOptions(.counter = 0) C = c("1 Gumbel: delta", "2 Galambos: delta", "3 Husler-Reis: delta", "4 Tawn: alpha", "... beta", "... r", "5 BB5: delta", "... theta", "Plot - theta", "... phi") .sliderMenu(refresh.code, names = c("Copula", "N", C), #gal hr tawn bb5 theta phi minima = c(1, 10, 1, 0, 0, 0, 0, 1, 0, 1, -180, 0), maxima = c(5, 100, B, B, B, 1, 1, B, B, B, 180, 360), resolutions = c(1, 1, .05, .05, .05, .01, .01, .1, .1, .1, 1, 1), starts = c(1, 25, 2, 1, 1, .5, .5, 2, 1, 2, -40, 30)) } ################################################################################ # FUNCTION: EXTREME VALUE COPULAE DENSITY: # devCopula Computes extreme value copula density # devSlider Displays interactively plots of density # .dev1Copula EV copula density via dependence function # .dev2Copula EV copula density direct computation # .devContourSlider Interactive contour plots of EV density # .devPerspSlider Interactive perspective plots of EV density devCopula <- function(u = 0.5, v = u, param = NULL, type = evList(), output = c("vector", "list"), alternative = FALSE ) { # A function implemented by Diethelm Wuertz # Description: # Computes extreme value copula density from dependence function # Arguments: # u, v - two numeric values or vectors of the same length at # which the copula will be computed. If 'u' is a list then the # the '$x' and '$y' elements will be used as 'u' and 'v'. # If 'u' is a two column matrix then the first column will # be used as 'u' and the the second as 'v'. # param - a numeric value or vector of named parameters as # required by the copula specified by the variable 'type'. # If set to NULL, then the parameters will be taken as # specified by the function 'evParam'. # type - the type of the maximum extreme value copula. A character # string selected from: "gumbel", "galambos", "husler.reiss", # "tawn", or "bb5". # output - a character string specifying how the output should # be formatted. By default a vector of the same length as # 'u' and 'v'. If specified as "list" then 'u' and 'v' are # expected to span a two-dimensional grid as outputted by the # function 'grid2d' and the function returns a list with # elements '$x', 'y', and 'z' which can be directly used # for example by 2D plotting functions. # alternative - Should the density be computed alternatively # in a direct way from the probability formula or by default # via the dependency function? # Value: # returns a vector or list of density values depending on the # value of the "output" variable. # Example: # Diagonal Value: devCopula((0:10)/10) # persp(devCopula(u=grid2d(), output="list"), theta=-40, phi=30, xlab="x") # FUNCTION: # Match Arguments: type = match.arg(type) output = match.arg(output) # Copula Density: if (alternative) { ans = .dev2Copula(u, v, param, type, output) } else { ans = .dev1Copula(u, v, param, type, output) } # Return Value: ans } # ------------------------------------------------------------------------------ devSlider = function(type = c("persp", "contour"), B = 10) { # A function implemented by Diethelm Wuertz # Description: # Displays interactively plots of probability # Arguments: # type - a character string specifying the plot type. # Either a perspective plot which is the default or # a contour plot with an underlying image plot will # be created. # B - the maximum slider menu value when the boundary # value is infinite. By default this is set to 10. # Match Arguments: type = match.arg(type) # Plot: if (type == "persp") .devPerspSlider(B = B) if (type == "contour") .devContourSlider(B = B) # Return Value: invisible() } # ------------------------------------------------------------------------------ .dev1Copula <- function(u = 0.5, v = u, param = NULL, type = evList(), output = c("vector", "list") ) { # A function implemented by Diethelm Wuertz # Description: # Computes extreme value copula density from dependence function # Example: # Diagonal Value: devCopula((0:10)/10) # persp(devCopula(u=grid2d(), output="list"), theta=-40, phi=30, xlab="x") # FUNCTION: # Match Arguments: type = match.arg(type) output = match.arg(output) # Settings: if (is.null(param)) { param = evParam(type)$param } if (is.list(u)) { v = u$y u = u$x } if (is.matrix(u)) { v = u[, 2] u = u[, 1] } # Settings for Maple Output: Pi = pi ln = function(x) { log(x) } erf = function (x) { 2*pnorm(sqrt(2)*x)-1 } # Further Settings: log.u = log(u) log.v = log(v) x = log.u/(log.u+log.v) y = log.v/(log.u+log.v) # Copula Probability: A = Afunc(x, param = param, type = type) A1 = .AfuncFirstDer(x, param = param, type = type) A2 = .AfuncSecondDer(x, param = param, type = type) # Prefactor: P = pevCopula(u, v, param = param, type = type) / (u*v) c.uv = P * (( -x*y/(log.u+log.v))*A2 + (A+y*A1)*(A-x*A1) ) c.uv[which(u*v == 0 | u*v == 1)] = 0 # Result: attr(c.uv, "control") <- unlist(list(param = param, type = type)) # As List ? if (output == "list") { N = sqrt(length(u)) x = u[1:N] y = matrix(v, ncol = N)[1, ] c.uv = list(x = x, y = y, z = matrix(c.uv, ncol = N)) } # Return Value: c.uv } # ------------------------------------------------------------------------------ .dev2Copula <- function(u = 0.5, v = u, param = NULL, type = evList(), output = c("vector", "list") ) { # A function implemented by Diethelm Wuertz # Description: # Computes extreme value copula density directly # Details: # List - 9 Types: # pi[Cperp], gumbel, gumbelII, galambos, husler.reiss, # tawn, bb5, marshall.olkin, m[Cplus] # References: # Carmona, Evanesce # FUNCTION: # Match Arguments: type = match.arg(type) output = match.arg(output) # Settings: if (is.null(param)) { param = evParam(type)$param } if (is.list(u)) { v = u$y u = u$x } if (is.matrix(u)) { v = u[, 2] u = u[, 1] } # Settings: if (is.null(param)) param = evParam[[type]] Pi = pi ln = function(x) { log(x) } erf = function (x) { 2*pnorm(sqrt(2)*x)-1 } # Compute Probability: if (type == "gumbel") { alpha = param[1] # Maple Generated Output: c.uv = -((-ln(u))^alpha+(-ln(v))^alpha)^(1/alpha)*(-ln(v))^alpha/v/ln(v)/( (-ln(u))^alpha+(-ln(v))^alpha)^2*(-ln(u))^alpha/u/ln(u)*exp(-((-ln( u))^alpha+(-ln(v))^alpha)^(1/alpha))+((-ln(u))^alpha+(-ln(v))^alpha )^(1/alpha)*(-ln(u))^alpha/u/ln(u)/((-ln(u))^alpha+(-ln(v))^alpha)^ 2*exp(-((-ln(u))^alpha+(-ln(v))^alpha)^(1/alpha))*(-ln(v))^alpha* alpha/v/ln(v)+(((-ln(u))^alpha+(-ln(v))^alpha)^(1/alpha))^2*(-ln(u) )^alpha/u/ln(u)/((-ln(u))^alpha+(-ln(v))^alpha)^2*(-ln(v))^alpha/v/ ln(v)*exp(-((-ln(u))^alpha+(-ln(v))^alpha)^(1/alpha)) } if (type == "galambos") { alpha = param[1] # Maple Generated Output: c.uv = exp(((-ln(u))^(-alpha)+(-ln(v))^(-alpha))^(-1/alpha))+((-ln(u))^(- alpha)+(-ln(v))^(-alpha))^(-1/alpha)*(-ln(v))^(-alpha)/ln(v)/((-ln( u))^(-alpha)+(-ln(v))^(-alpha))*exp(((-ln(u))^(-alpha)+(-ln(v))^(- alpha))^(-1/alpha))+((-ln(u))^(-alpha)+(-ln(v))^(-alpha))^(-1/alpha )*(-ln(u))^(-alpha)/ln(u)/((-ln(u))^(-alpha)+(-ln(v))^(-alpha))*exp( ((-ln(u))^(-alpha)+(-ln(v))^(-alpha))^(-1/alpha))+((-ln(u))^(- alpha)+(-ln(v))^(-alpha))^(-1/alpha)*(-ln(v))^(-alpha)/ln(v)/((-ln( u))^(-alpha)+(-ln(v))^(-alpha))^2*(-ln(u))^(-alpha)/ln(u)*exp(((-ln (u))^(-alpha)+(-ln(v))^(-alpha))^(-1/alpha))+((-ln(u))^(-alpha)+(- ln(v))^(-alpha))^(-1/alpha)*(-ln(u))^(-alpha)/ln(u)/((-ln(u))^(- alpha)+(-ln(v))^(-alpha))^2*exp(((-ln(u))^(-alpha)+(-ln(v))^(-alpha ))^(-1/alpha))*(-ln(v))^(-alpha)*alpha/ln(v)+(((-ln(u))^(-alpha)+(- ln(v))^(-alpha))^(-1/alpha))^2*(-ln(u))^(-alpha)/ln(u)/((-ln(u))^(- alpha)+(-ln(v))^(-alpha))^2*(-ln(v))^(-alpha)/ln(v)*exp(((-ln(u))^( -alpha)+(-ln(v))^(-alpha))^(-1/alpha)) } if (type == "husler.reiss") { # Maple Generated Output: c.uv = (-.2500000000/u/Pi^(1/2)*exp(-1/2*(1/alpha+.5*alpha*ln(ln(u)/ln(v)) )^2)*alpha/v/ln(v)*2^(1/2)+.1250000000/Pi^(1/2)*(1/alpha+.5*alpha* ln(ln(u)/ln(v)))*alpha^2/v/ln(v)*exp(-1/2*(1/alpha+.5*alpha*ln(ln(u )/ln(v)))^2)/u*2^(1/2)-.2500000000/v/Pi^(1/2)*exp(-1/2*(1/alpha+.5* alpha*ln(ln(v)/ln(u)))^2)*alpha/u/ln(u)*2^(1/2)+.1250000000/Pi^(1/2 )*(1/alpha+.5*alpha*ln(ln(v)/ln(u)))*alpha^2/v*exp(-1/2*(1/alpha+.5 *alpha*ln(ln(v)/ln(u)))^2)/u/ln(u)*2^(1/2))*exp(.5*ln(u)*(erf(1/2*( 1/alpha+.5*alpha*ln(ln(u)/ln(v)))*2^(1/2))+1)+.5*ln(v)*(erf(1/2*(1/ alpha+.5*alpha*ln(ln(v)/ln(u)))*2^(1/2))+1))+(.5/u*(erf(1/2*(1/ alpha+.5*alpha*ln(ln(u)/ln(v)))*2^(1/2))+1)+.2500000000/Pi^(1/2)* exp(-1/2*(1/alpha+.5*alpha*ln(ln(u)/ln(v)))^2)*alpha/u*2^(1/2)-.25* ln(v)/Pi^(1/2)*exp(-1/2*(1/alpha+.5*alpha*ln(ln(v)/ln(u)))^2)* alpha/u/ln(u)*2^(1/2))*(-.2500000000*ln(u)/Pi^(1/2)*exp(-1/2*(1/ alpha+.5*alpha*ln(ln(u)/ln(v)))^2)*alpha/v/ln(v)*2^(1/2)+.5/v*(erf( 1/2*(1/alpha+.5*alpha*ln(ln(v)/ln(u)))*2^(1/2))+1)+.2500000000/Pi^( 1/2)*exp(-1/2*(1/alpha+.5*alpha*ln(ln(v)/ln(u)))^2)*alpha/v*2^(1/2) )*exp(.5*ln(u)*(erf(1/2*(1/alpha+.5*alpha*ln(ln(u)/ln(v)))*2^(1/2)) +1)+.5*ln(v)*(erf(1/2*(1/alpha+.5*alpha*ln(ln(v)/ln(u)))*2^(1/2))+1 )) } if (type == "tawn") { # 0 <= alpha, beta <= 1, 1 <= r < Inf b = param[1] a = param[2] r = param[3] # Maple Generated Output: c.uv = (-(b-a)/u/ln(u*v)^2/v+2*(b-a)*ln(u)/ln(u*v)^3/u/v+(a^r*(ln(u)/ln(u* v))^r+b^r*(1-ln(u)/ln(u*v))^r)^(1/r)/r^2*(-a^r*(ln(u)/ln(u*v))^r*r/ ln(u*v)/v+b^r*(1-ln(u)/ln(u*v))^r*r*ln(u)/ln(u*v)^2/v/(1-ln(u)/ln(u *v)))/(a^r*(ln(u)/ln(u*v))^r+b^r*(1-ln(u)/ln(u*v))^r)^2*(a^r*(ln(u) /ln(u*v))^r*r*(1/u/ln(u*v)-ln(u)/ln(u*v)^2/u)/ln(u)*ln(u*v)+b^r*(1- ln(u)/ln(u*v))^r*r*(-1/u/ln(u*v)+ln(u)/ln(u*v)^2/u)/(1-ln(u)/ln(u*v )))+(a^r*(ln(u)/ln(u*v))^r+b^r*(1-ln(u)/ln(u*v))^r)^(1/r)/r*(-a^r*( ln(u)/ln(u*v))^r*r^2/v*(1/u/ln(u*v)-ln(u)/ln(u*v)^2/u)/ln(u)+a^r*( ln(u)/ln(u*v))^r*r*(-1/u/ln(u*v)^2/v+2*ln(u)/ln(u*v)^3/u/v)/ln(u)* ln(u*v)+a^r*(ln(u)/ln(u*v))^r*r*(1/u/ln(u*v)-ln(u)/ln(u*v)^2/u)/ln( u)/v+b^r*(1-ln(u)/ln(u*v))^r*r^2*ln(u)/ln(u*v)^2/v/(1-ln(u)/ln(u*v) )^2*(-1/u/ln(u*v)+ln(u)/ln(u*v)^2/u)+b^r*(1-ln(u)/ln(u*v))^r*r*(1/u /ln(u*v)^2/v-2*ln(u)/ln(u*v)^3/u/v)/(1-ln(u)/ln(u*v))-b^r*(1-ln(u)/ ln(u*v))^r*r*(-1/u/ln(u*v)+ln(u)/ln(u*v)^2/u)/(1-ln(u)/ln(u*v))^2* ln(u)/ln(u*v)^2/v)/(a^r*(ln(u)/ln(u*v))^r+b^r*(1-ln(u)/ln(u*v))^r)- (a^r*(ln(u)/ln(u*v))^r+b^r*(1-ln(u)/ln(u*v))^r)^(1/r)/r*(a^r*(ln(u) /ln(u*v))^r*r*(1/u/ln(u*v)-ln(u)/ln(u*v)^2/u)/ln(u)*ln(u*v)+b^r*(1- ln(u)/ln(u*v))^r*r*(-1/u/ln(u*v)+ln(u)/ln(u*v)^2/u)/(1-ln(u)/ln(u*v )))/(a^r*(ln(u)/ln(u*v))^r+b^r*(1-ln(u)/ln(u*v))^r)^2*(-a^r*(ln(u)/ ln(u*v))^r*r/ln(u*v)/v+b^r*(1-ln(u)/ln(u*v))^r*r*ln(u)/ln(u*v)^2/v/ (1-ln(u)/ln(u*v))))*exp(ln(u*v)-b+(b-a)*ln(u)/ln(u*v)+(a^r*(ln(u)/ ln(u*v))^r+b^r*(1-ln(u)/ln(u*v))^r)^(1/r))+(1/u+(b-a)/u/ln(u*v)-(b- a)*ln(u)/ln(u*v)^2/u+(a^r*(ln(u)/ln(u*v))^r+b^r*(1-ln(u)/ln(u*v))^r )^(1/r)/r*(a^r*(ln(u)/ln(u*v))^r*r*(1/u/ln(u*v)-ln(u)/ln(u*v)^2/u)/ ln(u)*ln(u*v)+b^r*(1-ln(u)/ln(u*v))^r*r*(-1/u/ln(u*v)+ln(u)/ln(u*v) ^2/u)/(1-ln(u)/ln(u*v)))/(a^r*(ln(u)/ln(u*v))^r+b^r*(1-ln(u)/ln(u*v ))^r))*(1/v-(b-a)*ln(u)/ln(u*v)^2/v+(a^r*(ln(u)/ln(u*v))^r+b^r*(1- ln(u)/ln(u*v))^r)^(1/r)/r*(-a^r*(ln(u)/ln(u*v))^r*r/ln(u*v)/v+b^r*( 1-ln(u)/ln(u*v))^r*r*ln(u)/ln(u*v)^2/v/(1-ln(u)/ln(u*v)))/(a^r*(ln( u)/ln(u*v))^r+b^r*(1-ln(u)/ln(u*v))^r))*exp(ln(u*v)-b+(b-a)*ln(u)/ ln(u*v)+(a^r*(ln(u)/ln(u*v))^r+b^r*(1-ln(u)/ln(u*v))^r)^(1/r)) } if (type == "bb5") { # delta > 0, theta >= 1 delta = param[1] theta = param[2] # Maple Generated Output: c.uv = -((-ln(u))^theta+(-ln(v))^theta-((-ln(u))^(-theta*delta)+(-ln(v))^( -theta*delta))^(-1/delta))^(1/theta)/theta^2*((-ln(v))^theta*theta/ v/ln(v)-((-ln(u))^(-theta*delta)+(-ln(v))^(-theta*delta))^(-1/delta )*(-ln(v))^(-theta*delta)*theta/v/ln(v)/((-ln(u))^(-theta*delta)+(- ln(v))^(-theta*delta)))/((-ln(u))^theta+(-ln(v))^theta-((-ln(u))^(- theta*delta)+(-ln(v))^(-theta*delta))^(-1/delta))^2*((-ln(u))^theta *theta/u/ln(u)-((-ln(u))^(-theta*delta)+(-ln(v))^(-theta*delta))^(- 1/delta)*(-ln(u))^(-theta*delta)*theta/u/ln(u)/((-ln(u))^(-theta* delta)+(-ln(v))^(-theta*delta)))*exp(-((-ln(u))^theta+(-ln(v))^ theta-((-ln(u))^(-theta*delta)+(-ln(v))^(-theta*delta))^(-1/delta)) ^(1/theta))-((-ln(u))^theta+(-ln(v))^theta-((-ln(u))^(-theta*delta) +(-ln(v))^(-theta*delta))^(-1/delta))^(1/theta)/theta*(-((-ln(u))^( -theta*delta)+(-ln(v))^(-theta*delta))^(-1/delta)*(-ln(v))^(-theta* delta)*theta^2/v/ln(v)/((-ln(u))^(-theta*delta)+(-ln(v))^(-theta* delta))^2*(-ln(u))^(-theta*delta)/u/ln(u)-((-ln(u))^(-theta*delta)+ (-ln(v))^(-theta*delta))^(-1/delta)*(-ln(u))^(-theta*delta)*theta^2 /u/ln(u)/((-ln(u))^(-theta*delta)+(-ln(v))^(-theta*delta))^2*(-ln(v ))^(-theta*delta)*delta/v/ln(v))/((-ln(u))^theta+(-ln(v))^theta-((- ln(u))^(-theta*delta)+(-ln(v))^(-theta*delta))^(-1/delta))*exp(-((- ln(u))^theta+(-ln(v))^theta-((-ln(u))^(-theta*delta)+(-ln(v))^(- theta*delta))^(-1/delta))^(1/theta))+((-ln(u))^theta+(-ln(v))^theta -((-ln(u))^(-theta*delta)+(-ln(v))^(-theta*delta))^(-1/delta))^(1/ theta)/theta*((-ln(u))^theta*theta/u/ln(u)-((-ln(u))^(-theta*delta) +(-ln(v))^(-theta*delta))^(-1/delta)*(-ln(u))^(-theta*delta)*theta/ u/ln(u)/((-ln(u))^(-theta*delta)+(-ln(v))^(-theta*delta)))/((-ln(u) )^theta+(-ln(v))^theta-((-ln(u))^(-theta*delta)+(-ln(v))^(-theta* delta))^(-1/delta))^2*exp(-((-ln(u))^theta+(-ln(v))^theta-((-ln(u)) ^(-theta*delta)+(-ln(v))^(-theta*delta))^(-1/delta))^(1/theta))*((- ln(v))^theta*theta/v/ln(v)-((-ln(u))^(-theta*delta)+(-ln(v))^(- theta*delta))^(-1/delta)*(-ln(v))^(-theta*delta)*theta/v/ln(v)/((- ln(u))^(-theta*delta)+(-ln(v))^(-theta*delta)))+(((-ln(u))^theta+(- ln(v))^theta-((-ln(u))^(-theta*delta)+(-ln(v))^(-theta*delta))^(-1/ delta))^(1/theta))^2/theta^2*((-ln(u))^theta*theta/u/ln(u)-((-ln(u) )^(-theta*delta)+(-ln(v))^(-theta*delta))^(-1/delta)*(-ln(u))^(- theta*delta)*theta/u/ln(u)/((-ln(u))^(-theta*delta)+(-ln(v))^(- theta*delta)))/((-ln(u))^theta+(-ln(v))^theta-((-ln(u))^(-theta* delta)+(-ln(v))^(-theta*delta))^(-1/delta))^2*((-ln(v))^theta*theta /v/ln(v)-((-ln(u))^(-theta*delta)+(-ln(v))^(-theta*delta))^(-1/ delta)*(-ln(v))^(-theta*delta)*theta/v/ln(v)/((-ln(u))^(-theta* delta)+(-ln(v))^(-theta*delta)))*exp(-((-ln(u))^theta+(-ln(v))^ theta-((-ln(u))^(-theta*delta)+(-ln(v))^(-theta*delta))^(-1/delta)) ^(1/theta)) } # Result: attr(c.uv, "control") <- unlist(list(param = param, type = type)) # As List ? if (output[1] == "list") { N = sqrt(length(u)) x = u[1:N] y = matrix(v, ncol = N)[1, ] c.uv = list(x = x, y = y, z = matrix(c.uv, ncol = N)) } # Return Value: c.uv } # ------------------------------------------------------------------------------ .devContourSlider <- function(B = 10) { # A function implemented by Diethelm Wuertz # Description: # Displays interactively contour plots of density # FUNCTION: # Internal Function: refresh.code = function(...) { # Startup Counter: .counter <- getRmetricsOptions(".counter") + 1 setRmetricsOptions(.counter = .counter) if (.counter < 12) return () # Sliders: Type = evList() Copula = .sliderMenu(no = 1) N = .sliderMenu(no = 2) if (Copula <= 3) param = c(delta = .sliderMenu(no = Copula + 2)) if (Copula == 4) param = c(alpha = .sliderMenu(no = 6), beta = .sliderMenu(no = 7), r = .sliderMenu(no = 8)) if (Copula == 5) param = c(delta = .sliderMenu(no = 9), theta = .sliderMenu(no = 10)) nlev = .sliderMenu(no = 11) ncol = .sliderMenu(no = 12) # Title: type = Type[Copula] subTitle = paste(paste(names(param) , "="), param, collapse = " | " ) Title = paste(" ", type, "\n", subTitle) # Plot: n = N/2 F = (2*1.0e-2)^(1/n) x = 0.5*F^(1:n) x = c(rev(x), 0.5, 1-x) uv = grid2d(x = (1:(N-1))/N) D = .dev1Copula(u = uv, type = type, param = param, output = "list") image(D, col = heat.colors(ncol) ) contour(D, nlevels = nlev, add = TRUE) title(main = Title) # Reset Frame: par(mfrow = c(1, 1)) } # Open Slider Menu: setRmetricsOptions(.counter = 0) C = c("1 Gumbel: delta", "2 Galambos: delta", "3 Husler-Reis: delta", "4 Tawn: alpha", "... beta", "... r", "5 BB5: delta", "... theta", "Plot - levels", "... colors") .sliderMenu(refresh.code, names = c("Copula","N", C), #gal hr tawn bb5 nlev ncol minima = c(1, 10, 1, 0, 0, 0, 0, 1, 0, 1, 5, 12), maxima = c(5, 100, B, B, B, 1, 1, B, B, B, 100, 256), resolutions = c(1, 5, .05, .05, .05, .01, .01, .1, .1, .1, 5, 1), starts = c(1, 25, 2, 1, 1, .5, .5, 2, 1, 2, 10, 12)) } # ------------------------------------------------------------------------------ .devPerspSlider <- function(B = 10) { # A function implemented by Diethelm Wuertz # Description: # Displays interactively contour plots of density #FUNCTION: # Internal Function: refresh.code = function(...) { # Startup Counter: .counter <- getRmetricsOptions(".counter") + 1 setRmetricsOptions(.counter = .counter) if (.counter < 12) return () # Sliders: Type = evList() Copula = .sliderMenu(no = 1) N = .sliderMenu(no = 2) if (Copula <= 3) param = c(delta = .sliderMenu(no = Copula + 2)) if (Copula == 4) param = c(alpha = .sliderMenu(no = 6), beta = .sliderMenu(no = 7), r = .sliderMenu(no = 8)) if (Copula == 5) param = c(delta = .sliderMenu(no = 9), theta = .sliderMenu(no = 10)) theta = .sliderMenu(no = 11) phi = .sliderMenu(no = 12) # Title: type = Type[Copula] subTitle = paste(paste(names(param) , "="), param, collapse = " | " ) Title = paste(" ", type, "\n", subTitle) # Plot: n = N/2 F = (2*1.0e-2)^(1/n) x = 0.5*F^(1:n) x = c(rev(x), 0.5, 1-x) uv = grid2d(x = x) D = .dev1Copula(u = uv, type = type, param = param, output = "list") persp(D, theta = theta, phi = phi, col = "steelblue", shade = 0.5, ticktype = "detailed", cex = 0.5) title(main = Title) # Reset Frame: par(mfrow = c(1, 1)) } # Open Slider Menu: setRmetricsOptions(.counter = 12) C = c("1 Gumbel: delta", "2 Galambos: delta", "3 Husler-Reis: delta", "4 Tawn: alpha", "... beta", "... r", "5 BB5: delta", "... theta", "Plot - theta", "... phi") .sliderMenu(refresh.code, names = c("Copula", "N", C), #gal hr tawn bb5 theta phi minima = c(1, 10, 1, 0, 0, 0, 0, 1, 0, 1, -180, 0), maxima = c(5, 100, B, B, B, 1, 1, B, B, B, 180, 360), resolutions = c(1, 5, .05, .05, .05, .01, .01, .1, .1, .1, 1, 1), starts = c(1, 25, 2, 1, 1, .5, .5, 2, 1, 2, -40, 30)) } ################################################################################ fCopulae/R/ArchimedeanSlider.R0000644000176200001440000005664214265245633015726 0ustar liggesusers # 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: ARCHIMEDEAN COPULAE SLIDERS: # rarchmSlider Displays interactively Archimedean probability # parchmSlider Displays interactively Archimedean probability # .parchmPerspSlider Perspective Archimedean probability slider # .parchmContourSlider Contour Archimedean probability slider # darchmSlider Displays interactively archimedean density # .darchmPerspSlider Perspective Archimedean density slider # .darchmContourSlider Contour Archimedean density slider ################################################################################ ################################################################################ rarchmSlider <- function(B = 10) { # A function implemented by Diethelm Wuertz # Description: # Displays interactively perspective plots of probability # FUNCTION: # Graphic Frame: par(mfrow = c(1, 1)) # Internal Function: refresh.code <- function(...) { # Sliders: # 1 5 10 15 20 Counter = c(1,2,3,2,4,2,5,2,5,5,6,2,7,2,2,7,4,8,7,7,2,5) Copula = as.integer(.sliderMenu(no = 1)) No = Counter[Copula] N = .sliderMenu(no = 2) alpha = .sliderMenu(no = No+2) # There is no known Copula for the following bounds: eps = 1.0e-6 if (Copula == 11) if (alpha == 0.5) alpha = 0.5 - eps if (Copula == 13) if (alpha == 0.0) alpha = eps # Title: Names = c( "- Clayton", "", "- Ali-Mikhail-Hag", "- Gumbel-Hougard", "- Frank", "- Joe-Frank", "", "", "- Gumbel-Barnett", "", "", "", "", "", "- Genest-Ghoudi", "", "", "", "", "", "", "") Title = paste("Archimedean Copula No:", as.character(Copula), Names[Copula], "\nalpha = ", as.character(alpha)) # Plot: R = rarchmCopula(n = N, alpha = alpha, type = as.character(Copula)) plot(R, xlab = "U", ylab = "V", pch = 19, col = "steelblue") grid() title(main = Title) # Reset Frame: par(mfrow = c(1, 1)) } # Open Slider Menu: C2 = "2-4-6-8-12-14-15-21" C = c("1", C2, "3", "5-17", "7-9-10-22", "11", "13-16-19-20","18") L = c( -1, 1, -1, -B, 0, 0, 0, 2 ) U = c( B, B, 1, B, 1, 0.5, B, B ) A = c(0.5, 2, 0.5, 1, 0.5, 0.2, 1, 3 ) V = rep(0.1, 8) .sliderMenu(refresh.code, names = c("Copula", "N", C), minima = c( 1, 100, L), maxima = c( 22, 1000, U), resolutions = c( 1, 100, V), starts = c( 1, 100, A)) } ################################################################################ parchmSlider <- function(type = c("persp", "contour"), B = 10) { # A function implemented by Diethelm Wuertz # Description: # Displays interactively plots of probability # Description: # Displays interactively plots of probability # Arguments: # type - a character string specifying the plot type. # Either a perspective plot which is the default or # a contour plot with an underlying image plot will # be created. # B - the maximum slider menu value when the boundary # value is infinite. By default this is set to 10. # FUNCTION: # Match Arguments: type = match.arg(type) # Plot: if (type[1] == "persp") .parchmPerspSlider(B = B) if (type[1] == "contour") .parchmContourSlider(B = B) # Return Value: invisible() } # ------------------------------------------------------------------------------ .parchmPerspSlider = function(B = 5) { # A function implemented by Diethelm Wuertz # Description: # Displays interactively perspective plots of probability # FUNCTION: # Graphic Frame: par(mfrow = c(1, 1)) # Internal Function: refresh.code = function(...) { # Sliders: Counter = c(1,2,3,2,4,2,5,2,5,5,6,2,7,2,2,7,4,8,7,7,2,5) Copula = as.integer(.sliderMenu(no = 1)) No = Counter[Copula] N = .sliderMenu(no = 2) alpha = .sliderMenu(no = No+2) theta = .sliderMenu(no = 11) phi = .sliderMenu(no = 12) # Skip: if (Copula == 11) if (alpha == 0.5) return(invisible()) if (Copula == 13) if (alpha == 0) return(invisible()) # Do we have a strict Copula? strict = c( "Yes","No","Yes","Yes","Yes","Yes","No","No","Yes","Yes", "No","Yes","Yes","Yes","No","Yes","Yes","No","Yes","Yes", "No","Yes")[Copula] if (alpha < 0 & Copula == 1) strict[1] = "No" if (alpha == 0 & Copula == 16) strict[16] = "No" # What is the Range? RANGE = c( "[-1|Inf)", "[1|Inf)", "[-1|1)", "(-Inf|Inf)", "(0|1]", "(0|0.5]", "(0|Inf)", "[2|Inf)")[No] # Which one is the Limit Copula? limitTitle = rep("NA", times = 22) if (alpha == -1) limitTitle = c( "W ", "NA", "NA", "NA", "NA", "NA", "NA", "NA", "NA", "NA", "NA", "NA", "NA", "NA", "NA", "NA", "Pi", "NA", "NA", "NA", "NA", "NA") if (alpha == 0) limitTitle = c( "Pi", "NA", "Pi", "NA", "Pi", "NA", "W ", "NA", "Pi", "Pi", "Pi", "NA", "NA", "NA", "NA", "W ", "NA", "NA", "L ", "Pi", "NA", "Pi") if (alpha == 1) limitTitle = c( "L ", "W ", "L ", "Pi", "NA", "Pi", "Pi", "W ", "NA", "NA", "NA", "L ", "Pi", "L ", "W ", "NA", "NA", "NA", "NA", "NA", "W ", "NA") limitTitle = limitTitle[Copula] if (limitTitle == "NA") { limitTitle = " " } else { limitTitle = paste(" Copula = ", limitTitle[1]) } # Tau/Rho: Tau = round(approx(.ALPHA[, Copula], .TAU[, Copula], xout = alpha)$y, digits = 3) Rho = round(approx(.ALPHA[, Copula], .RHO[, Copula], xout = alpha)$y, digits = 3) # Title: Names = c( "- Clayton", "", "- Ali-Mikhail-Hag", "- Gumbel-Hougard", "- Frank", "- Joe-Frank", "", "", "- Gumbel-Barnett", "", "", "", "", "", "- Genest-Ghoudi", "", "", "", "", "", "", "") Title = paste("Archimedean Copula No:", as.character(Copula), Names[Copula], "\n", RANGE, " alpha =", as.character(alpha), " tau =", as.character(Tau), " rho =", as.character(Rho)) # Plot: uv = grid2d(x = (0:N)/N) P = .parchm1Copula(u = uv, alpha = alpha, type = Copula, output = "list") persp(P, theta = theta, phi = phi, col = "steelblue", shade = 0.5, ticktype = "detailed", cex = 0.5, xlab = "u", ylab = "v", zlab = "C(u,v)" ) title(main = Title) # Reset Frame: par(mfrow = c(1, 1)) } # Open Slider Menu: B = 5 C1 = "1: [-1,Inf]" C2 = "2-4-6-8-12-14-15-21: [1,Inf)" C3 = "3: [-1,1)" C4 = "5-17: (-Inf,Inf)|{0}" C5 = "7-9-10-22: (0,1]" C6 = "11: (0, 1/2]" C7 = "13-16-19-20: (0,Inf)" C8 = "18: [2, Inf)" C = c( C1, C2, C3, C4, C5, C6, C7, C8 ) L = c( -1, 1, -1, -B, 0, 0, 0, 2 ) U = c( B, B, 1, B, 1, 0.5, B, B ) A = c( 0.5, 2, 0.5, 1, 0.5, 0.2, 1, 3 ) V = rep(0.01, 8) plot.names = c("Plot - theta", "... phi") .sliderMenu(refresh.code, names = c("Copula", "N", C, plot.names), minima = c( 1, 10, L, -180, 0), maxima = c( 22, 100, U, 180, 360), resolutions = c( 1, 10, V, 1, 1), starts = c( 1, 10, A, -40, 30)) } # ------------------------------------------------------------------------------ .parchmContourSlider <- function(B = 5) { # A function implemented by Diethelm Wuertz # Description: # Displays interactively perspective plots of probability #FUNCTION: # Graphic Frame: par(mfrow = c(1, 1)) # Internal Function: refresh.code = function(...) { # Sliders: # 1 5 10 15 20 Counter = c(1,2,3,2,4,2,5,2,5,5,6,2,7,2,2,7,4,8,7,7,2,5) Copula = as.integer(.sliderMenu(no = 1)) No = Counter[Copula] N = .sliderMenu(no = 2) alpha = .sliderMenu(no = No+2) n.lev = .sliderMenu(no = 11) n.col = .sliderMenu(no = 12) # Skip: if (Copula == 11) if (alpha == 0.5) return(invisible()) if (Copula == 13) if (alpha == 0) return(invisible()) # Do we have a strict Copula? strict = c( "Yes","No","Yes","Yes","Yes","Yes","No","No","Yes","Yes", "No","Yes","Yes","Yes","No","Yes","Yes","No","Yes","Yes", "No","Yes")[Copula] if (alpha < 0 & Copula == 1) strict[1] = "No" if (alpha == 0 & Copula == 16) strict[16] = "No" # What is the Range? RANGE = c( "[-1|Inf)", "[1|Inf)", "[-1|1)", "(-Inf|Inf)", "(0|1]", "(0|0.5]", "(0|Inf)", "[2|Inf)")[No] # Which one is the Limit Copula? limitTitle = rep("NA", times = 22) if (alpha == -1) limitTitle = c( "W ", "NA", "NA", "NA", "NA", "NA", "NA", "NA", "NA", "NA", "NA", "NA", "NA", "NA", "NA", "NA", "Pi", "NA", "NA", "NA", "NA", "NA") if (alpha == 0) limitTitle = c( "Pi", "NA", "Pi", "NA", "Pi", "NA", "W ", "NA", "Pi", "Pi", "Pi", "NA", "NA", "NA", "NA", "W ", "NA", "NA", "L ", "Pi", "NA", "Pi") if (alpha == 1) limitTitle = c( "L ", "W ", "L ", "Pi", "NA", "Pi", "Pi", "W ", "NA", "NA", "NA", "L ", "Pi", "L ", "W ", "NA", "NA", "NA", "NA", "NA", "W ", "NA") limitTitle = limitTitle[Copula] if (limitTitle == "NA") { limitTitle = " " } else { limitTitle = paste(" Copula = ", limitTitle[1]) } # Tau/Rho: Tau = round(approx(.ALPHA[, Copula], .TAU[, Copula], xout = alpha)$y, digits = 3) Rho = round(approx(.ALPHA[, Copula], .RHO[, Copula], xout = alpha)$y, digits = 3) # Title: Names = c( "- Clayton", "", "- Ali-Mikhail-Hag", "- Gumbel-Hougard", "- Frank", "- Joe-Frank", "", "", "- Gumbel-Barnett", "", "", "", "", "", "- Genest-Ghoudi", "", "", "", "", "", "", "") Title = paste("Archimedean Copula No:", as.character(Copula), Names[Copula], "\n", RANGE, " alpha =", as.character(alpha), " tau =", as.character(Tau), " rho =", as.character(Rho)) # Plot: uv = grid2d(x = (0:N)/N) P = .parchm1Copula(u = uv, alpha = alpha, type = Copula, output = "list") image(P, col = heat.colors(n.col) ) contour(P, xlab = "u", ylab = "v", nlevels = n.lev, add = TRUE) title(main = Title) # Reset Frame: par(mfrow = c(1, 1)) } # Open Slider Menu: C1 = "1: [-1,Inf]" C2 = "2-4-6-8-12-14-15-21: [1,Inf)" C3 = "3: [-1,1)" C4 = "5-17: (-Inf,Inf)|{0}" C5 = "7-9-10-22: (0,1]" C6 = "11: (0, 1/2]" C7 = "13-16-19-20: (0,Inf)" C8 = "18: [2, Inf)" C = c( C1, C2, C3, C4, C5, C6, C7, C8 ) L = c( -1, 1, -1, -B, 0, 0, 0, 2 ) U = c( B, B, 1, B, 1, 0.5, B, B ) A = c( 0.5, 2, 0.5, 1, 0.5, 0.2, 1, 3 ) V = rep(0.01, 8) plot.names = c("Plot - levels", "... colors") .sliderMenu(refresh.code, names = c("Copula", "N", C, plot.names), minima = c( 1, 10, L, 5, 12), maxima = c( 20, 100, U, 100, 256), resolutions = c( 1, 10, V, 5, 1), starts = c( 1, 10, A, 10, 12)) } ################################################################################ darchmSlider <- function(type = c("persp", "contour"), B = 10) { # A function implemented by Diethelm Wuertz # Description: # Displays interactively plots of density # Arguments: # type - a character string specifying the plot type. # Either a perspective plot which is the default or # a contour plot with an underlying image plot will # be created. # B - the maximum slider menu value when the boundary # value is infinite. By default this is set to 10. # FUNCTION: # Match Arguments: type = match.arg(type) # Plot: if (type == "persp") .darchmPerspSlider(B = B) if (type == "contour") .darchmContourSlider(B = B) # Return Value: invisible() } # ------------------------------------------------------------------------------ .darchmPerspSlider <- function(B = 10) { # A function implemented by Diethelm Wuertz # Description: # Displays interactively perspective plots of density # FUNCTION: # Graphic Frame: par(mfrow = c(1, 1)) # Internal Function: refresh.code = function(...) { # Sliders: Counter = c(1,2,3,2,4,2,5,2,5,5,6,2,7,2,2,7,4,8,7,7,2,5) Copula = as.integer(.sliderMenu(no = 1)) No = Counter[Copula] N = .sliderMenu(no = 2) alpha = .sliderMenu(no = No+2) theta = .sliderMenu(no = 11) phi = .sliderMenu(no = 12) # Skip: if (Copula == 11) if (alpha == 0.5) return(invisible()) if (Copula == 13) if (alpha == 0) return(invisible()) # Do we have a strict Copula? strict = c( "Yes","No","Yes","Yes","Yes","Yes","No","No","Yes","Yes", "No","Yes","Yes","Yes","No","Yes","Yes","No","Yes","Yes", "No","Yes")[Copula] if (alpha < 0 & Copula == 1) strict[1] = "No" if (alpha == 0 & Copula == 16) strict[16] = "No" # What is the Range? RANGE = c( "[-1|Inf)", "[1|Inf)", "[-1|1)", "(-Inf|Inf)", "(0|1]", "(0|0.5]", "(0|Inf)", "[2|Inf)")[No] # Which one is the Limit Copula? limitTitle = rep("NA", times = 22) if (alpha == -1) limitTitle = c( "W ", "NA", "NA", "NA", "NA", "NA", "NA", "NA", "NA", "NA", "NA", "NA", "NA", "NA", "NA", "NA", "Pi", "NA", "NA", "NA", "NA", "NA") if (alpha == 0) limitTitle = c( "Pi", "NA", "Pi", "NA", "Pi", "NA", "W ", "NA", "Pi", "Pi", "Pi", "NA", "NA", "NA", "NA", "W ", "NA", "NA", "L ", "Pi", "NA", "Pi") if (alpha == 1) limitTitle = c( "L ", "W ", "L ", "Pi", "NA", "Pi", "Pi", "W ", "NA", "NA", "NA", "L ", "Pi", "L ", "W ", "NA", "NA", "NA", "NA", "NA", "W ", "NA") limitTitle = limitTitle[Copula] if (limitTitle == "NA") { limitTitle = " " } else { limitTitle = paste(" Copula = ", limitTitle[1]) } # Tau/Rho: Tau = round(approx(.ALPHA[, Copula], .TAU[, Copula], xout = alpha)$y, digits = 3) Rho = round(approx(.ALPHA[, Copula], .RHO[, Copula], xout = alpha)$y, digits = 3) # Title: Names = c( "- Clayton", "", "- Ali-Mikhail-Hag", "- Gumbel-Hougard", "- Frank", "- Joe-Frank", "", "", "- Gumbel-Barnett", "", "", "", "", "", "- Genest-Ghoudi", "", "", "", "", "", "", "") Title = paste("Archimedean Copula No:", as.character(Copula), Names[Copula], "\n", RANGE, " alpha =", as.character(alpha), " tau =", as.character(Tau), " rho =", as.character(Rho)) # Plot: uv = grid2d(x = (1:(N-1))/N) D = .darchm1Copula(u = uv, alpha = alpha, type = as.character(Copula), output = "list") persp(D, theta = theta, phi = phi, col = "steelblue", shade = 0.5, ticktype = "detailed", cex = 0.5, xlab = "u", ylab = "v", zlab = "C(u,v)" ) title(main = Title) # Reset Frame: par(mfrow = c(1, 1)) } # Open Slider Menu: B = 5 C1 = "1: [-1,Inf]" C2 = "2-4-6-8-12-14-15-21: [1,Inf)" C3 = "3: [-1,1)" C4 = "5-17: (-Inf,Inf)|{0}" C5 = "7-9-10-22: (0,1]" C6 = "11: (0, 1/2]" C7 = "13-16-19-20: (0,Inf)" C8 = "18: [2, Inf)" C = c( C1, C2, C3, C4, C5, C6, C7, C8 ) L = c( -1, 1, -1, -B, 0, 0, 0, 2 ) U = c( B, B, 1, B, 1, 0.5, B, B ) A = c( 0.5, 2, 0.5, 1, 0.5, 0.2, 1, 3 ) V = rep(0.1, 8) plot.names = c("Plot - theta", "... phi") .sliderMenu(refresh.code, names = c("Copula", "N", C, plot.names), minima = c( 1, 10, L, -180, 0), maxima = c( 22, 100, U, 180, 360), resolutions = c( 1, 10, V, 1, 1), starts = c( 1, 20, A, -40, 30)) } # ------------------------------------------------------------------------------ .darchmContourSlider <- function(B = 10) { # A function implemented by Diethelm Wuertz # Description: # Displays interactively perspective plots of density #FUNCTION: # Graphic Frame: par(mfrow = c(1, 1)) # Internal Function: refresh.code = function(...) { # Sliders: Counter = c(1,2,3,2,4,2,5,2,5,5,6,2,7,2,2,7,4,8,7,7,2,5) Copula = as.integer(.sliderMenu(no = 1)) No = Counter[Copula] N = .sliderMenu(no = 2) alpha = .sliderMenu(no = No+2) n.lev = .sliderMenu(no = 11) n.col = .sliderMenu(no = 12) # Skip: if (Copula == 11) if (alpha == 0.5) return(invisible()) if (Copula == 13) if (alpha == 0) return(invisible()) # Do we have a strict Copula? strict = c( "Yes","No","Yes","Yes","Yes","Yes","No","No","Yes","Yes", "No","Yes","Yes","Yes","No","Yes","Yes","No","Yes","Yes", "No","Yes")[Copula] if (alpha < 0 & Copula == 1) strict[1] = "No" if (alpha == 0 & Copula == 16) strict[16] = "No" # What is the Range? RANGE = c( "[-1|Inf)", "[1|Inf)", "[-1|1)", "(-Inf|Inf)", "(0|1]", "(0|0.5]", "(0|Inf)", "[2|Inf)")[No] # Which one is the Limit Copula? limitTitle = rep("NA", times = 22) if (alpha == -1) limitTitle = c( "W ", "NA", "NA", "NA", "NA", "NA", "NA", "NA", "NA", "NA", "NA", "NA", "NA", "NA", "NA", "NA", "Pi", "NA", "NA", "NA", "NA", "NA") if (alpha == 0) limitTitle = c( "Pi", "NA", "Pi", "NA", "Pi", "NA", "W ", "NA", "Pi", "Pi", "Pi", "NA", "NA", "NA", "NA", "W ", "NA", "NA", "L ", "Pi", "NA", "Pi") if (alpha == 1) limitTitle = c( "L ", "W ", "L ", "Pi", "NA", "Pi", "Pi", "W ", "NA", "NA", "NA", "L ", "Pi", "L ", "W ", "NA", "NA", "NA", "NA", "NA", "W ", "NA") limitTitle = limitTitle[Copula] if (limitTitle == "NA") { limitTitle = " " } else { limitTitle = paste(" Copula = ", limitTitle[1]) } # Tau/Rho: Tau = round(approx(.ALPHA[, Copula], .TAU[, Copula], xout = alpha)$y, digits = 3) Rho = round(approx(.ALPHA[, Copula], .RHO[, Copula], xout = alpha)$y, digits = 3) # Title: Names = c( "- Clayton", "", "- Ali-Mikhail-Hag", "- Gumbel-Hougard", "- Frank", "- Joe-Frank", "", "", "- Gumbel-Barnett", "", "", "", "", "", "- Genest-Ghoudi", "", "", "", "", "", "", "") Title = paste("Archimedean Copula No:", as.character(Copula), Names[Copula], "\n", RANGE, " alpha =", as.character(alpha), " tau =", as.character(Tau), " rho =", as.character(Rho)) # Plot: uv = grid2d(x = (1:(N-1)/N)) D = .darchm1Copula(u = uv, alpha = alpha, type = as.character(Copula), output = "list") image(D, xlim = c(0, 1), ylim = c(0,1), col = heat.colors(n.col) ) contour(D, xlab = "u", ylab = "v", nlevels = n.lev, add = TRUE) title(main = Title) # Reset Frame: par(mfrow = c(1, 1)) } # Open Slider Menu: B = 5 C1 = "1: [-1,Inf]" C2 = "2-4-6-8-12-14-15-21: [1,Inf)" C3 = "3: [-1,1)" C4 = "5-17: (-Inf,Inf)|{0}" C5 = "7-9-10-22: (0,1]" C6 = "11: (0, 1/2]" C7 = "13-16-19-20: (0,Inf)" C8 = "18: [2, Inf)" C = c( C1, C2, C3, C4, C5, C6, C7, C8 ) L = c( -1, 1, -1, -B, 0, 0, 0, 2 ) U = c( B, B, 1, B, 1, 0.5, B, B ) A = c( 0.5, 2, 0.5, 1, 0.5, 0.2, 1, 3 ) V = rep(0.1, 8) plot.names = c("Plot - levels", "... colors") .sliderMenu(refresh.code, names = c("Copula", "N", C, plot.names), minima = c( 1, 10, L, 10, 12), maxima = c( 22, 100, U, 100, 256), resolutions = c( 1, 10, V, 10, 1), starts = c( 1, 30, A, 30, 64)) } fCopulae/R/ArchimedeanDependency.R0000644000176200001440000003663214265245633016557 0ustar liggesusers # 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: KENDALL'S TAU AND SPEARMAN'S RHO: # archmTau Returns Kendall's tau for Archemedean copulae # archmRho Returns Spearman's rho for Archemedean copulae # .archmTauRange Returns range for Kendall's tau # .archm2Tau Alternative way to compute Kendall's tau # ### .archmGamma Returns Gini's gamma for Archimedean copulae # .archmTail Utility Function # FUNCTION: ARCHIMEDEAN COPULAE TAIL COEFFICIENT: # archmTailCoeff Computes tail dependence for Archimedean copulae # archmTailPlot Plots Archimedean tail dependence function # REQUIREMENT: DESCRIPTION: # adapt Contributed R package adapt ################################################################################ ################################################################################ # FUNCTION KENDALL'S TAU AND SPEARMAN'S RHO: # archmTau Returns Kendall's tau for Archemedean copulae # archmRho Returns Spearman's rho for Archemedean copulae # .archmTauRange Returns range for Kendall's tau # .archm2Tau Alternative way to compute Kendall's tau # .archmGamma Returns Gini's gamma for Archimedean copulae # .archmTail Utility Function archmTau <- function(alpha = NULL, type = archmList(), lower = 1.0e-10) { # A function implemented by Diethelm Wuertz # Description: # Kendall's tau by integration for Archimedean copulae # FUNCTION: # Settings: type = match.arg(type) Type = as.integer(type) # Alpha: if (is.null(alpha)) alpha = archmParam(type)$param # Check alpha: check = archmCheck(alpha, type) # Compute tau: if (length(alpha) == 1) { ans = .archmTau(alpha, type, lower) names(ans) = "Tau" names(alpha) = "alpha" } else { ans = NULL for ( i in 1:length(alpha) ) ans = c(ans, .archmTau(alpha[i], type, lower)[1]) names(ans) = paste("Tau", 1:length(alpha), sep = "") names(alpha) = paste("alpha", 1:length(alpha), sep = "") } # Add Control Attribute: attr(ans, "control")<-cbind.data.frame( t(alpha), type = type, lower = lower, row.names= "") # Return Value: ans } # ------------------------------------------------------------------------------ .archmTau <- function(alpha = NULL, type = archmList(), lower = 1.0e-10) { # A function implemented by Diethelm Wuertz # Description: # Kendall's tau by integration for Archimedean copulae # FUNCTION: # Type: type <- match.arg(type) Type <- as.integer(type) # Alpha: if (is.null(alpha)) alpha = archmParam(type)$param # Check alpha: check = archmCheck(alpha, type) # Select Type: if (Type == 1) { if (alpha == -1) return(-1) if (alpha == 0) return(0) tau = alpha/(alpha+2) return(tau) } else if (Type == 2) { if (alpha == 1) return(-1) tau = 1 - 2/alpha return(tau) } else if (Type == 3 & alpha == 0) { return(0) # tau numeric } else if (Type == 3 & alpha == 1) { return(1/3) # tau numeric } else if (Type == 4) { if (alpha == 1) return(0) tau = 1 - 1/alpha return(tau) } else if (Type == 5 & alpha == 0) { return(0) # tau numeric } else if (Type == 6 & alpha == 1) { return(0) } else if (Type == 7) { if (alpha == 0) return(1) if (alpha == 1) return(0) tau = 2*(1-alpha)*(alpha+log(1-alpha)-alpha*log(1-alpha))/alpha^2 return(tau) } else if (Type == 8) { if (alpha == 1) return(-1) tau = (-4+alpha)/(3*alpha) return(tau) } else if (Type == 9 & alpha == 0) { return(0) # tau numeric } else if (Type == 10 & alpha == 0) { return(0) # tau numeric } else if (Type == 11 & alpha == 0) { return(0) } else if (Type == 12) { tau = 1 - 2/(3*alpha) return(tau) } else if (Type == 13 & alpha == 1) { return(0) # tau numeric } else if (Type == 13 & alpha == 0) { return(-0.3613289) # 1e-8 value } else if (Type == 14) { tau = 1 - 4/(2+4*alpha) return(tau) } else if (Type == 15) { if (alpha == 1) return(-1) tau = 1 + 4/(2-4*alpha) return(tau) } else if (Type == 16 & alpha == 0) { return(-1) # tau numeric } else if (Type == 17 & alpha == -1) { return(0) # tau numeric } else if (Type == 18) { tau = 1 - 4/(3*alpha) return(tau) } else if (Type == 19 & alpha == 0) { return(0) # tau numeric } else if (Type == 20 & alpha == 0) { return(1/3) # tau numeric # } else if (Type == 21) { # tau numeric # } else if (Type == 22) { # tau numeric } else { # Integrate: ans = integrate( f = .Kfunc, lower = lower, upper = 1, alpha = alpha, type = type, stop.on.error = FALSE, rel.tol = .Machine$double.eps^0.5) tau = 3 - 4 * ans[[1]] attr(tau, "control")<-unlist(c(alpha, type = type, ans[2:4])) return(tau) } # Return Value: invisible() } # ------------------------------------------------------------------------------ .archmTauRange <- function(type = archmList()) { # A function implemented by Diethelm Wuertz # FUNCTION: # Type: type = match.arg(type) Type = as.integer(type) # Range: range = matrix( c( 1, -1, 1, 2, -1, 1, 3, -0.182, 1/3, 4, 0, 1, 5, -1, 1, 6, 0, 1, 7, 0, 1, 8, -1, 1/3, 9, 0, 0.361, 10, 0, 0.182, 11, 0,-0.565, 12, 1/3, 1, 13, 0.361, NA, 14, 1/3, 1, 15, -1, 1, 16, NA, 1/3, 17, -1, 1, 18, 1/3, 1, 19, 1/3, 1, 20, 0, 1, 21, NA, NA, 22, NA, NA ), byrow = TRUE, ncol = 3 ) # Result: ans <- range[Type, ][-1] names(ans) <- c("tau.lower", "tau.upper") attr(ans, "control") <- c(type = type) # Return Value: ans } # ------------------------------------------------------------------------------ .archm2Tau <- function (alpha = NULL, type = archmList(), lower = 1e-6) { # A function implemented by Diethelm Wuertz # Joe's [1997] alternative expression: # Type: type = match.arg(type) Type = as.integer(type) # Alpha: if (is.null(alpha)) alpha = archmParam(type)$param # Check alpha: check = archmCheck(alpha, type) # Integrate: K2func = function(x, alpha, type) { x * .invPhiFirstDer(x, alpha, type)^2 } upper = .Phi(0, alpha, type) - lower ans = integrate(f = K2func, lower = lower, upper = upper, alpha = alpha, type = type) tau = 1 - 4 * ans[[1]] attr(tau, "control") <- unlist(c(alpha, type = type, ans[2:4])) # Return Value: tau } # ------------------------------------------------------------------------------ archmRho <- function(alpha = NULL, type = archmList(), method = c("integrate2d", "adapt"), error = 1.0e-5) { # A function implemented by Diethelm Wuertz # Description: # Spearman's Rho by integration for Archimedean copulae # FUNCTION: # Match Arguments: method = match.arg(method) # Type: type = match.arg(type) Type = as.integer(type) # Alpha: if (is.null(alpha)) alpha = archmParam(type)$param # Check alpha: check = archmCheck(alpha, type) # Compute Rho: if (length(alpha) == 1) { ans = .archmRho(alpha, type, method, error) names(ans) = "Rho" names(alpha) = "alpha" } else { ans = NULL for ( i in 1:length(alpha) ) ans = c(ans, .archmRho(alpha[i], type, method, error)[1]) names(ans) = paste("Rho", 1:length(alpha), sep = "") names(alpha) = paste("alpha", 1:length(alpha), sep = "") } # Add Control Attribute: attr(ans, "control")<-cbind.data.frame( t(alpha), type = type, method = method, error = error, row.names= "") # Return Value: ans } # ------------------------------------------------------------------------------ .archmRho <- function(alpha = NULL, type = archmList(), method = c("integrate2d", "adapt"), error = 1.0e-5) { # A function implemented by Diethelm Wuertz # Description: # Spearman's rho by integration for Archimedean copulae # Requirements: # Note, method="adapt" requires R-Package adapt # FUNCTION: # Match Arguments: method <- match.arg(method) # Type: type <- match.arg(type) Type <- as.integer(type) # Alpha: if (is.null(alpha)) alpha = archmParam(type)$param # Check alpha: check = archmCheck(alpha, type) # Global Parameters: ## alpha <<- alpha ## type <<- type # 2D Integration: if (method == "integrate2d" ) { # Internal Function : fun.integrate2d = function(x, y, alpha, type ) { 12 * (.parchm1Copula(x, y, alpha = alpha, type = type) - x*y ) } ans = integrate2d(fun.integrate2d, error = error, alpha = alpha, type = type) } else if (method == "adapt") { # Requires contributed package adapt ... fun.adapt = function(z, alpha, type) { x = z[1] y = z[2] 12 * (.parchm1Copula(x, y, alpha = alpha, type = type) - x*y) } ans = adapt(ndim = 2, lower = c(0, 0), upper = c(1, 1), minpts = 100, maxpts = NULL, functn = fun.adapt, eps = 0.01, alpha = alpha, type = type) } rho = ans$value # Result: control = list(alpha = alpha[[1]]) attr(rho, "control") <- unlist(control) # Return Value: rho } # ------------------------------------------------------------------------------ # .archmGamma <- # function(alpha = 0.5, type = archmList()) # { # A function implemented by Diethelm Wuertz # # # Description: # # Gini's gamma by integration for Archimedean copulae # # # FUNCTION: # # # Type: # type = match.arg(type) # Type = as.integer(type) # # # Check alpha: # check = archmCheck(alpha, type) # # # Specification: # spec = copulaSpec("archm", model = list(alpha = alpha, type = type)) # # # Internal Function: # fun = function(x, spec) { # f = NULL # for ( y in x ) # f = c( f, 4*(pcopula(y, y, spec) + pcopula(y, 1-y, spec) - y) ) # f } # # # Integration: # ans = integrate(fun, c(0, 0), c(1, 1), spec = spec) # # # Result: # gamma = ans$value # attr(gamma, "control") <- unlist(ans[-1]) # # # Return Value: # gamma # } ################################################################################ # FUNCTION: ARCHIMEDEAN COPULAE TAIL COEFFICIENT: # archmTailCoeff Computes tail dependence for Archimedean copulae # archmTailPlot Plots Archimedean tail dependence function archmTailCoeff <- function(alpha = NULL, type = archmList()) { # A function implemented by Diethelm Wuertz # Description: # Tail Dependence for Archimedean copulae # FUNCTION: # Type: type = match.arg(type) Type = as.integer(type) # Alpha: if (is.null(alpha)) alpha = archmParam(type)$param # Check alpha: check = archmCheck(alpha, type) # Tail Coefficient: N = 20 x = 1 - (1/2)^(1:N) lambdaU.Cuv = ( 1 - 2*x + parchmCopula(u = x, v = x, alpha = alpha, type = type) ) / (1-x) lambdaU.Phi = 2 - 2 * .invPhiFirstDer(2*x, alpha = alpha, type = type) / .invPhiFirstDer(x, alpha = alpha, type = type) # Return Value: list(lambdaU.Cuv = lambdaU.Cuv, lambdaU.Phi = lambdaU.Phi) } # ------------------------------------------------------------------------------ archmTailPlot <- function(alpha = NULL, type = archmList(), tail = c("Upper", "Lower")) { # A function implemented by Diethelm Wuertz # Description: # Plots tail dependence for elliptical copulae # Arguments: # rho - a numeric value setting the coorelation strength, ranging # between minus one and one. # FUNCTION: # Match Arguments: type = match.arg(type) Type = as.integer(type) tail = match.arg(tail) # Settings: Title = paste("Archimedean Copula No.", 1:22) names(Title) = paste(1:22) Title = Title[type] N = 1000; Points = 20 # don't change these values! u = (0:N)/N # Plot Frame: plot(c(0, 1), c(0, 1), type = "n", main = Title, xlab = "u", ylab = paste(tail, "Tail Dependence")) # Iterate alpha: B = 10 lower = max(archmRange(type)[1], -B) upper = min(archmRange(type)[2], B) # Select alpha: if (is.null(alpha)) { # from range: Alpha = seq(lower, upper, length = 5) } else { # from arguments: Alpha = alpha } # Do for all alpha: for (alpha in Alpha) { # Compute Copula Tail dependence lambda: C.uu = parchmCopula(u, alpha = alpha, type = type) if (tail == "Upper") { lambdaTail = (1-2*u+C.uu)/(1-u) } else if (tail == "Lower") { lambdaTail = C.uu/u } # Add Parameter Labels: text(x = 0.52, y = lambdaTail[floor(N/2)]+0.025, col = "red", cex = 0.7, labels = as.character(round(alpha, 2))) # Add Lines: lines(u, lambdaTail, lty = 3, col = "black") # Add Points to Curves: if (tail == "Upper") { Index = round(seq(1, N-1, length = Points)) X = 1 } else if (tail == "Lower") { Index = round(seq(1, N-1, length = Points)) + 1 X = 0 } points(u[Index], lambdaTail[Index], col = "steelblue", pch = 19, cex = 0.7) } abline(h = 0, lty = 3, col = "grey") abline(v = X, lty = 3, col = "grey") # Return Value: invisible() } ################################################################################ fCopulae/R/EmpiricalCopulae.R0000644000176200001440000001262514265245633015572 0ustar liggesusers # 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: EMPIRICAL COPULAE PROBABILIY: # pempiricalCopula Computes empirical copula probability # FUNCTION: EMPIRICAL COPULAE DENSITY: # dempiricalCopula Computes empirical copula density # FUNCTION: DEBYE FUNCTION: # .Debye Returns the value of the Debye function of order k # .Debye1 Returns the value of the Debye function of order 1 # FUNCTION: # .pmoCopula # .dmoCopula ################################################################################ ################################################################################ # FUNCTION: EMPIRICAL COPULAE PROBABILIY: # pempiricalCopula Computes empirical copula probability pempiricalCopula <- function(u, v, N = 10) { # A function implemented by Diethelm Wuertz # Description # Computes the empirical copula probability # Source: # bouye02a.pdf # FUNCTION: # Settings: if (is.list(u)) { v = u[[2]] u = u[[1]] } if (is.matrix(u)) { v = u[, 1] u = u[, 2] } # Probability: p = q = (0:N)/N h = matrix(rep(0, times = (N+1)^2), N+1) for ( i in (0:N) ) { for ( j in (0:N) ) { z = Heaviside(u, p[i+1]) + Heaviside(v, q[j+1]) h[j+1, i+1] = length(z[z == 0]) } } h = h/length(u) # Return Value: list(x = p, y = q, z = h) } ################################################################################ # FUNCTION: EMPIRICAL COPULAE DENSITY: # dempiricalCopula Computes empirical copula density dempiricalCopula <- function(u, v, N = 10) { # A function implemented by Diethelm Wuertz # Description # Computes the empirical copula probability # Source: # bouye02a.pdf # FUNCTION: # Settings: if (is.list(u)) { v = u[[2]] u = u[[1]] } if (is.matrix(u)) { v = u[, 1] u = u[, 2] } # Probability: ans = pempiricalCopula(u, v, N) X = ans$x Y = ans$y C = ans$z # Density: M = N+1 x = X[-1] - diff(X)/2 y = Y[-1] - diff(Y)/2 c = C[-1,-1]+C[-M,-M]-C[-1,-M]-C[-M,-1] # Return Value: list(x = x, y = y, z = c) } ################################################################################ # FUNCTION: DEBYE FUNCTION: # .Debye Returns the value of the Debye function of order k # .Debye1 .Debye <- function(x, k = 1) { # A function implemented by Diethelm Wuertz # Description: # Returns the value of the Debye function of order k # Arguments: # x - a numeric value or vector # k - the order of the Debye function, a positive integer value # FUNCTION: # Check: if (!is.integer(k) | k <= 0) stop("k must be a positive integer") # Loop: D = NULL error = NULL for ( i in 1:length(x) ) { nextD = .Debye1(x[i],k) D = c(D, nextD[[1]]) error = c(error, nextD[[2]]) } # Add error attribute: attr(D, "error") = error # Return Value: D } # ------------------------------------------------------------------------------ .Debye1 <- function(x, k = 1) { # A function implemented by Diethelm Wuertz # FUNCTION: # Function to be integrated: d = function(x, lambda) { x^lambda / ( exp(x) - 1 ) } # Integrate: u = abs(x) if (x == 0) { D = 1 error = 0 } else { ans = integrate(f = d, lower = 0, upper = u, lambda = k) D = k * ans[[1]] / u^k error = ans[[2]] } if (x < 0) { D = D + k*u/(k+1) } # Return Value: list(D = D, error = error) } ################################################################################ # FUNCTION: # .pmoCopula # .dmoCopula .pmoCopula <- function(u = 0.5, v = u, alpha = NULL) { if (is.null(alpha)) alpha = c(0.5, 0.5) alpha1 = alpha[1] alpha2 = alpha[2] U = u^(1-alpha1) * v V = u * v^(1-alpha2) UV = cbind(U,V) apply(UV, 1, max) } # ------------------------------------------------------------------------------ .dmoCopula <- function(u = 0.5, v = u, alpha = NULL) { if (is.null(alpha)) alpha = c(0.5, 0.5) alpha1 = alpha[1] alpha2 = alpha[2] U = u^(1-alpha1) * v V = u * v^(1-alpha2) UV = cbind(U,V) apply(UV, 1, max) } ################################################################################ fCopulae/MD50000644000176200001440000000636114356373443012342 0ustar liggesusers098b86eccc9d2c314ead0418bf493955 *ChangeLog 3cf99cf568e2d3aa9331568723af9898 *DESCRIPTION 9d365d9b1fff0b1a443e7a7bcdade222 *NAMESPACE b8d5908432d8c6a53460e80c917489a6 *R/ArchimedeanCopulae.R 2ecff1b4ef03dca8bd390416e70d7728 *R/ArchimedeanDependency.R f1d90931e92891488195c69aa258a21a *R/ArchimedeanGenerator.R da9998da89be52ffc8a917768c86511b *R/ArchimedeanModelling.R d1448727aeb5c2bfb70ea051f3d29b14 *R/ArchimedeanSlider.R 6bab46620fac6baf5493156b3c0874a9 *R/EllipticalCopulae.R d648d61dfc570f419e48ea47a03779aa *R/EllipticalDependency.R 4fa6db2ede6ff3999d42506461aa6c11 *R/EllipticalGenerator.R ff1b598b5b38c986cb9ae589348bca3c *R/EllipticalModelling.R 83b5f567bddea6a012c6b1dfd5778843 *R/EmpiricalCopulae.R 645ca0158a158f51982d750fa11fb3d0 *R/ExtremeValueCopulae.R fd6d1f817a41bfea6b205c75000999ba *R/ExtremeValueDependency.R 88172d828a93cbf37f4782ab1d9e7078 *R/ExtremeValueGenerator.R dccbc5d81da8cecb6c2d24a43a0488f0 *R/ExtremeValueModelling.R 24b6e829324e611e40b53f598f99020e *R/aaaCopulaeClass.R cc66b4093da5eaf07f5692f598fed2a3 *R/aaaCopulaeEnv.R 03c202578e38501cae6fb4e1c599c7e2 *R/zzz.R 5073775e2caf6351d1b1e15479b1c73c *inst/unitTests/Makefile 15d9197eafec4b5e5bda5249e9e3f8dc *inst/unitTests/runTests.R ae0c5c6d8359da416c80a253ed6c0f75 *inst/unitTests/runit.ArchimedeanCopulae.R c621d826877c3bfa872a49a1065d47f1 *inst/unitTests/runit.ArchimedeanDependency.R c88b95efbb2d4bc75b1ebd9df8aeb8a3 *inst/unitTests/runit.ArchimedeanGenerator.R d38397d2fc0dc6eb89002fefaf079088 *inst/unitTests/runit.ArchimedeanModelling.R 8ceae4c74d1cb701634a4cf7a1eaea3d *inst/unitTests/runit.EllipticalCopulae.R dcedc8a4dd5069a1d7688659a649e145 *inst/unitTests/runit.EllipticalDependency.R 42d75060cf879d166823264a80794fe2 *inst/unitTests/runit.EllipticalGenerator.R 92f244d8f50bb1beaafca75103c77938 *inst/unitTests/runit.EllipticalModelling.R 2ec7439e6cca7f30bb1ee18b4d55102d *inst/unitTests/runit.EmpiricalCopulae.R 5438f55742a20e12ad93e2cd03ca794e *inst/unitTests/runit.ExtremeValueCopulae.R a6345f50524edc1f8b467a0bc554ee84 *inst/unitTests/runit.ExtremeValueDependency.R 9a51f166fa789c12d60982413ab8dd4a *inst/unitTests/runit.ExtremeValueModelling.R df81a4997de286f18c9b699b90f462a3 *inst/unitTests/runit.ExtrmeValueGenerator.R c812d9fca2be1e1ae085f282b1d291c1 *inst/unitTests/runit.aaaCopulaClass.R b6c70ab404057c7d41615ab1827d57f8 *man/00fCopulae-package.Rd 90072dc7563f14dcea9fd5efa62d06f1 *man/ArchimedeanCopulae.Rd 0ed0a793f6c4f19edffd48e634de74f2 *man/ArchimedeanDependency.Rd 34e50b7a0e7f34c599ec2455c0b1ea1b *man/ArchimedeanGenerator.Rd 24e3120bde46175dd44cec2bec363f13 *man/ArchimedeanModelling.Rd 2f31dc62ac9fc4607a935c0b7ca8af79 *man/EllipticalCopulae.Rd ff0441ac8f168bb6032243af29737a51 *man/EllipticalDependency.Rd 3cb9708247c68983ddfc8b02fe6cf774 *man/EllipticalGenerator.Rd 160fddf4faf3ea6c218d01c28a5b6107 *man/EllipticalModelling.Rd ab3c21c844982a45425329cbc5a72c36 *man/EmpiricalCopulae.Rd 7ea7f3cd54e2f80cddbd5ada672e6805 *man/ExtremeValueCopulae.Rd 7fed36f79e52e62318335bed37d746ca *man/ExtremeValueDependency.Rd 041c895cf8dd9f181fb9ff7b4ed15875 *man/ExtremeValueGenerator.Rd 2f6c7b7aa20fb72e73764713a3e2d3b7 *man/ExtremeValueModelling.Rd f90fde38f6c413e80f56f77fa13d065d *man/aaaCopulaClass.Rd 36e22401a240adfdad1ebea7a571e1f3 *man/aaaCopulaEnv.Rd ca566e590ec30abd0718c5375e1a446f *tests/doRUnit.R fCopulae/inst/0000755000176200001440000000000014265250751012774 5ustar liggesusersfCopulae/inst/unitTests/0000755000176200001440000000000014350706244014774 5ustar liggesusersfCopulae/inst/unitTests/runit.EllipticalGenerator.R0000644000176200001440000001730114265245633022217 0ustar liggesusers # 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 # Copyrights (C) # for this R-port: # 1999 - 2007, Diethelm Wuertz, GPL # Diethelm Wuertz # info@rmetrics.org # www.rmetrics.org # for the code accessed (or partly included) from other R-ports: # see R's copyright and license files # for the code accessed (or partly included) from contributed R-ports # and other sources # see Rmetrics's copyright file ################################################################################ # FUNCTION: UTILITY FUNCTIONS: # ellipticalList Returns list of implemented Elliptical copulae # ellipticalParam Sets default parameters for an elliptical copula # ellipticalRange Returns the range of valid rho values # ellipticalCheck Checks if rho is in the valid range # FUNCTION: ELLIPTICAL GENERATOR AND RELATED FUNCTIONS: # gfunc Generator function for elliptical distributions # gfuncSlider Slider for generator, density and probability # .pelliptical Univariate elliptical distribution probability # .delliptical Univariate elliptical distribution density # .qelliptical Univariate elliptical distribution quantiles ################################################################################ test.ellipticalList = function() { # Arguments ? args(ellipticalList) # List: target = c("norm", "cauchy", "t", "logistic", "laplace", "kotz", "epower") current = ellipticalList() print(current) # Return Value: return() } # ------------------------------------------------------------------------------ test.ellipticalRange = function() { # Arguments ? args(ellipticalRange) # Range: for (type in ellipticalList()) { cat("\n") print(ellipticalRange(type)) } # Return Value: return() } # ------------------------------------------------------------------------------ test.ellipticalParam = function() { # Arguments ? args(ellipticalParam) # Parameters: for (type in ellipticalList()) { cat("\n") print(unlist(ellipticalParam(type))) } # Return Value: return() } # ------------------------------------------------------------------------------ test.ellipticalCheck = function() { # Arguments ? args(ellipticalCheck) # ellipticalCheck(rho = 0.75, param = NULL, type = ellipticalList()) # Range: for (type in ellipticalList()) { cat("\n") param = ellipticalParam(type)$param rho = param[1] # Returns NULL if OK print(ellipticalCheck(rho, param[-1], type)) } # Return Value: return() } ################################################################################ test.gfunc = function() { # Arguments ? args(gfunc) # gfunc(x, param = NULL, type = ellipticalList()) # Call Generator Function - Missing x: gfunc(type = "norm") gfunc(type = "cauchy") gfunc(type = "t") gfunc(type = "t", param = 2) gfunc(type = "logistic") gfunc(type = "laplace") gfunc(type = "kotz") gfunc(type = "kotz", param = 2) gfunc(type = "epower") gfunc(type = "epower", param = c(2, 1)) # Call Generator Function - With specified x: gfunc(x = 0:10, type = "norm") gfunc(x = 0:10, type = "cauchy") gfunc(x = 0:10, type = "t") gfunc(x = 0:10, type = "logistic") gfunc(x = 0:10, type = "laplace") gfunc(x = 0:10, type = "kotz") gfunc(x = 0:10, type = "epower") # Return Value: return() } # ------------------------------------------------------------------------------ test.gfuncSlider = function() { # Try Slider: # gfuncSlider() NA # Return Value: return() } # ------------------------------------------------------------------------------ test.pelliptical = function() { # Probability: q = (-1000:1000)/2000 S = NULL s = Sys.time() fCopulae:::.pelliptical(q = q, param = NULL, type = "norm") S = c(S, as.integer(Sys.time() - s)) s = Sys.time() fCopulae:::.pelliptical(q = q, param = NULL, type = "cauchy") S = c(S, as.integer(Sys.time() - s)) s = Sys.time() fCopulae:::.pelliptical(q = q, param = 2, type = "t") S = c(S, as.integer(Sys.time() - s)) s = Sys.time() fCopulae:::.pelliptical(q = q, param = NULL, type = "logistic") S = c(S, as.integer(Sys.time() - s)) s = Sys.time() fCopulae:::.pelliptical(q = q, param = NULL, type = "laplace") S = c(S, as.integer(Sys.time() - s)) s = Sys.time() fCopulae:::.pelliptical(q = q, param = c(r = 1), type = "kotz") S = c(S, as.integer(Sys.time() - s)) s = Sys.time() fCopulae:::.pelliptical(q = q, param = c(r = 1, s = 1), type = "epower") S = c(S, as.integer(Sys.time() - s)) # Return Value: return() } # ------------------------------------------------------------------------------ test.delliptical = function() { # Probability: N = 100 x = (-1999:1999)/N d = fCopulae:::.delliptical(x = x, param = NULL, type = "norm") sum(d)/N d = fCopulae:::.delliptical(x = x, param = NULL, type = "cauchy") sum(d)/N d = fCopulae:::.delliptical(x = x, param = NULL, type = "t") sum(d)/N d = fCopulae:::.delliptical(x = x, param = NULL, type = "logistic") sum(d)/N d = fCopulae:::.delliptical(x = x, param = NULL, type = "laplace") sum(d)/N d = fCopulae:::.delliptical(x = x, param = NULL, type = "kotz") sum(d)/N d = fCopulae:::.delliptical(x = x, param = NULL, type = "epower") sum(d)/N # Non-default Parameters: d = fCopulae:::.delliptical(x = (-100:100)/10, param = 1, type = "kotz") sum(d)/N d = fCopulae:::.delliptical(x = (-100:100)/10, param = 1/2, type = "kotz") sum(d)/N # Return Value: return() } # ------------------------------------------------------------------------------ test.qelliptical = function() { # Probability: p = (0:10)/10 fCopulae:::.qelliptical(p = p, param = NULL, type = "norm") fCopulae:::.qelliptical(p = p, param = NULL, type = "cauchy") fCopulae:::.qelliptical(p = p, param = 2, type = "t") fCopulae:::.qelliptical(p = p, param = NULL, type = "logistic") fCopulae:::.qelliptical(p = p, param = NULL, type = "laplace") fCopulae:::.qelliptical(p = p, param = c(r = 1), type = "kotz") fCopulae:::.qelliptical(p = p, param = c(r = 1, s = 1), type = "epower") # Return Value: return() } ################################################################################ fCopulae/inst/unitTests/runit.ArchimedeanCopulae.R0000644000176200001440000001535514345452520022000 0ustar liggesusers # 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 # Copyrights (C) # for this R-port: # 1999 - 2007, Diethelm Wuertz, GPL # Diethelm Wuertz # info@rmetrics.org # www.rmetrics.org # for the code accessed (or partly included) from other R-ports: # see R's copyright and license files # for the code accessed (or partly included) from contributed R-ports # and other sources # see Rmetrics's copyright file ################################################################################ # FUNCTION: ARCHIMEDEAN COPULAE RANDOM VARIATES: # rarchmCopula Generates Archimedean copula random variates # rarchmSlider Displays interactively archimedean probability # FUNCTION: ARCHIMEDEAN COPULAE PROBABILITY: # parchmCopula Computes Archimedean copula probability # parchmSlider Displays interactively archimedean probability # FUNCTION: ARCHIMEDEAN COPULAE DENSITY: # darchmCopula Computes Archimedean copula density # darchmSlider Displays interactively archimedean density # FUNCTION: SPECIAL BIVARIATE COPULA: # rgumbelCopula Generates fast gumbel random variates # pgumbelCopula Computes bivariate Gumbel copula probability # dgumbelCopula Computes bivariate Gumbel copula density ################################################################################ test.rarchmCopula = function() { # Arguments: # rarchmCopula(n, alpha = NULL, type = archmList()) # Random Variates - Check all Types: for (type in archmList()) { R = rarchmCopula(n = 5, alpha = NULL, type = type) cat("\n") print(type) print(R) } # Return Value: return() } # ------------------------------------------------------------------------------ test.rarchmSlider = function() { # Arguments: # rarchmSlider(B = 10) # Try Slider: # rarchmSlider() NA # Return Value: return() } ################################################################################ test.parchmCopula = function() { # Arguments: # parchmCopula(u = 0.5, v = u, alpha = NULL, type = archmList(), # output = c("vector", "list"), alternative = FALSE) # u - single input value: parchmCopula() parchmCopula(0.5) parchmCopula(0.5, 0.25) # u - input vector: U = (0:10)/10 V = U parchmCopula(U) parchmCopula(u = U, v = V) parchmCopula(u = U, v = rev(V)) # u - input matrix: parchmCopula(cbind(U, V)) # u - input list: u = grid2d() u parchmCopula(u) # output = "vector" parchmCopula(u, output = "list") diff = parchmCopula(u) - parchmCopula(u, alternative = TRUE) mean(abs(diff)) # Check All Types: u = grid2d() for (type in paste(1:22)) { cop1 = parchmCopula(u, type = type, output = "list") cop2 = parchmCopula(u, type = type, output = "list", alternative = TRUE) cat("Type: ", type, "\t Difference: ", mean(abs(cop1$z-cop2$z)), "\n") persp(cop1, main = type, theta = -40, phi = 30, col = "steelblue") } # Return Value: return() } # ------------------------------------------------------------------------------ test.parchmSlider = function() { # Arguments: # parchmSlider(type = c("persp", "contour"), B = 10) # Try Perspective Slider: # parchmSlider() NA # Try Contour Slider: # parchmSlider("contour") NA # Return Value: return() } ################################################################################ test.darchmCopula = function() { # Arguments: # darchmCopula(u = 0.5, v = u, alpha = NULL, type = archmList(), # output = c("vector", "list"), alternative = FALSE) # u - single input value: darchmCopula() darchmCopula(0.5) darchmCopula(0.5, 0.25) # u - input vector: U = (0:10)/10 V = U darchmCopula(U) darchmCopula(u = U, v = V) darchmCopula(u = U, v = rev(V)) # u - input matrix: darchmCopula(cbind(U, V)) # u - input list: u = grid2d() u darchmCopula(u) # output = "vector" darchmCopula(u, output = "list") # Check All Types: u = grid2d(x = (0:25)/25) for (type in archmList()) { cop1 = darchmCopula(u, type = type, output = "list") cop2 = darchmCopula(u, type = type, output = "list", alternative = TRUE) diff = abs(cop1$z-cop2$z) diff = diff[!is.na(diff)] cat("Type: ", type, "\t Difference: ", mean(diff), "\n") persp(cop2, main = type, theta = -40, phi = 30, col = "steelblue") } # Return Value: return() } # ------------------------------------------------------------------------------ test.darchmSlider = function() { # Arguments: # darchmSlider(type = c("persp", "contour"), B = 10) # Try Perspective Slider: # darchmSlider() NA # Try Contour Slider: # darchmSlider("contour") NA # Return Value: return() } ################################################################################ test.rgumbelCopula = function() { # Generates fast gumbel random variates # Copula: rgumbelCopula() # Return Value: return() } # ------------------------------------------------------------------------------ test.pgumbelCopula = function() { # Computes bivariate Gumbel copula probability # Copula: pgumbelCopula() # Return Value: return() } # ------------------------------------------------------------------------------ test.dgumbelCopula = function() { # Computes bivariate Gumbel copula density # Copula: dgumbelCopula() # Return Value: return() } ################################################################################ fCopulae/inst/unitTests/runit.aaaCopulaClass.R0000644000176200001440000000740214265245633021143 0ustar liggesusers # 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 # Copyrights (C) # for this R-port: # 1999 - 2007, Diethelm Wuertz, GPL # Diethelm Wuertz # info@rmetrics.org # www.rmetrics.org # for the code accessed (or partly included) from other R-ports: # see R's copyright and license files # for the code accessed (or partly included) from contributed R-ports # and other sources # see Rmetrics's copyright file ################################################################################ # FUNCTION: SPECIFICATION: # fCOPULA S4 class representation # show S4 print method for copula specification # FUNCTION: FRECHET COPULAE: # pfrechetCopula Computes Frechet copula probability # FUNCTION: SPEARMAN'S RHO: # .copulaRho Spearman's rho by integration for "ANY" copula ################################################################################ test.pfrechetCopula = function() { # pfrechetCopula(u = 0.5, v = u, type = c("m", "pi", "w"), # output = c("vector", "list")) # Grid: grid2d() grid2d(x = (0:10)/10) # Vector - M Copula: copula.vector = pfrechetCopula(u = grid2d(), output = "vector", type = "m") copula.vector class(copula.vector) cbind(u = grid2d()$x, v = grid2d()$y, C = copula.vector) # List - M Copula: copula.list = pfrechetCopula(u = grid2d(), output = "list", type = "m") copula.list class(copula.list) persp(copula.list, theta = -40, phi = 30, col = "steelblue", ps = 9) # Vector - Pi Copula: copula.vector = pfrechetCopula(u = grid2d(), output = "vector", type = "pi") copula.vector class(copula.vector) cbind(u = grid2d()$x, v = grid2d()$y, C = copula.vector) # List - Pi Copula: copula.list = pfrechetCopula(u = grid2d(), output = "list", type = "pi") copula.list class(copula.list) persp(copula.list, theta = -40, phi = 30, col = "steelblue", ps = 9) # Vector - W Copula: copula.vector = pfrechetCopula(u = grid2d(), output = "vector", type = "w") copula.vector class(copula.vector) cbind(u = grid2d()$x, v = grid2d()$y, C = copula.vector) # List - W Copula: copula.list = pfrechetCopula(u = grid2d(), output = "list", type = "w") copula.list class(copula.list) persp(copula.list, theta = -40, phi = 30, col = "steelblue", ps = 9) # Return Value: return() } ################################################################################ test.copulaRho = function() { # .copulaRho(rho = NULL, alpha = NULL, param = NULL, # family = c("elliptical", "archm", "ev", "archmax"), # type = NULL, error = 1e-3, ...) # Elliptical: fCopulae:::.copulaRho(rho = 0.5, family = "elliptical", type = "norm") # Return Value: return() } ################################################################################ fCopulae/inst/unitTests/runit.EllipticalModelling.R0000644000176200001440000001021214265245633022175 0ustar liggesusers # 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 # Copyrights (C) # for this R-port: # 1999 - 2007, Diethelm Wuertz, GPL # Diethelm Wuertz # info@rmetrics.org # www.rmetrics.org # for the code accessed (or partly included) from other R-ports: # see R's copyright and license files # for the code accessed (or partly included) from contributed R-ports # and other sources # see Rmetrics's copyright file ################################################################################ # FUNCTION: ELLIPTICAL COPULAE PARAMETER FITTING: # ellipticalCopulaSim Simulates bivariate elliptical copula # ellipticalCopulaFit Fits the paramter of an elliptical copula ################################################################################ test.copulaSim = function() { # Arguments: # ellipticalCopulaSim(n, rho = 0.75, param = NULL, # type = c("norm", "cauchy", "t")) # Normal Copula: rho = 0.5 R = ellipticalCopulaSim(n = 1000, rho = rho) R[1:10, ] plot(R, pch = 19) # Cauchy Copula: rho = runif(1, -1, 1) R = ellipticalCopulaSim(n = 100, rho = rho, type = "cauchy") R[1:10, ] plot(R, pch = 19) # Student-t Copula: rho = runif(1, -1, 1) nu = runif(1, 3, 20) print(c(rho, nu)) R = ellipticalCopulaSim(n = 1000, rho = rho, param = nu, type = "t") R[1:10, ] plot(R, pch = 19) # The remaining Copulae are not yet implemented ... # Return Value: return() } # ------------------------------------------------------------------------------ test.copulaFit = function() { # Arguments: # ellipticalCopulaFit(u, v = NULL, type = c("norm", "cauchy", "t"), ...) # Fit Normal Copula: rho = 0.5 R = ellipticalCopulaSim(n = 1000, rho = rho) fit = ellipticalCopulaFit(u = R[,1], v = R[,2]) fit rho - fit$par plot(c(-1,1), c(-1,1), xlab = "rho", ylab = "estimate", main = "Normal") for ( i in 1:100) { rho = runif(1, -1, 1) R = ellipticalCopulaSim(n = 1000, rho = rho) fit = ellipticalCopulaFit(R) points(rho, fit$par) print(c(rho, fit$par)) } # Fit Cauchy Copula: rho = runif(1, -1, 1) R = ellipticalCopulaSim(n = 100, rho = rho, type = "cauchy") ellipticalCopulaFit(R, type = "cauchy") rho plot(c(-1,1), c(-1,1), main = "Cauchy") for ( i in 1:100) { rho = runif(1, -1, 1) R = ellipticalCopulaSim(n = 1000, rho = rho, type = "cauchy") fit = ellipticalCopulaFit(R, type = "cauchy") points(rho, fit$par) print(c(rho, fit$par)) } # Fit Student-t Copula: rho = runif(1, -1, 1) nu = runif(1, 3, 20) print(c(rho, nu)) R = ellipticalCopulaSim(n = 1000, rho = rho, param = nu, type = "t") ellipticalCopulaFit(R, type = "t") plot(c(-1,1), c(-1,1), main = "Student-t") for ( i in 1:100) { rho = runif(1, -1, 1) nu = runif(1, 3, 20) R = ellipticalCopulaSim(n = 1000, rho = rho, param = nu, type = "t") fit = ellipticalCopulaFit(R, type = "t") points(rho, fit$par[1]) print(c(rho, nu, fit$par)) } # The remaining Copulae are not yet implemented ... # Return Value: return() } ################################################################################ fCopulae/inst/unitTests/runit.ExtremeValueDependency.R0000644000176200001440000000617514265245633022702 0ustar liggesusers # 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 # Copyrights (C) # for this R-port: # 1999 - 2007, Diethelm Wuertz, GPL # Diethelm Wuertz # info@rmetrics.org # www.rmetrics.org # for the code accessed (or partly included) from other R-ports: # see R's copyright and license files # for the code accessed (or partly included) from contributed R-ports # and other sources # see Rmetrics's copyright file ################################################################################ # FUNCTION KENDALL'S TAU AND SPEARMAN'S RHO: # evTau Returns Kendall's tau for extreme value copulae # evRho Returns Spearman's rho for extreme value copulae # FUNCTION: EXTREME VALUE COPULAE TAIL DEPENDENCE: # evTailCoeff Computes tail dependence for extreme value copulae # evTailCoeffSlider Plots extreme value tail dependence function ################################################################################# test.evTau = function() { # Arguments: # evTau(param = NULL, type = evList(), alternative = FALSE) # Tau: for (type in evList()) { ans = evTau(type = type) cat("\n") print(ans) } # Return Value: return() } # ------------------------------------------------------------------------------ test.evRho = function() { # Arguments: # evRho(param = NULL, type = evList(), alternative = FALSE) # Rho: for (type in evList()) { ans = evRho(type = type) cat("\n") print(type) print(ans) } # Return Value: return() } ################################################################################ test.evTailCoeff = function() { # Arguments: # evTailCoeff(param = NULL, type = evList()) # Tail Coefficient: for (type in evList()) { ans = evTailCoeff(type = type) cat("\n") print(type) print(ans) } # Return Value: return() } # ------------------------------------------------------------------------------ test.evTailCoeffSlider = function() { # Arguments: # evTailCoeffSlider(B = 10) # Try Slider: # evTailCoeffSlider() NA # Return Value: return() } ################################################################################ fCopulae/inst/unitTests/runit.EllipticalDependency.R0000644000176200001440000000637414265245633022357 0ustar liggesusers # 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 # Copyrights (C) # for this R-port: # 1999 - 2007, Diethelm Wuertz, GPL # Diethelm Wuertz # info@rmetrics.org # www.rmetrics.org # for the code accessed (or partly included) from other R-ports: # see R's copyright and license files # for the code accessed (or partly included) from contributed R-ports # and other sources # see Rmetrics's copyright file ################################################################################ # FUNCTION: ELLIPTICAL COPULAE DEPENDENCE MASURES: # ellipticalTau Computes Kendall's tau for elliptical copulae # ellipticalRho Computes Spearman's rho for elliptical copulae # FUNCTION: ELLIPTICAL COPULAE TAIL COEFFICIENT: # ellipticalTailCoeff Computes tail dependence for elliptical copulae # ellipticalTailPlot Plots tail dependence function ################################################################################ test.ellipticalTau = function() { # Computes Kendall's tau for elliptical copulae args(ellipticalTau) ellipticalTau(rho = 0.5) ellipticalTau(rho = c(-0.5, 0, 0.5)) # Return Value: return() } # ------------------------------------------------------------------------------ test.ellipticalRho = function() { # Computes Spearman's rho for elliptical copulae args(ellipticalRho) ellipticalRho(0.5) ellipticalRho(rho = c(-0.5, 0, 0.5)) # Return Value: return() } ################################################################################ test.ellipticalTailCoeff = function() { # Lower - Upper ---- # Tail Coefficient - Using Default Parameters: Type = c("norm", "cauchy", "t") for (type in Type) { ans = ellipticalTailCoeff(rho = 0.5, type = type) print(ans) cat("\n") } # Return Value: return() } # ------------------------------------------------------------------------------ test.ellipticalTailPlot = function() { # Arguments: # ellipticalTailPlot(param = NULL, type = c("norm", "cauchy", "t"), # tail = c("Lower", "Upper")) # Plot - Be patient, plotting takes some time ... Type = c("norm", "cauchy", "t") for (type in Type) { par(mfrow = c(2, 2), cex = 0.7) ellipticalTailPlot(type = type) ellipticalTailPlot(type = type, tail = "Lower") } # Return Value: return() } ################################################################################ fCopulae/inst/unitTests/runit.ArchimedeanGenerator.R0000644000176200001440000001230214265245633022331 0ustar liggesusers # 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 # Copyrights (C) # for this R-port: # 1999 - 2007, Diethelm Wuertz, GPL # Diethelm Wuertz # info@rmetrics.org # www.rmetrics.org # for the code accessed (or partly included) from other R-ports: # see R's copyright and license files # for the code accessed (or partly included) from contributed R-ports # and other sources # see Rmetrics's copyright file ################################################################################ # FUNCTION: ARCHIMEDEAN COPULAE PARAMETER: # evList Returns list of implemented extreme value copulae # archmParam Sets Default parameters for an extreme value copula # archmRange Returns the range of valid alpha values # archmCheck Checks if alpha is in the valid range # FUNCTION: ARCHIMEDEAN COPULAE PHI GENERATOR: # Phi Computes Archimedean Phi, inverse and derivatives # PhiSlider Displays interactively generator function # FUNCTION: ARCHIMEDEAN DENSITY K GENERATOR: # Kfunc Computes Archimedean Density Kc and its Inverse # KfuncSlider Displays interactively the density and concordance ################################################################################ test.archmList = function() { # Arguments: # archmList() # List: archmList() # Return Value: return() } # ------------------------------------------------------------------------------ test.archmParam = function() { # Arguments: # archmParam(type = archmList()) # Parameters: for (type in archmList()) { cat("\n") print(unlist(archmParam(type))) } # Return Value: return() } # ------------------------------------------------------------------------------ test.archmRange = function() { # Arguments: # archmRange(type = archmList(), B = Inf) # Range: for (type in archmList()) { cat("\n") print(archmRange(type)) } # Return Value: return() } # ------------------------------------------------------------------------------ test.archmCheck = function() { # Arguments ? # archmCheck(alpha, type = archmList()) # Check: for (type in archmList()) { cat("\n") print(archmCheck(archmParam(type)$param)) } # Return Value: return() } ################################################################################ test.Phi = function() { # Arguments: # Phi(x, alpha = NULL, type = archmList(), inv = FALSE, deriv = paste(0:2)) # Call Generator Function Phi: for (type in paste(1:22)) { print(Phi(x = 0.5, type = type, inv = TRUE, deriv = "0")) cat("\n") } for (type in paste(1:22)) { print(Phi(x = 0.5, type = type, inv = TRUE, deriv = "1")) cat("\n") } for (type in paste(1:22)) { print(Phi(x = 0.5, type = type, inv = TRUE, deriv = "2")) cat("\n") } for (type in paste(1:22)) { print(Phi(x = 0.5, type = type, inv = FALSE, deriv = "0")) cat("\n") } for (type in paste(1:22)) { print(Phi(x = 0.5, type = type, inv = FALSE, deriv = "1")) cat("\n") } for (type in paste(1:22)) { print(Phi(x = 0.5, type = type, inv = FALSE, deriv = "2")) cat("\n") } # Return Value: return() } # ------------------------------------------------------------------------------ test.PhiSlider = function() { # Arguments: # PhiSlider() # Try Slider: # PhiSlider() NA # Return Value: return() } ################################################################################ test.Kfunc = function() { # Arguments: # Kfunc(x, alpha = NULL, type = archmList(), inv = FALSE, lower = 1e-08) # Call Generator Function Phi: for (type in paste(1:22)) { print(Kfunc(x = 0.5, inv = FALSE)) cat("\n") } for (type in paste(1:22)) { print(Kfunc(x = 0.5, inv = TRUE)) cat("\n") } # Return Value: return() } # ------------------------------------------------------------------------------ test.KfuncSlider = function() { # Arguments: # KfuncSlider() # Try Slider: # KfuncSlider() NA # Return Value: return() } ################################################################################ fCopulae/inst/unitTests/runit.ExtremeValueCopulae.R0000644000176200001440000001105114265245633022201 0ustar liggesusers # 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 # Copyrights (C) # for this R-port: # 1999 - 2007, Diethelm Wuertz, GPL # Diethelm Wuertz # info@rmetrics.org # www.rmetrics.org # for the code accessed (or partly included) from other R-ports: # see R's copyright and license files # for the code accessed (or partly included) from contributed R-ports # and other sources # see Rmetrics's copyright file ################################################################################ # FUNCTION: EXTREME VALUE COPULAE RANDOM VARIATES: # revCopula Generates extreme value copula random variates # revSlider isplays interactively plots of random variates # FUNCTION: EXTREME VALUE COPULAE PROBABILIY: # pevCopula Computes extreme value copula probability # pevSlider Displays interactively plots of probability # FUNCTION: EXTREME VALUE COPULAE DENSITY: # devCopula Computes extreme value copula density # devSlider Displays interactively plots of density ################################################################################ test.revCopula = function() { # Arguments: # revCopula(n, param = NULL, type = evList()) # Random Variates - Check all Types: for (type in evList()) { R = revCopula(n = 5, param = NULL, type = type) cat("\n") print(type) print(R) } # Tawn Copula: revCopula(n = 5, param = NULL, type = "tawn") # Return Value: return() } # ------------------------------------------------------------------------------ test.revSlider = function() { # Arguments: # revSlider(B = 10) # Try Slider() # revSlider() # CHECK !!! NA # Return Value: return() } ################################################################################ test.pevCopula = function() { # Arguments: # pevCopula(u = 0.5, v = u, param = NULL, type = evList(), # output = c("vector", "list"), alternative = FALSE) # Random Variates - Check all Types: for (type in evList()) { R = pevCopula(u = grid2d(), param = NULL, type = type, output = "list") cat("\n") print(type) print(R) } # Tawn Copula: revCopula(n = 5, param = NULL, type = "tawn") # Return Value: return() } # ------------------------------------------------------------------------------ test.pevSlider = function() { # Arguments: # pevSlider(type = c("persp", "contour"), B = 10) # Try Perspective Slider: # pevSlider("persp") NA # Try Contour Slider: # pevSlider("contour") NA # Return Value: return() } ################################################################################ test.devCopula = function() { # Arguments: # devCopula(u = 0.5, v = u, param = NULL, type = evList(), # output = c("vector", "list"), alternative = FALSE) # Random Variates - Check all Types: for (type in evList()) { R = devCopula(u = grid2d(), param = NULL, type = type, output = "list") cat("\n") print(type) print(R) } # CHECK Border !!!! # Tawn Copula: revCopula(n = 5, param = NULL, type = "tawn") # Return Value: return() } # ------------------------------------------------------------------------------ test.devSlider = function() { # Arguments: # devSlider(type = c("persp", "contour"), B = 10) # Try Perspective Slider: # devSlider("persp") NA # Try Contour Slider: # devSlider("contour") NA # Return Value: return() } ################################################################################ fCopulae/inst/unitTests/runit.ArchimedeanModelling.R0000644000176200001440000000453514350706244022321 0ustar liggesusers # 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 # Copyrights (C) # for this R-port: # 1999 - 2007, Diethelm Wuertz, GPL # Diethelm Wuertz # info@rmetrics.org # www.rmetrics.org # for the code accessed (or partly included) from other R-ports: # see R's copyright and license files # for the code accessed (or partly included) from contributed R-ports # and other sources # see Rmetrics's copyright file ################################################################################ # FUNCTION: ARCHIMEDEAN COPULAE PARAMETER FITTING: # archmCopulaSim Simulates bivariate elliptical copula # archmCopulaFit Fits the paramter of an elliptical copula ################################################################################ test.archmCopulaSim = function() { # Arguments: # archmCopulaSim(n, alpha = NULL, type = archmList()) # Simulate Random Variates: for (type in archmList()) { ans = archmCopulaSim(5, type = type) cat("\n") print(type) print(ans) } # Return Value: return() } # ------------------------------------------------------------------------------ test.archmCopulaFit = function() { # Arguments: # archmCopulaFit(u, v = NULL, type = archmList(), ...) # Random Variates: R = archmCopulaSim(n = 100, alpha = 2, type = "4") # Fit: fit = archmCopulaFit(u = R, type = "4") fit # Fit: fit = archmCopulaFit(u = R[, 1], v = R[, 2], type = "4") fit # Return Value: return() } ################################################################################ fCopulae/inst/unitTests/runTests.R0000644000176200001440000000501414345456617016760 0ustar liggesuserspkg <- "fCopulae" initial_opt <- options(warn = 1) on.exit(initial_opt) if(require("RUnit", quietly = TRUE)) { library(package=pkg, character.only = TRUE) if(!(exists("path") && file.exists(path))) path <- system.file("unitTests", package = pkg) ## --- Testing --- ## Define tests testSuite <- defineTestSuite(name = paste(pkg, "unit testing"), dirs = path, rngKind = "Mersenne-Twister", rngNormalKind = "Inversion") if(interactive()) { cat("Now have RUnit Test Suite 'testSuite' for package '", pkg, "' :\n", sep='') str(testSuite) cat('', "Consider doing", "\t tests <- runTestSuite(testSuite)", "\nand later", "\t printTextProtocol(tests)", '', sep = "\n") } else { ## run from shell / Rscript / R CMD Batch / ... ## Run tests <- runTestSuite(testSuite) if(file.access(path, 02) != 0) { ## cannot write to path -> use writable one tdir <- tempfile(paste(pkg, "unitTests", sep="_")) dir.create(tdir) pathReport <- file.path(tdir, "report") cat("RUnit reports are written into ", tdir, "/report.(txt|html)", sep = "") } else { pathReport <- file.path(path, "report") } ## Print Results: printTextProtocol(tests, showDetails = FALSE) printTextProtocol(tests, showDetails = FALSE, fileName = paste(pathReport, "Summary.txt", sep = "")) printTextProtocol(tests, showDetails = TRUE, fileName = paste(pathReport, ".txt", sep = "")) ## Print HTML Version to a File: ## printHTMLProtocol has problems on Mac OS X if (Sys.info()["sysname"] != "Darwin") printHTMLProtocol(tests, fileName = paste(pathReport, ".html", sep = "")) ## stop() if there are any failures i.e. FALSE to unit test. ## This will cause R CMD check to return error and stop tmp <- getErrors(tests) if(tmp$nFail > 0 | tmp$nErr > 0) { stop(paste("\n\nunit testing failed (#test failures: ", tmp$nFail, ", R errors: ", tmp$nErr, ")\n\n", sep="")) } } } else { cat("R package 'RUnit' cannot be loaded -- no unit tests run\n", "for package", pkg,"\n") } ################################################################################ fCopulae/inst/unitTests/runit.EllipticalCopulae.R0000644000176200001440000001120714265245633021660 0ustar liggesusers # 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: ELLIPTICAL COPULAE RANDOM DEVIATES: # rellipticalCopula Generates elliptical copula variates # rellipticalSlider Interactive plots of random variates # FUNCTION: ELLIPTICAL COPULAE PROBABILITY: # pellipticalCopula Computes elliptical copula probability # pellipticalSlider Interactive plots of probability # FUNCTION: ELLIPTICAL COPULAE DENSITY: # dellipticalCopula Computes elliptical copula density # dellipticalSlider Interactive plots of density ################################################################################ test.rellipticalCopula = function() { # Random Number Generator: R <- rellipticalCopula(1000, type = "norm") plot(R, pch = 19, col = "steelblue", main = "norm") grid() R <- rellipticalCopula(1000, type = "cauchy") plot(R, pch = 19, col = "steelblue", main = "cauchy") grid() R <- rellipticalCopula(1000, type = "t") plot(R, pch = 19, col = "steelblue", main = "t-default") grid() R <- rellipticalCopula(1000, param = c(nu = 3), type = "t") plot(R, pch = 19, col = "steelblue", main = "t3") grid() R <- rellipticalCopula(1000, param = 3, type = "t") plot(R, pch = 19, col = "steelblue", main = "t3") grid() # The remaining copulae are not yet implemented ... # Return Value: return() } # ------------------------------------------------------------------------------ test.rellipticalSlider <- function() { # Try Slider: # rellipticalSlider() NA # Return Value: return() } ################################################################################ test.pellipticalCopula <- function() { # Arguments ? # pellipticalCopula(u = 0.5, v = u, rho = 0.75, param = NULL, # type = ellipticalList(), output = c("vector", "list"), border = TRUE) # Use Default Settings: par (mfrow = c(1, 1)) for (type in ellipticalList()) { UV <- grid2d() p <- pellipticalCopula(u = UV, rho = 0.75, type = type, output = "list") print(type) persp(p, main = type, theta = -40, phi = 30, col = "steelblue", ps = 9, xlab = "u", ylab = "v", zlab = "C") } # Return Value: return() } # ------------------------------------------------------------------------------ test.pellipticalSlider = function() { # Arguments: # pellipticalSlider(type = c("persp", "contour"), B = 20) # Try Perspective Slider: # pellipticalSlider() NA # Try Contour Slider: # pellipticalSlider("contour") NA # Return Value: return() } ################################################################################ test.dellipticalCopula = function() { # Arguments ? # dellipticalCopula(u = 0.5, v = u, rho = 0.75, param = NULL, # type = ellipticalList(), output = c("vector", "list"), border = TRUE) # Use Default Settings: par (mfrow = c(1, 1)) for (type in ellipticalList()) { UV = grid2d() d = dellipticalCopula(u = UV, rho = 0.75, type = type, output = "list") print(type) persp(d, main = type, theta = -40, phi = 30, col = "steelblue", ps = 9, xlab = "u", ylab = "v", zlab = "c") } # Return Value: return() } # ------------------------------------------------------------------------------ test.dellipticalSlider = function() { # Arguments: # dellipticalSlider(type = c("persp", "contour"), B = 20) # Try Perspective Slider: # dellipticalSlider() NA # Try Contour Slider: # dellipticalSlider("contour") NA # Return Value: return() } ################################################################################ fCopulae/inst/unitTests/runit.EmpiricalCopulae.R0000644000176200001440000000360614265245633021507 0ustar liggesusers # 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 # Copyrights (C) # for this R-port: # 1999 - 2007, Diethelm Wuertz, GPL # Diethelm Wuertz # info@rmetrics.org # www.rmetrics.org # for the code accessed (or partly included) from other R-ports: # see R's copyright and license files # for the code accessed (or partly included) from contributed R-ports # and other sources # see Rmetrics's copyright file ################################################################################ # FUNCTION: EMPIRICAL COPULAE: # pempiricalCopula Computes empirical copula probability # dempiricalCopula Computes empirical copula density ################################################################################ test.pempiricalCopula = function() { # Arguments: # pempiricalCopula(u, v, N = 10) NA # Return Value: return() } # ------------------------------------------------------------------------------ test.dempiricalCopula = function() { # Arguments: # dempiricalCopula(u, v, N = 10) NA # Return Value: return() } ################################################################################ fCopulae/inst/unitTests/runit.ExtrmeValueGenerator.R0000644000176200001440000000721414265245633022400 0ustar liggesusers # 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 # Copyrights (C) # for this R-port: # 1999 - 2007, Diethelm Wuertz, GPL # Diethelm Wuertz # info@rmetrics.org # www.rmetrics.org # for the code accessed (or partly included) from other R-ports: # see R's copyright and license files # for the code accessed (or partly included) from contributed R-ports # and other sources # see Rmetrics's copyright file ################################################################################ # FUNCTION: EXTREME VALUE COPULAE PARAMETER: # evList Returns list of implemented extreme value copulae # evParam Sets Default parameters for an extreme value copula # evRange Returns the range of valid parameter values # evCheck Checks if parameters are in the valid range # FUNCTION: EXTREME VALUE COPULAE GENERATOR FUNCTION: # Afunc Computes Dependence function # AfuncSlider Displays interactively dependence function ################################################################################# test.evList = function() { # Arguments: # evList() # List: evList() # c("gumbel", "galambos", "husler.reiss", "tawn", "bb5") # Return Value: return() } # ------------------------------------------------------------------------------ test.evParam = function() { # Arguments: # evParam(type = evList()) # Parameters: for (type in evList()) { cat("\n") print(unlist(evParam(type))) } # Return Value: return() } # ------------------------------------------------------------------------------ test.evRange = function() { # Arguments: # evRange(type = evList()) # Range: for (type in evList()) { cat("\n") print(evRange(type)) } # Return Value: return() } # ------------------------------------------------------------------------------ test.evCheck = function() { # Arguments: # evCheck(type = evList()) # Check: for (type in evList()) { cat("\n") param = evParam(type)$param print(evCheck(param)) } # Return Value: return() } ################################################################################ test.Afunc = function() { # Arguments: # Afunc(x, param = NULL, type = evList() # Afunc: x = (0:10)/10 for (type in evList()) { cat("\n") print(type) print(Afunc(x, type = type)) } # Return Value: return() } # ------------------------------------------------------------------------------ test.AfuncSlider = function() { # Arguments: # AfuncSlider() # Try Slider: # AfuncSlider() NA # Return Value: return() } ################################################################################ fCopulae/inst/unitTests/runit.ExtremeValueModelling.R0000644000176200001440000000470414265245633022532 0ustar liggesusers # 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 # Copyrights (C) # for this R-port: # 1999 - 2007, Diethelm Wuertz, GPL # Diethelm Wuertz # info@rmetrics.org # www.rmetrics.org # for the code accessed (or partly included) from other R-ports: # see R's copyright and license files # for the code accessed (or partly included) from contributed R-ports # and other sources # see Rmetrics's copyright file ################################################################################ # FUNCTION: EXTREME VALUE COPULA PARAMETER FITTING: # evCopulaSim Simulates bivariate extreme value copula # evCopulaFit Fits the paramter of an extreme value copula ################################################################################# test.evCopulaSim = function() { # Arguments: # evCopulaSim(n, param = NULL, type = evList()) # Simulate Random Variates: for (type in evList()) { ans = evCopulaSim(5, type = type) cat("\n") print(type) print(ans) } # Return Value: return() } # ------------------------------------------------------------------------------ test.evCopulaFit = function() { # Arguments: # evCopulaFit(u, v = NULL, type = evList(), ...) # Random Variates: set.seed(4711) type = "gumbel" R = evCopulaSim(500, param = NULL, type = type) Index = which(is.na(R[,2])) R = R[-Index, ] # Fit: ### evCopulaFit(u = R, type = type) # Check # Fit: ### evCopulaFit(u = R[, 1], v = R[, 2], type = type) # Check # Return Value: return() } ################################################################################ fCopulae/inst/unitTests/Makefile0000644000176200001440000000042114356351340016430 0ustar liggesusersPKG=fCopulae TOP=../.. SUITE=doRUnit.R R=R all: inst test inst: # Install package -- but where ?? -- will that be in R_LIBS ? cd ${TOP}/..;\ ${R} CMD INSTALL ${PKG} test: # Run unit tests export RCMDCHECK=FALSE;\ cd ${TOP}/tests;\ ${R} --vanilla --slave < ${SUITE} fCopulae/inst/unitTests/runit.ArchimedeanDependency.R0000644000176200001440000000711314265245633022465 0ustar liggesusers # 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 # Copyrights (C) # for this R-port: # 1999 - 2007, Diethelm Wuertz, GPL # Diethelm Wuertz # info@rmetrics.org # www.rmetrics.org # for the code accessed (or partly included) from other R-ports: # see R's copyright and license files # for the code accessed (or partly included) from contributed R-ports # and other sources # see Rmetrics's copyright file ################################################################################ # FUNCTION KENDALL'S TAU AND SPEARMAN'S RHO: # archmTau Returns Kendall's tau for Archemedean copulae # archmRho Returns Spearman's rho for Archemedean copulae # FUNCTION: ARCHIMEDEAN COPULAE TAIL COEFFICIENT: # archmTailCoeff Computes tail dependence for Archimedean copulae # archmTailPlot Plots Archimedean tail dependence function ################################################################################ test.archmTau = function() { # Arguments: # archmTau(alpha = NULL, type = archmList(), lower = 1e-10) # Tau: for (type in archmList()) { ans = archmTau(type = type) cat("\n") print(type) print(ans) } # Return Value: return() } # ------------------------------------------------------------------------------ test.archmRho = function() { # Arguments: # archmRho(alpha = NULL, type = archmList(), # method = c("integrate2d", "adapt"), error = 1e-05) # Rho: for (type in archmList()) { ans = archmRho(alpha = NULL, type = type, method = "integrate2d", error = 1e-5) cat("\n") print(type) print(ans) } # Return Value: return() } ################################################################################ test.archmTailCoeff = function() { # Arguments: # archmTailCoeff(alpha = NULL, type = archmList()) # Tail Coefficient: for (type in archmList()) { ans = archmTailCoeff(alpha = NULL, type = type) cat("\n") print(type) print(ans) } # Return Value: return() } # ------------------------------------------------------------------------------ test.archmTailPlot = function() { # Arguments: # archmTailPlot(alpha = NULL, type = archmList(), # tail = c("Upper", "Lower")) # Lower Tail Coefficient Plot: par(mfrow = c(2, 2), cex = 0.7) for (type in archmList()) { print(type) archmTailPlot(alpha = NULL, type = type, tail = "Upper") } # Upper Tail Coefficient Plot: for (type in archmList()) { print(type) archmTailPlot(alpha = NULL, type = type, tail = "Lower") } # Return Value: return() } ################################################################################