Title:	General Bivariate Copula Theory and Many Utility Functions
Version:	2.2.8
Date:	2025-06-27
Description:	Extensive functions for bivariate copula (bicopula) computations and related operations for bicopula theory. The lower, upper, product, and select other bicopula are implemented along with operations including the diagonal, survival copula, dual of a copula, co-copula, and numerical bicopula density. Level sets, horizontal and vertical sections are supported. Numerical derivatives and inverses of a bicopula are provided through which simulation is implemented. Bicopula composition, convex combination, asymmetry extension, and products also are provided. Support extends to the Kendall Function as well as the Lmoments thereof. Kendall Tau, Spearman Rho and Footrule, Gini Gamma, Blomqvist Beta, Hoeffding Phi, Schweizer- Wolff Sigma, tail dependency, tail order, skewness, and bivariate Lmoments are implemented, and positive/negative quadrant dependency, left (right) increasing (decreasing) are available. Other features include Kullback-Leibler Divergence, Vuong Procedure, spectral measure, and Lcomoments for inference, maximum likelihood, and AIC, BIC, and RMSE for goodness-of-fit.
Maintainer:	William Asquith <william.asquith@ttu.edu>
Repository:	CRAN
Depends:	R (≥ 4.0.0)
Imports:	lmomco, randtoolbox
Suggests:	copula
License:	GPL-2
NeedsCompilation:	no
Packaged:	2025-06-27 21:31:14 UTC; wasquith
Author:	William Asquith [aut, cre]
Date/Publication:	2025-06-27 22:00:02 UTC

Basic Theoretical Copula, Empirical Copula, and Various Utility Functions

Description

The copBasic package is oriented around bivariate copula theory and mathematical operations closely follow the recommended texts of Nelsen (2006) and Joe (2014) as well as select other references. Another recommended text is Salvadori et al. (2007) and Hofert et al. (2018) and are cited herein, but about half of that excellent book concerns univariate applications. The primal objective of copBasic is to provide a study of numerous results shown by authoritative texts on copulas. It is intended that the package will help other copula students in self study, potential course work, and applied circumstances.

Notes on copulas that are supported. The author has focused on pedagogical aspects of copulas, and this package is a diary of sorts beginning in fall 2008. Originally, the author did not implement many copulas in the copBasic in order to deliberately avoid redundancy to that support such as it exists on the R CRAN. Though as time has progressed, other copulas have been added occasionally based on needs of the user community, need to show some specific concept in the general theory, or test algorithms. For example, the Clayton copula (CLcop) was a late arriving addition the package (c.2017), which was added to assist a specific user; the Frank copula (FRcop was added in December 2024 because of an inquiry on using copBasic for vine copula (see vine example under FRcop).

The language and vocabulary of copulas are formidable even within the realm of bivariate or bicopula as design basis for the package. Often “vocabulary” words are often emphasized in italics, which is used extensively and usually near the opening of function-by-function documentation to identify vocabulary words, such as survival copula (see surCOP). This syntax tries to mimic and accentuate the terminology in Nelsen (2006), Joe (2014), and generally most other texts. Italics are used to draw connections between concepts.

In conjunction with the summary of functions in copBasic-package, the extensive cross referencing to functions and expansive keyword indexing should be beneficial. The author had no experience with copulas prior to a chance happening upon Nelsen (2006) in c.2008. The copBasic package is a personal tour de force in self-guided learning. Over time, this package and user's manual have been helpful to others.

Helpful Navigation of Copulas Implemented in the copBasic Package

Some entry points to the copulas implemented are listed in the Table of Copulas:

A few comments on notation herein are needed. A bold math typeface is used to represent a copula function or family such as \mathbf{\Pi} (see P) for the independence copula. The syntax \mathcal{R}\times\mathcal{R} \equiv \mathcal{R}^2 denotes the orthogonal domain of two real numbers, and [0,1]\times [0,1] \equiv \mathcal{I}\times\mathcal{I} \equiv \mathcal{I}^2 denotes the orthogonal domain on the unit square of probabilities. Limits of integration [0,1] or [0,1]^2 involving copulas are thus shown as \mathcal{I} and \mathcal{I}^2, respectively.

Random variables X and Y respectively denote the horizontal and vertical directions in \mathcal{R}^2. Their probabilistic counterparts are uniformly distributed random variables on [0,1], are respectively denoted as U and V, and necessarily also are the respective directions in \mathcal{I}^2 (U denotes the horizontal, V denotes the vertical). Often realizations of these random variables are respectively x and y for X and Y and u and v for U and V.

There is an obvious difference between nonexceedance probability F and its complement, which is exceedance probability defined as 1-F. Both u and v herein are in nonexceedance probability. Arguments to many functions herein are u = u and v = v and are almost exclusively nonexceedance but there are instances for which the probability arguments are u = 1 - u = u' and v = 1 - v = v'.

Several of the functions listed above are measures of “bivariate association.” Two of the measures (Kendall Tau, tauCOP; Spearman Rho, rhoCOP) are widely known. R provides native support for their sample estimation of course, but each function can be used to call the cor() function in R for parallelism to the other measures of this package. The other measures (Blomqvist Beta, Gini Gamma, Hoeffding Phi, Schweizer–Wolff Sigma, Spearman Footrule) support sample estimation by specially formed calls to their respective functions: blomCOP, giniCOP, hoefCOP, wolfCOP, and footCOP. Gini Gamma (giniCOP) documentation (also joeskewCOP) shows extensive use of theoretical and sample computations for these and other functions.

Helpful Navigation of the copBasic Package

Some other entry points into the package are listed in the following table:

Concerning goodness-of-fit and although not quite the same as copula properties (such as “correlation”) per se as the coefficients aforementioned in the prior paragraph, three goodness-of-fit metrics of a copula compared to the empirical copula, which are all based the mean square error (MSE), are aicCOP, bicCOP, and rmseCOP. This triad of functions is useful for making decisions on whether a copula is more favorable than another to a given dataset. However, because they are genetically related by using MSE and if these are used for copula fitting by minimization, the fits will be identical. A statement of “not quite the same” is made because the previously described copula properties are generally defined as types of deviations from other copulas (such as P). Another goodness-of-fit statistic is statTn, which is based on magnitude summation of fitted copula difference from the empirical copula. These four (aicCOP, bicCOP, rmseCOP, and statTn) collectively are relative simple and readily understood measures. These bulk sample statistics are useful, but generally thought to not capture the nuances of tail behavior (semicorCOP and taildepCOP might be useful).

Bivariate skewness measures are supported in the functions joeskewCOP (nuskewCOP and nustarCOP) and uvlmoms (uvskew). Extensive discussion and example computations of bivariate skewness are provided in the joeskewCOP documentation. Lastly, so-called bivariate L-moments and bivariate L-comoments of a copula are directly computable in bilmoms (though that function using Monte Carlo integration is deprecated) and lcomCOP (direct numerical integration). The lcomCOP function is the theoretical counterpart to the sample L-comoments provided in the lmomco package.

Bivariate random simulation methods by several functions are identified in the previous table. The copBasic package explicitly uses only conditional simulation also known as the conditional distribution method for random variate generation following Nelsen (2006, pp. 40–41) (see also simCOPmicro, simCOP). The numerical derivatives (derCOP and derCOP2) and their inversions (derCOPinv and derCOPinv2) represent the foundation of the conditional simulation. There are other methods in the literature and available in other R packages, and a comparison of some methods is made in the Examples section of the Gumbel–Hougaard copula (GHcop).

Several functions in copBasic make the distinction between V with respect to (wrt) U and U wrt V, and a guide for the nomenclature involving wrt distinctions is listed in the following table:

The previous two tables do not include all of the myriad of special functions to support similar operations on empirical copulas. All empirical copula operators and utilities are prepended with EMPIR in the function name. An additional note concerning package nomenclature is that an appended “2” to a function name indicates U wrt V (e.g. EMPIRgridderinv2 for an inversion of the partial derivatives \delta \mathbf{C}/\delta v across the grid of the empirical copula).

Some additional functions to compute often salient features or characteristics of copulas or bivariate data, including functions for bivariate inference or goodness-of-fit, are listed in the following table:

The Table of Probabilities that follows lists important relations between various joint probability concepts, the copula, nonexceedance probabilities u and v, and exceedance probabilities u' and v'. A compact summary of these probability relations has obvious usefulness. The notation [\ldots, \ldots] is to read as [\ldots \mathrm{\ and\ } \ldots], and the [\ldots \mid \ldots] is to be read as [\ldots \mathrm{\ given\ } \ldots].

The function jointCOP has considerable demonstration in its Note section of the joint and and joint or relations shown through simulation and counting scenarios. Also there is a demonstration in the Note section of function duCOP on application of the concepts of joint and conditions, joint or conditions, and importantly joint mutually exclusive or conditions.

Copula Construction Methods

Permutation asymmetry can be added to a copula by breveCOP. One, two, or more copulas can be “composited,” “combined,” or “multiplied” in interesting ways to create highly unique bivariate relations and as a result, complex dependence structures can be formed. The package provides three main functions for copula composition: composite1COP composites a single copula with two compositing parameters (Khoudraji device with independence), composite2COP (Khoudraji device) composites two copulas with two compositing parameters, and composite3COP composites two copulas with four compositing parameters. Also two copulas can be combined through a weighted convex combination using convex2COP with a single weighting parameter, and even N number of copulas can be combined by weights using convexCOP. So-called “gluing” two copula by a parameter is provided by glueCOP. Multiplication of two copulas to form a third is supported by prod2COP. All eight functions for compositing, combining, or multipling copulas are compatible with joint probability simulation (simCOP), measures of association (e.g. \rho_\mathbf{C}), and presumably all other copula operations using copBasic features. Finally, ordinal sums of copula are provided by ORDSUMcop and ORDSUWcop as particularly interesting methods of combining copulas.

Useful Copula Relations by Visualization

There are a myriad of relations amongst variables computable through copulas, and these were listed in the Table of Probabilities earlier in this documentation. There is a script located in the inst/doc directory of the copBasic sources titled CopulaRelations_BaseFigure_inR.txt. This script demonstrates, using the PSP copula, relations between the copula (COP), survival copula (surCOP), joint survival function of a copula (surfuncCOP), co-copula (coCOP), and dual of a copula function (duCOP). The script performs simulation and manual counts observations meeting various criteria in order to compute their empirical probabilities. The script produces a base figure, which after extending in editing software, is suitable for educational description and is provided at the end of this documentation.

A Review of “Return Periods” using Copulas

Risk analyses of natural hazards are commonly expressed as annual return periods T in years, which are defined for a nonexceedance probability q as T = 1/(1-q). In bivariate analysis, there immediately emerge two types of return periods representing T_{q;\,\mathrm{coop}} and T_{q;\,\mathrm{dual}} conditions between nonexceedances of the two hazard sources (random variables) U and V. It is usual in many applications for T to be expressed equivalently as a probability q in common for both variables.

Incidentally, the \mathrm{Pr}[\,U > u \mid V > v\,] and \mathrm{Pr}[\,V > v \mid U > u\,] probabilities also are useful for conditional return period computations following Salvadori et al. (2007, pp. 159–160) but are not further considered here. Also the F_K(w) (Kendall Function or Kendall Measure of a copula) is the core tool for secondary return period computations (see kfuncCOP).

Let the copula \mathbf{C}(u,v; \Theta) for nonexceedances u and v be set for some copula family (formula) by a parameter vector \Theta. The copula family and parameters define the joint coupling (loosely meant the dependency/correlation) between hazards U and V. If “failure” occurs if either or both hazards U and V are at probability q threshold (u = v = 1 - 1/T = q) for T-year return period, then the real return period of failure is defined using either the copula \mathbf{C}(q,q; \Theta) or the co-copula \mathbf{C}^\star(q',q'; \Theta) for exceedance probability q' = 1 - q is

T_{q;\,\mathrm{coop}} = \frac{1}{1 - \mathbf{C}(q, q; \Theta)} = \frac{1}{\mathbf{C}^\star(1-q, 1-q; \Theta)}\mbox{\ and}

T_{q;\,\mathrm{coop}} \equiv \frac{1}{\mathrm{cooperative\ risk}}\mbox{.}

Or in words, the hazard sources collaborate or cooperate to cause failure. If failure occurs, however, if and only if both hazards U and V occur simultaneously (the hazards must “dually work together” or be “conjunctive”), then the real return period is defined using either the dual of a copula (function) \tilde{\mathbf{C}}(q,q; \Theta), the joint survival function \overline{\mathbf{C}}(q,q;\Theta), or survival copula \hat{\mathbf{C}}(q',q'; \Theta) as

T_{q;\,\mathrm{dual}} = \frac{1}{1 - \tilde{\mathbf{C}}(q,q; \Theta)} = \frac{1}{\overline{\mathbf{C}}(q,q;\Theta)} = \frac{1}{\hat{\mathbf{C}}(q',q';\Theta)} \mbox{\ and}

T_{q;\,\mathrm{dual}} \equiv \frac{1}{\mathrm{complement\ of\ dual\ protection}}\mbox{.}

Numerical demonstration is informative. Salvadori et al. (2007, p. 151) show for a Gumbel–Hougaard copula (GHcop) having \Theta = 3.055 and T = 1,000 years (q = 0.999) that T_{q;\,\mathrm{coop}} = 797.1 years and that T_{q;\,\mathrm{dual}} = 1,341.4 years, which means that average return periods between “failures” are

T_{q;\,\mathrm{coop}} \le T \le T_{q;\,\mathrm{dual}}\mbox{\ and thus}

797.1 \le T \le 1314.4\mbox{\ years.}

With the following code, these bounding return-period values are readily computed and verified using the prob2T() function from the lmomco package along with copBasic functions COP (generic functional interface to a copula) and duCOP (dual of a copula):

  q <- lmomco::T2prob(1000)
  lmomco::prob2T(  COP(q,q, cop=GHcop, para=3.055)) #  797.110
  lmomco::prob2T(duCOP(q,q, cop=GHcop, para=3.055)) # 1341.438

An early source (in 2005) by some of those authors cited on p. 151 of Salvadori et al. (2007; their citation “[67]”) shows T_{q;\,\mathrm{dual}} = 798 years—a rounding error seems to have been committed. Finally just for reference, a Gumbel–Hougaard copula having \Theta = 3.055 corresponds to an analytical Kendall Tau (see GHcop) of \tau \approx 0.673, which can be verified through numerical integration available from tauCOP as:

  tauCOP(cop=GHcop, para=3.055, brute=TRUE) # 0.6726542

Thus, a “better understanding of the statistical characteristics of [multiple hazard sources] requires the study of their joint distribution” (Salvadori et al., 2007, p. 150).

Interaction of copBasic to Copulas in Other Packages

Originally, the copBasic package was not intended to be a port of the numerous bivariate copulas or over re-implementation other bivariate copulas available in R though as the package passed its 10th year in 2018, the original intent changed. It is useful to point out a demonstration showing an implementation of the Gaussian copula from the copula package, which is shown in the Note section of med.regressCOP in a circumstance of ordinary least squares linear regression compared to median regression of a copula as well as prediction limits of both regressions. Another demonstration in context of maximum pseudo-log-likelihood estimation of copula parameters is seen in the Note section mleCOP, and also see “API to the copula package” or “package copula (comparison to)” entries in the Index of this user manual.

Author(s)

William Asquith william.asquith@ttu.edu

References

Cherubini, U., Luciano, E., and Vecchiato, W., 2004, Copula methods in finance: Hoboken, NJ, Wiley, 293 p.

Hernández-Maldonado, V., Díaz-Viera, M., and Erdely, A., 2012, A joint stochastic simulation method using the Bernstein copula as a flexible tool for modeling nonlinear dependence structures between petrophysical properties: Journal of Petroleum Science and Engineering, v. 90–91, pp. 112–123.

Joe, H., 2014, Dependence modeling with copulas: Boca Raton, CRC Press, 462 p.

Hofert, M., Kojadinovic, I., Mächler, M., and Yan, J., 2018, Elements of copula modeling with R: Dordrecht, Netherlands, Springer.

Nelsen, R.B., 2006, An introduction to copulas: New York, Springer, 269 p.

Salvadori, G., De Michele, C., Kottegoda, N.T., and Rosso, R., 2007, Extremes in nature—An approach using copulas: Dordrecht, Netherlands, Springer, Water Science and Technology Library 56, 292 p.

Examples

## Not run: 
# Nelsen (2006, p. 75, exer. 3.15b) provides for a nice test of copBasic features.
"mcdurv" <- function(u,v, theta) {
   ifelse(u > theta & u < 1-theta & v > theta & v < 1 - theta,
             return(M(u,v) - theta), # Upper bounds copula with a shift
             return(W(u,v)))         # Lower bounds copula
}
"MCDURV" <- function(u,v, para=NULL) {
   if(is.null(para))         stop("need theta")
   if(para < 0 | para > 0.5) stop("theta ! in [0, 1/2]")
   return(asCOP(u, v, f=mcdurv, para))
}
"afunc" <- function(t) { # a sample size = 1,000 hard wired
   return(cov(simCOP(n=1000, cop=MCDURV, para=t, ploton=FALSE, points=FALSE))[1,2])
}
set.seed(6234) # setup covariance based on parameter "t" and the "root" parameter
print(uniroot(afunc, c(0, 0.5))) # "t" by simulation = 0.1023742
# Nelsen reports that if theta appox. 0.103 then covariance of U and V is zero.
# So, one will have mutually completely dependent uncorrelated uniform variables!

# Let us check some familiar measures of association:
rhoCOP( cop=MCDURV, para=0.1023742) # Spearman Rho = 0.005854481 (near zero)
tauCOP( cop=MCDURV, para=0.1023742) # Kendall Tau  = 0.2648521
wolfCOP(cop=MCDURV, para=0.1023742) # S & W Sigma  = 0.4690174 (less familiar)
D <- simCOP(n=1000, cop=MCDURV, para=0.1023742) # Plot mimics Nelsen (2006, fig. 3.11)
# Lastly, open research problem. L-comoments (matrices) measure high dimension of
# variable comovements (see lmomco package)---"method of L-comoments" for estimation?
lmomco::lcomoms2(simCOP(n=1000, cop=MCDURV, para=0),   nmom=5) # Perfect neg. corr.
lmomco::lcomoms2(simCOP(n=1000, cop=MCDURV, para=0.1023742), nmom=5)
lmomco::lcomoms2(simCOP(n=1000, cop=MCDURV, para=0.5), nmom=5) # Perfect pos. corr.
# T2 (L-correlation), T3 (L-coskew), T4 (L-cokurtosis), and T5 matrices result. For
# Theta = 0 or 0.5 see the matrix symmetry with a sign change for L-coskew and T5 on
# the off diagonals (offdiags). See unities for T2. See near zero for offdiag terms
# in T2 near zero. But then see that T4 off diagonals are quite different from those
# for Theta 0.1024 relative to 0 or 0.5. As a result, T4 has captured a unique
# property of U vs V.
## End(Not run)

The Ali–Mikhail–Haq Copula

Description

The Ali–Mikhail–Haq copula (Nelsen, 2006, pp. 92–93, 172) is

\mathbf{C}_{\Theta}(u,v) = \mathbf{AMH}(u,v) = \frac{uv}{1 - \Theta(1-u)(1-v)}\mbox{,}

where \Theta \in [-1,+1), where the right boundary, \Theta = 1, can sometimes be considered valid according to Mächler (2014). The copula \Theta \rightarrow 0 becomes the independence copula (\mathbf{\Pi}(u,v); P), and the parameter \Theta is readily computed from a Kendall Tau (tauCOP) by

\tau_\mathbf{C} = \frac{3\Theta - 2}{3\Theta} - \frac{2(1-\Theta)^2\log(1-\Theta)}{3\Theta^2}\mbox{,}

and by Spearman Rho (rhoCOP), through Mächler (2014), by

\rho_\mathbf{C} = \sum_{k=1}^\infty \frac{3\Theta^k}{{k + 2 \choose 2}^2}\mbox{.}

The support of \tau_\mathbf{C} is [(5 - 8\log(2))/3, 1/3] \approx [-0.1817258, 0.3333333] and the \rho_\mathbf{C} is [33 - 48\log(2), 4\pi^2 - 39] \approx [-0.2710647, 0.4784176], which shows that this copula has a limited range of dependency. The infinite summation is easier to work with than Nelsen (2006, p. 172) definition of

\rho_\mathbf{C} = \frac{12(1+\Theta)}{\Theta^2}\mathrm{dilog}(1-\Theta)- \frac{24(1-\Theta)}{\Theta^2}\log(1-\Theta)- \frac{3(\Theta+12)}{\Theta}\mbox{,}

where the \mathrm{dilog(x)} is the dilogarithm function defined by

\mathrm{dilog}(x) = \int_1^x \frac{\log(t)}{1-t}\,\mathrm{d}t\mbox{.}

The integral version has more nuances with approaches toward \Theta = 0 and \Theta = 1 than the infinite sum version.

Usage

AMHcop(u, v, para=NULL, rho=NULL, tau=NULL, fit=c("rho", "tau"), ...)

Arguments

Value

Value(s) for the copula are returned. Otherwise if tau is given, then the \Theta is computed and a list having

and if para=NULL and tau=NULL, then the values within u and v are used to compute Kendall Tau and then compute the parameter, and these are returned in the aforementioned list.

Note

Mächler (2014) reports on accurate computation of \tau_\mathbf{C} and \rho_\mathbf{C} for this copula for conditions of \Theta \rightarrow 0 and in particular derives the following equation, which does not have \Theta in the denominator:

\rho_\mathbf{C} = \sum_{k=1}^{\infty} \frac{3\Theta^k}{{k+2 \choose 2}^2}\mbox{.}

The copula package provides a Taylor series expansion for \tau_\mathbf{C} for small \Theta in the copula::tauAMH(). This is demonstrated here between the implementation of \tau = 0 for parameter estimation in the copBasic package to that in the more sophisticated implementation in the copula package.

  copula::tauAMH(AMHcop(tau=0)$para) # theta = -2.313076e-07

It is seen that the numerical approaches yield quite similar results for small \tau_\mathbf{C}, and finally, a comparison to the \rho_\mathbf{C} is informative:

  rhoCOP(AMHcop, para=1E-9)    # 3.333333e-10 (two nested integrations)
  copula:::.rhoAmhCopula(1E-9) # 3.333333e-10 (cutoff based)
  theta <- seq(-1,1, by=.0001)
  RHOa <- sapply(theta, function(t) rhoCOP(AMHcop, para=t))
  RHOb <- sapply(theta, function(t) copula:::.rhoAmhCopula(t))
  plot(10^theta, RHOa-RHOb, type="l", col=2)

The plot shows that the apparent differences are less than 1 part in 100 million—The copBasic computation is radically slower though, but rhoCOP was designed for generality of copula family.

Author(s)

W.H. Asquith

References

Joe, H., 2014, Dependence modeling with copulas: Boca Raton, CRC Press, 462 p.

Mächler, Martin, 2014, Spearman's Rho for the AMH copula—A beautiful formula: copula package vignette, accessed on April 7, 2018, at https://CRAN.R-project.org/package=copula under the vignette rhoAMH-dilog.pdf.

Nelsen, R.B., 2006, An introduction to copulas: New York, Springer, 269 p.

Pranesh, Kumar, 2010, Probability distributions and estimation of Ali–Mikhail–Haq copula: Applied Mathematical Sciences, v. 4, no. 14, p. 657–666.

See Also

P

Examples

## Not run: 
  t <- 0.9 # The Theta of the copula and we will compute Spearman Rho.
  di <- integrate(function(t) log(t)/(1-t), lower=1, upper=(1-t))$value
  A <- di*(1+t) - 2*log(1-t) + 2*t*log(1-t) - 3*t # Nelsen (2007, p. 172)
  rho <- 12*A/t^2 - 3    # 0.4070369
  rhoCOP(AMHcop, para=t) # 0.4070369
  sum(sapply(1:100, function(k) 3*t^k/choose(k+2, 2)^2)) # Machler (2014)
  # 0.4070369 (see Note section, very many tens of terms are needed) 
## End(Not run)

## Not run: 
  layout(matrix(1:2, byrow=TRUE)) # Note: Kendall Tau is same on reversal.
  s <- 2; set.seed(s); nsim <- 10000
  UVn <- simCOP(nsim, cop=AMHcop, para=c(-0.9, "FALSE" ), col=4)
  mtext("Normal definition [default]") # '2nd' parameter could be skipped
  set.seed(s) # seed used to keep Rho/Tau inside attainable limits
  UVr <- simCOP(nsim, cop=AMHcop, para=c(-0.9, "TRUE"),   col=2)
  mtext("Reversed definition")
  AMHcop(UVn[,1], UVn[,2], fit="rho")$rho # -0.2581653
  AMHcop(UVr[,1], UVr[,2], fit="rho")$rho # -0.2570689
  rhoCOP(cop=AMHcop, para=-0.9)           # -0.2483124
  AMHcop(UVn[,1], UVn[,2], fit="tau")$tau # -0.1731904
  AMHcop(UVr[,1], UVr[,2], fit="tau")$tau # -0.1724820
  tauCOP(cop=AMHcop, para=-0.9)           # -0.1663313 
## End(Not run)

Copula of Circular Uniform Distribution

Description

The Circular copula of the coordinates (x, y) of a point chosen at random on the unit circle (Nelsen, 2006, p. 56) is given by

\mathbf{C}_{\mathrm{CIRC}}(u,v) = \mathbf{M}(u,v) \mathrm{\ for\ }|u-v| > 1/2\mathrm{,}

\mathbf{C}_{\mathrm{CIRC}}(u,v) = \mathbf{W}(u,v) \mathrm{\ for\ }|u+v-1| > 1/2\mathrm{,\ and}

\mathbf{C}_{\mathrm{CIRC}}(u,v) = \frac{u+v}{2} - \frac{1}{4} \mathrm{\ otherwise\ }\mathrm{.}

The coordinates of the unit circle are given by

\mathrm{CIRC}(x,y) = \biggl(\frac{\mathrm{cos}\bigl(\pi(u-1)\bigr)+1}{2}, \frac{\mathrm{cos}\bigl(\pi(v-1)\bigr)+1}{2}\biggr)\mathrm{.}

Usage

CIRCcop(u, v, para=NULL, as.circ=FALSE, ...)

Arguments

Value

Value(s) for the copula are returned.

Author(s)

W.H. Asquith

References

Nelsen, R.B., 2006, An introduction to copulas: New York, Springer, 269 p.

Examples

CIRCcop(0.5, 0.5) # 0.25 quarterway along the diagonal upward to right
CIRCcop(0.5, 1  ) # 0.50 halfway across in horizontal direction
CIRCcop(1  , 0.5) # 0.50 halfway across in  vertical  direction

## Not run: 
  nsim <- 2000
  rtheta <- runif(nsim, min=0, max=2*pi) # polar coordinate simulation
  XY <- data.frame(X=cos(rtheta)/2 + 1/2, Y=sin(rtheta)/2 + 1/2)
  plot(XY, lwd=0.8, col="lightgreen", xaxs="i", yaxs="i", las=1,
           xlab="X OF UNIT CIRCLE OR NONEXCEEDANCE PROBABILITY U",
           ylab="Y OF UNIT CIRCLE OR NONEXCEEDANCE PROBABILITY V")
  UV <- simCOP(nsim, cop=CIRCcop, lwd=0.8, col="salmon3", ploton=FALSE)
  theta <- 3/4*pi+0.1 # select a point on the upper left of the circle
  x <- cos(theta)/2 + 1/2; y <- sin(theta)/2 + 1/2 # coordinates
  H <- CIRCcop(x, y, as.circ=TRUE) # 0.218169  # Pr[X <= x & Y <= y]
  points(x, y, pch=16, col="forestgreen", cex=2)
  segments(0, y, x, y, lty=2, lwd=2, col="forestgreen")
  segments(x, 0, x, y, lty=2, lwd=2, col="forestgreen")
  Hemp1 <- sum(XY$X <= x & XY$Y <= y) / nrow(XY) # about 0.22 as expected
  u <- 1-acos(2*x-1)/pi; v <- 1-acos(2*y-1)/pi
  segments(0, v, u, v, lty=2, lwd=2, col="salmon3")
  segments(u, 0, u, v, lty=2, lwd=2, col="salmon3")
  points(u, v, pch=16, cex=2,        col="salmon3")
  arrows(x, y, u, v, code=2, lwd=2, angle=15) # arrow points from (X,Y) coordinate
  # specified by angle theta in radians on the unit circle to the corresponding
  # coordinate in (U,V) domain of uniform circular distribution copula
  Hemp2 <- sum(UV$U <= u & UV$V <= v) / nrow(UV) # about 0.22 as expected
  # Hemp1 and Hemp2 are about equal to each other and converge as nsim
  # gets very large, but the origin of the simulations to get to each
  # are different: (1) one in polar coordinates and (2) by copula.
  # Now, draw the level curve for the empirical Hs and as nsim gets large the two
  # lines will increasingly plot on top of each other.
  lshemp1 <- level.setCOP(cop=CIRCcop, getlevel=Hemp1, lines=TRUE, col="blue", lwd=2)
  lshemp2 <- level.setCOP(cop=CIRCcop, getlevel=Hemp2, lines=TRUE, col="blue", lwd=2)
  txt <- paste0("level curves for Pr[X <= x & Y <= y] and\n",
                "level curves for Pr[U <= u & V <= v],\n",
                "which equal each other as nsim gets large")
  text(0.52, 0.52, txt, srt=-46, col="blue") # 
## End(Not run)

## Not run: 
  # Nelsen (2007, ex. 3.2, p. 57) # Singular bivariate distribution with
  # standard normal margins that is not bivariate normal.
  U <- runif(500); V <- simCOPmicro(U, cop=CIRCcop)
  X  <- qnorm(U, mean=0, sd=1);    Y <- qnorm(V, mean=0, sd=1)
  plot(X,Y, main="Nelsen (2007, ex. 3.2, p. 57)", xlim=c(-4,4), ylim=c(-4,4),
            lwd=0.8, col="turquoise")
  rug(X, side=1, col=grey(0,0.5), tcl=0.5)
  rug(Y, side=2, col=grey(0,0.5), tcl=0.5) #
## End(Not run)

## Not run: 
  DX <- c(5, 5, -5, -5); DY <- c(5, 5, -5, -5); D <- 6; R <- D/2
  plot(DX, DY, type="n", xlim=c(-10, 10), ylim=c(-10,10), xlab="X", ylab="Y")
  abline(h=DX, lwd=2, col="seagreen"); abline(v=DY, lwd=2, col="seagreen")
  for(i in seq_len(length(DX))) {
    for(j in seq_len(length(DY))) {
      UV <- simCOP(n=30, cop=CIRCcop, pch=16, col="darkgreen", cex=0.5, graphics=FALSE)
      points(UV[,1]-0.5, UV[,2]-0.5, pch=16, col="darkgreen", cex=0.5)
      XY <- data.frame(X=DX[i]+sign(DX[i])*D*(cos(pi*(UV$U-1))+1)/2-sign(DX[i])*R,
                       Y=DY[j]+sign(DY[j])*D*(cos(pi*(UV$V-1))+1)/2-sign(DY[j])*R)
      points(XY, lwd=0.8, col="darkgreen")
    }
    abline(h=DX[i]+R, lty=2, col="seagreen"); abline(h=DX[i]-R, lty=2, col="seagreen")
    abline(v=DY[i]+R, lty=2, col="seagreen"); abline(v=DY[i]-R, lty=2, col="seagreen")
  } #
## End(Not run)

## Not run: 
  para <- list(cop1=CIRCcop, para1=NULL, cop2=W, para2=NULL, alpha=0.8, beta=0.8)
  UV <- simCOP(n=2000, col="darkgreen", cop=composite2COP, para=para)
  XY <- data.frame(X=(cos(pi*(UV$U-1))+1)/2, Y=(cos(pi*(UV$V-1))+1)/2)
  plot(XY, type="n", xlab=paste0("X OF CIRCULAR UNIFORM DISTRIBUTION OR\n",
                                 "NONEXCEEDANCD PROBABILITY OF U"),
                     ylab=paste0("Y OF CIRCULAR UNIFORM DISTRIBUTION OR\n",
                                 "NONEXCEEDANCD PROBABILITY OF V"))
  JK <- data.frame(U=1 - acos(2*XY$X - 1)/pi, V=1 - acos(2*XY$Y - 1)/pi)
  segments(x0=UV$U, y0=UV$V, x1=XY$X, y1=XY$Y, col="lightgreen", lwd=0.8)
  points(XY, lwd=0.8, col="darkgreen")
  points(JK, pch=16,  col="darkgreen", cex=0.5)

  t <- seq(0.001, 0.999, by=0.001)
  t <- diagCOPatf(t, cop=composite2COP, para=para)
  AB <- data.frame(X=(cos(pi*(t-1))+1)/2, Y=(cos(pi*(t-1))+1)/2)
  lines(AB, lwd=4, col="seagreen") #
## End(Not run)

The Clayton Copula

Description

The Clayton copula (Joe, 2014, p. 168) is

\mathbf{C}_{\Theta}(u,v) = \mathbf{CL}(u,v) = \mathrm{max}\bigl[(u^{-\Theta}+v^{-\Theta}-1; 0)\bigr]^{-1/\Theta}\mbox{,}

where \Theta \in [-1,\infty), \Theta \ne 0. The copula, as \Theta \rightarrow -1^{+} limits, to the countermonotonicity coupla (\mathbf{W}(u,v); W), as \Theta \rightarrow 0 limits to the independence copula (\mathbf{\Pi}(u,v); P), and as \Theta \rightarrow \infty, limits to the comonotonicity copula (\mathbf{M}(u,v); M). The parameter \Theta is readily computed from a Kendall Tau (tauCOP) by \tau_\mathbf{C} = \Theta/(\Theta+2).

Usage

CLcop(u, v, para=NULL, tau=NULL, ...)

Arguments

Value

Value(s) for the copula are returned. Otherwise if tau is given, then the \Theta is computed and a list having

and if para=NULL and tau=NULL, then the values within u and v are used to compute Kendall Tau and then compute the parameter, and these are returned in the aforementioned list.

Author(s)

W.H. Asquith

References

Joe, H., 2014, Dependence modeling with copulas: Boca Raton, CRC Press, 462 p.

See Also

M, P, W

Examples

# Lower tail dependency of Theta = pi --> 2^(-1/pi) = 0.8020089 (Joe, 2014, p. 168)
taildepCOP(cop=CLcop, para=pi)$lambdaL # 0.80201

The Copula

Description

Compute the copula or joint distribution function through a copula as shown by Nelsen (2006, p. 18) is the joint probability

\mathrm{Pr}[U \le u, V \le v] = \mathbf{C}(u,v)\mbox{.}

The copula is an expression of the joint probability that both U \le u and V \le v.

A copula is a type of dependence function that permits straightforward characterization of dependence from independence. Joe (2014, p. 8) comments that “copula families are usually given as cdfs [cumulative distribution functions.]” A radially symmetric or permutation symmetric copula is one such that \mathbf{C}(u,v) = \mathbf{C}(v,u) otherwise the copula is asymmetric.

The copula inversions t = \mathbf{C}(u{=}U, v) or t = \mathbf{C}(u, v{=}V) for a given t and U or V are provided by COPinv and COPinv2, respectively. A copula exists in the domain of the unit square (\mathcal{I}^2 = [0, 1]\times [0,1]) and is a grounded function meaning that

\mathbf{C}(u,0) = 0 = \mathbf{C}(0,v) \mbox{\ and\ thus\ } \mathbf{C}(0,0) = 0\mbox{, }

and other properties of a copula are that

\mathbf{C}(u,1) = u \mbox{\ and\ } \mathbf{C}(1,v) = v\mbox{\ and}

\mathbf{C}(1,1) = 1\mbox{.}

Copulas can be combined with each other (convexCOP, convex2COP, composite1COP,
composite2COP, composite3COP, and glueCOP) to form more complex and sophisticated dependence structures. Also copula multiplication—a special product of two copulas—yields another copula (see prod2COP).

Perhaps the one of the more useful features of this function is that in practical applications it can be used to take a copula formula and reflect or rotated it in fashions to attain association structures that the native definition of the copula can not acquire. The terminal demonstration in the Examples demonstrates this for the Raftery copula (RFcop).

Usage

COP(u, v, cop=NULL, para=NULL,
          reflect=c("cop", "surv", "acute", "grave",
                      "1",    "2",     "3",     "4"), ...)

Arguments

Value

Value(s) for the copula are returned.

Note

REFLECTIONS OF VARIABLES (ROTATIONS OF THE COPULA)—The copula of (1-U, 1-V) is the survival copula (\hat{\mathbf{C}}(u,v); surCOP) and is defined as

\mathrm{Pr}[\,U > u, V > v\,] = \hat{\mathbf{C}}(u,v) = u + v - 1 + \mathbf{C}(1-u,1-v)\:\rightarrow\mbox{\ \code{"surv"},}

whereas, following the notation of Joe (2014, p. 271), the copula of (1-U, V) is defined as

\mathrm{Pr}[\,U > u, V \le v\,] = \acute{\mathbf{C}}(u,v) = v - \mathbf{C}(1-u,v)\:\rightarrow\mbox{\ \code{"acute"}, and}

the copula of (U, 1-V) is defined as

\mathrm{Pr}[\,U \le u, V > v\,] = \grave{\mathbf{C}}(u,v) = u - \mathbf{C}(u,1-v)\:\rightarrow\mbox{\ \code{"grave"}.}

Here it is useful to stress the probability aspects that change with the reflections, but this section ends with the reflections themselves being graphically highlighted. The Examples stress simple variations on the probability aspects.

To clarify the seemingly clunky nomenclature—Joe (2014) does not provide “names” for \acute{\mathbf{C}}(u,v) or \grave{\mathbf{C}}(u,v)—the following guidance is informative where the numbers in the list align to those for the reflect argument:
\mbox{}\quad\mbox{}(2) "surv" or \hat{\mathbf{C}}(u,v) is a reflection of U and V on the horizontal and vertical axes, respectively,
\mbox{}\quad\mbox{}(3) "acute" or \acute{\mathbf{C}}(u,v) is a reflection of U on the horizontal axis, and
\mbox{}\quad\mbox{}(4) "grave" or \grave{\mathbf{C}}(u,v) is a reflection of V on the verical axis.
The names "acute" and "grave" match those used in the Rd-format math typesetting instructions. Users are directed to the documentation of simCOPmicro for further discussion because the COP function is expected to be an early entry point for new users interested in the copBasic API.

For the copBasic package and in order to keep some logic brief and code accessible for teaching and applied circumstances, reflections of copulas using analogs to the reflect argument are only natively supported in the COP and simCOPmicro functions. The interfaces of copBasic should already be flexible enough for users to adapt and (or) specially name reflections of copulas for deployment. A caveat is that some individual copula implementations might have some self-supporting infrastructure. The reflection can also be set within the para argument when it is a list (see Examples).

An example is warranted. Although the Gumbel–Hougaard copula (GHcop) can be reflected by COP and simCOPmicro and testing is made in the Note section of simCOPmicro, it is suggested that a user generally requiring say a horizontal reflection ru (or vertical reflection rv) of the Gumbel–Hougaard copula write a function named perhaps ruGHcop (or rvGHcop).

Such functions, consistent with the mathematics at the beginning of this Note, can be used throughout functions of copBasic using the cop arguments. The author (Asquith) eschews implementing what is perceived as too much flexibility and overhead for the package to support the three reflection permutations universally across all copula functions of the package. This being said, COP can take an R list for the para argument for rotation/reflection:

  set.seed(14)
  UV3 <- simCOP(20, cop=COP, pch=16, col=3,
                para=list(cop=GLcop, para=pi+1, reflect="3"))
  set.seed(14)
  UV2 <- simCOP(20, cop=COP, pch=16, col=4, ploton=FALSE,
                para=list(cop=GLcop, para=pi+1, reflect="2"))
  arrows(x0=UV3[,1], y0=UV3[,2], x=UV2[,1], y=UV2[,2])

and this type of interface is similar to composite1COP as the following rotation and then asymmetric construction shows:

  UV <- simCOP(1000, cop=composite1COP,
                     para=list(cop1=COP,
                               para1=c(cop=GHcop, para=pi+1, reflect="4"),
                               alpha=0.1, beta=0.3))

Author(s)

W.H. Asquith

References

Joe, H., 2014, Dependence modeling with copulas: Boca Raton, CRC Press, 462 p.

Nelsen, R.B., 2006, An introduction to copulas: New York, Springer, 269 p.

See Also

coCOP, duCOP, surCOP, surfuncCOP

Examples

u <- runif(1); v <- runif(1)
COP(cop=W,u,v); COP(cop=P,u,v); COP(cop=M,u,v); COP(cop=PSP,u,v)

FF <- 0.75 # 75th percentile, nonexceedance
GG <- 0.20 # 25th percentile, nonexceedance
bF <- 1 - FF; bG <- 1 - GG     # exceedance
# What is the probability that both X and Y are less than
# 75th and 20th percentiles, respectively?
COP(cop=P, FF, GG)    # 0.15
# What is the probability that both X and Y are greater than
# 75th and 20th percentiles, respectively?
surCOP(cop=P, bF, bG) # 0.20
# What is the probability that either X or Y are less than
# the 75th and 20th percentiles, respectively?
duCOP(cop=P, FF, GG)  # 0.8
# What is the probability that either X or Y are greater than
# the 75th and 20th percentiles, respectively?
coCOP(cop=P, bF, bG)  # 0.85

# Repeat for the PSP copula:
# What is the probability that both X and Y are less than
# 75th and 20th percentiles, respectively?
COP(cop=PSP, FF, GG)    # 0.1875
# What is the probability that both X and Y are greater than
# 75th and 20th percentiles, respectively?
surCOP(cop=PSP, bF, bG) # 0.2375
# What is the probability that either X or Y are less than
# the 75th and 20th percentiles, respectively?
duCOP(cop=PSP, FF, GG)  # 0.7625
# What is the probability that either X or Y are greater than
# the 75th and 20th percentiles, respectively?
coCOP(cop=PSP, bF, bG)  # 0.8125
# Both of these summations equal unity
   COP(cop=PSP, FF, GG) + coCOP(cop=PSP, bF, bG) # 1
surCOP(cop=PSP, bF, bG) + duCOP(cop=PSP, FF, GG) # 1

FF <- 0.99 # 99th percentile, nonexceedance
GG <- 0.50 # 50th percentile, nonexceedance
bF <- 1 - FF # nonexceedance
bG <- 1 - GG # nonexceedance
# What is the probability that both X and Y are less than
# 99th and 50th percentiles, respectively?
COP(cop=P, FF, GG)    # 0.495
# What is the probability that both X and Y are greater than
# 99th and 50th percentiles, respectively?
surCOP(cop=P, bF, bG) # 0.005
# What is the probability that either X or Y are less than
# the 99th and 50th percentiles, respectively?
duCOP(cop=P, FF, GG)  # 0.995
# What is the probability that either X or Y are greater than
# the 99th and 50th percentiles, respectively?
coCOP(cop=P, bF, bG)  # 0.505

## Not run: 
  # MAJOR EXAMPLE FOR QUICKLY MODIFYING INHERENT ASSOCIATION STRUCTURES
  p <- 0.5 # Reasonable strong positive association for the Raftery copula
  "RFcop1" <- function(u,v, para) COP(u,v, cop=RFcop, para=para, reflect="1")
  "RFcop2" <- function(u,v, para) COP(u,v, cop=RFcop, para=para, reflect="2")
  "RFcop3" <- function(u,v, para) COP(u,v, cop=RFcop, para=para, reflect="3")
  "RFcop4" <- function(u,v, para) COP(u,v, cop=RFcop, para=para, reflect="4")

  d <- 0.01 # Just to speed up the density plots a bit
  densityCOPplot(RFcop1, para=p, contour.col=1, deluv=d) # Raftery in the literature
  densityCOPplot(RFcop2, para=p, contour.col=1, deluv=d, ploton=FALSE)
  densityCOPplot(RFcop3, para=p, contour.col=1, deluv=d, ploton=FALSE)
  densityCOPplot(RFcop4, para=p, contour.col=1, deluv=d, ploton=FALSE)
  # Now some text into the converging tail to show the reflection used.
  text(-2,-2, "reflect=1", col=2); text(+2,+2, "reflect=2", col=2)
  text(+2,-2, "reflect=3", col=2); text(-2,+2, "reflect=4", col=2) #
## End(Not run)

## Not run: 
  # ALTERNATIVE EXAMPLE FOR QUICKLY MODIFYING INHERENT ASSOCIATION STRUCTURES
  # To show how the reflection can be alternatively specified and avoid in this case
  # making four Raftery functions, pass by a list para argument. Also, demonstrate
  # that cop1 --> cop and para1 --> para are the same in use of the function. This
  # provides some nomenclature parallel to the other compositing functions.
  densityCOPplot(COP, para=list(reflect=1, cop1=RFcop, para=p ), deluv=d,
                            contour.col=1, drawlabels=FALSE)
  densityCOPplot(COP, para=list(reflect=2, cop= RFcop, para1=p), deluv=d,
                            contour.col=2, drawlabels=FALSE, ploton=FALSE)
  densityCOPplot(COP, para=list(reflect=3, cop1=RFcop, para1=p), deluv=d,
                            contour.col=3, drawlabels=FALSE, ploton=FALSE)
  densityCOPplot(COP, para=list(reflect=4, cop= RFcop, para=p ), deluv=d,
                            contour.col=4, drawlabels=FALSE, ploton=FALSE)
  # Now some text into the converging tail to show the reflection used.
  text(-2,-2, "reflect=1", col=2); text(+2,+2, "reflect=2", col=2)
  text(+2,-2, "reflect=3", col=2); text(-2,+2, "reflect=4", col=2) #
## End(Not run)

## Not run: 
  # Similar example to previous, but COP() can handle the reflection within a
  # parameter list ,and the reflect, being numeric here, is converted to
  # character internally.
  T12 <- CLcop(tau=0.67)$para # Kendall Tau of 0.67
  T12 <- list(cop=CLcop, para=T12, reflect=2) # reflected to upper tail dependency
  UV  <- simCOP(n=1000, cop=COP, para=T12) # 
## End(Not run)

The Inverse of a Copula for V with respect to U

Description

Compute the inverse of a copula for V with respect to U given t or

t = \mathbf{C}(u{=}U,v) \rightarrow \mathbf{C}^{(-1)}(u{=}U, t) = v\mbox{,}

and solving for v. Nelsen (2006, p. 12) does not so name this function as an “inverse.” The COPinv function is internally used by level.curvesCOP and level.curvesCOP2. A common misapplication that will puzzle the user (including the developer after long breaks from package use) is that the following call and error message are often seen, if silent=FALSE:

  COPinv(0.2, 0.25, cop=PSP)
  # Error in uniroot(func, interval = c(lo, 1), u = u, LHS = t, cop = cop,  :
  #  f() values at end points not of opposite sign
  # [1] NA

This is a harmless error in the sense that COPinv is functioning properly. One can not invert a copula for u < t and for u = t the v = 1 because of fundamental copula properties.

Usage

COPinv(cop=NULL, u, t, para=NULL, silent=TRUE, ...)

Arguments

Value

Value(s) for v are returned.

Author(s)

W.H. Asquith

References

Nelsen, R.B., 2006, An introduction to copulas: New York, Springer, 269 p.

See Also

COP, COPinv2, level.curvesCOP, level.curvesCOP2

Examples

COPinv(cop=N4212cop, para=2, u=0.5, t=0.2)

The Inverse of a Copula for U with respect to V

Description

Compute the inverse of a copula for U with respect to V given t or

t = \mathbf{C}(u,v{=}V) \rightarrow \mathbf{C}^{(-1)}(v{=}V, t) = u\mbox{,}

and solving for u. Nelsen (2006, p. 12) does not so name this function as an “inverse.” The COPinv2 function is internally used by level.curvesCOP2. A common misapplication that will puzzle the user (including the developer after long breaks from package use) is that the following call and error message are often seen, if silent=FALSE:

  COPinv2(0.2, 0.25, cop=PSP)
  # Error in uniroot(func, interval = c(lo, 1), u = u, LHS = t, cop = cop,  :
  #  f() values at end points not of opposite sign
  # [1] NA

This is a harmless error in the sense that COPinv2 is functioning properly. One can not invert a copula for v < t and for v = t the u = 1 because of fundamental copula properties.

Usage

COPinv2(cop=NULL, v, t, para=NULL, silent=TRUE, ...)

Arguments

Value

Value(s) for u are returned.

Author(s)

W.H. Asquith

References

Nelsen, R.B., 2006, An introduction to copulas: New York, Springer, 269 p.

See Also

COP, COPinv, level.curvesCOP, level.curvesCOP2

Examples

# See those for COPinv as they are the same by analogy.

The Bivariate Empirical Copula

Description

The bivariate empirical copula (Nelsen, 2006, p. 219) for a bivariate sample of length n is defined for random variables X and Y as

\mathbf{C}_n\biggl(\frac{i}{n}, \frac{j}{n}\biggr) = \frac{\mathrm{number\ of\ pairs\ (}x,y\mathrm{)\ with\ }x \le x_{(i)}\mathrm{\ and\ }y \le y_{(j)}}{n}\mbox{,}

where x_{(i)} and y_{(i)}, 1 \le i,j \le n or expressed as

\mathbf{C}_n\biggl(\frac{i}{n}, \frac{j}{n}\biggr) = \frac{1}{n}\sum_{i=1}^n \mathbf{1}\biggl(\frac{R_i}{n} \le u_i, \frac{S_i}{n} \le v_i \biggr)\mbox{,}

where R_i and S_i are ranks of the data for U and V, and \mathbf{1}(.) is an indicator function that score 1 if condition is true otherwise scoring zero. Using more generic notation, the empirical copula can be defined by

\mathbf{C}_{n}(u,v) = \frac{1}{n}\sum_{i=1}^n \mathbf{1}\bigl(u^\mathrm{obs}_{i} \le u_i, v^\mathrm{obs}_{i} \le v_i \bigr)\mbox{,}

where u^\mathrm{obs} and v^\mathrm{obs} are thus some type of nonparametric nonexceedance probabilities based on counts of the underlying data expressed in probabilities.

Hazen Empirical Copula—The “Hazen form” of the empirical copula is

\mathbf{C}^\mathcal{H}_{n}(u,v) = \frac{1}{n}\sum_{i=1}^n \mathbf{1}\biggl(\frac{R_i - 0.5}{n} \le u_i, \frac{S_i - 0.5}{n} \le v_i \biggr)\mbox{,}

which can be triggered by ctype="hazen". This form is named for this package because of direct similarity of the Hazen plotting position to the above definition. Joe (2014, pp. 247–248) uses the Hazen form. Joe continues by saying “[the] adjustment of the uniform score [(R - 0.5)/n]] could be done in an alternative form, but there is [asymptotic] equivalence[, and that] \mathbf{C}^\mathcal{H}_{n} puts mass of n^{-1} at the tuples ([r_{i1} - 0.5]/n, \ldots, [r_{id} - 0.5]/n) for i = 1, \ldots, n.” A footnote by Joe (2014) says that “the conversion [R/(n+1)] is commonly used for the empirical copula.” This later form is the “Weibull form” described next. Joe's preference for the Hazen form is so that the sum of squared normal scores is closer to unity for large n than such a sum would be attained using the Weibull form.

Weibull Empirical Copula—The “Weibull form” of the empirical copula is

\mathbf{C}^\mathcal{W}_{n}(u,v) = \frac{1}{n}\sum_{i=1}^n \mathbf{1}\biggl(\frac{R_i}{n+1} \le u_i, \frac{S_i}{n+1} \le v_i \biggr)\mbox{,}

which can be triggered by ctype="weibull". This form is named for this package because of direct similarity of the Weibull plotting position to the definition, and this form is the default (see argument description).

Bernstein Empirical Copula—The empirical copula can be extended nonparametrically as the Bernstein empirical copula (Hernández-Maldonado, Díaz-Viera, and Erdely, 2012) and is formulated as

\mathbf{C}^\mathcal{B}_n(u,v; \eta) = \sum_{i=1}^n\sum_{j=1}^n \mathbf{C}_{n}\biggl(\frac{i}{n},\frac{j}{n}\biggr) \times \eta(i,j; u,v)\mbox{,}

where the individual Bernstein weights \eta(i,j) for the kth paired value of the u and v vectors are

\eta(i,j; u,v) = {n \choose i} u^i (1-u)^{n-i} \times {n \choose j} u^j (1-u)^{n-j}\mbox{.}

The Bernstein extension, albeit conceptually pure in its shuffling by binomial coefficients and left- and right-tail weightings, is quite CPU intensive as inspection of the equations above indicates a nest of four for() loops in R. (The native R code of copBasic uses the sapply() function in R liberally for substantial but not a blazing fast speed increase.) The Bernstein extension results in a smoother surface of the empirical copula and can be triggered by ctype="bernstein".

Checkerboard Empirical Copula—A simple smoothing to the empirical copula is the checkerboard empirical copula (Segers et al., 2017) that has been adapted from the copula package. It is numerically intensive like the Bernstein and possibly of limited usefulness for large sample sizes. The checkerboard extension can be triggered by ctype="checkerboard" and is formulated as

\mathbf{C}^\sharp_{n}(U) = \frac{1}{n+o} \sum_{i=1}^n\prod_{i=1}^d \mathrm{min}[\mathrm{max}[n U_j - R^{(n)}_{i,j} + 1,0],1]\mathrm{,}

where U is a d=2 column matrix of u and v, R is a rank function, and o is an offset term on [0,1].

The empirical copula frequency can be defined (Nelson, 2006, p. 219) as

\mathbf{c}_n(u, v) = \mathbf{C}_n\biggl(\frac{i}{n}, \frac{j}{n}\biggr) - \mathbf{C}_n\biggl(\frac{i-1}{n}, \frac{j}{n}\biggr) - \mathbf{C}_n\biggl(\frac{i}{n}, \frac{j-1}{n}\biggr) + \mathbf{C}_n\biggl(\frac{i-i}{n}, \frac{j-1}{n}\biggr)\mbox{.}

Usage

EMPIRcop(u, v, para=NULL,
               ctype=c("weibull", "hazen", "1/n", "bernstein", "checkerboard"),
                          bernprogress=FALSE, checkerboard.offset=0, ...)

Arguments

Value

Value(s) for the copula are returned.

Note

Not all theoretical measures of copula dependence (both measures of association and measures of asymmetry), which use numerical integration by the integrate() function in R, can be used for all empirical copulas because of “divergent” integral errors; however, examples using Hoeffding Phi (\Phi_\mathbf{C}; hoefCOP) and shown under Examples. Other measures of copula dependence include blomCOP, footCOP, giniCOP, rhoCOP, tauCOP, wolfCOP, joeskewCOP, and uvlmoms. Each of these measures fortunately has a built-in sample estimator.

It is important to distinquish between a sample estimator and the estimation of the measure using the empirical copula itself via the EMPIRcop function. The sample estimators (triggered by the as.sample arguments for the measures) are reasonably fast and numerically preferred over using the empirical copula. Further, the generally slow numerical integrations for the theoretical definitions of these copula measures might have difficulties. Limited testing, however, suggests prevalence of numerical integration not erroring using the Bernstein extension of the empirical copula, which must be a by-product of the enhanced and sufficient smoothness for the R default numerical integration to succeed. Many of the measures have brute option for a brute-force numerical integration on a regular grid across the empirical copula—these are slow but should not trigger errors. As a general rule, users should still use the sample estimators instead.

Author(s)

W.H. Asquith

References

Hernández-Maldonado, V., Díaz-Viera, M., and Erdely, A., 2012, A joint stochastic simulation method using the Bernstein copula as a flexible tool for modeling nonlinear dependence structures between petrophysical properties: Journal of Petroleum Science and Engineering, v. 90–91, pp. 112–123.

Nelsen, R.B., 2006, An introduction to copulas: New York, Springer, 269 p.

Salvadori, G., De Michele, C., Kottegoda, N.T., and Rosso, R., 2007, Extremes in Nature—An approach using copulas: Springer, 289 p.

Segers, J., Sibuya, M., and Tsukahara, H., 2017, The empirical beta copula: Journal of Multivariate Analysis, v. 155, pp. 35–51.

See Also

diagCOP, level.curvesCOP, simCOP

Examples

## Not run: 
set.seed(62)
EMPIRcop(0.321,0.78, para=simCOP(n=90, cop=N4212cop,
                                 para=2.32, graphics=FALSE)) # [1] 0.3222222
N4212cop(0.321,0.78, para=2.32)                              # [1] 0.3201281
## End(Not run)

## Not run: 
set.seed(62) # See note below about another seed to try.
psp <- simCOP(n=34, cop=PSP, ploton=FALSE, points=FALSE) * 150
# Pretend psp is real data, the * 150 is to clearly get into an arbitrary unit system.

# The sort=FALSE is critical in the following two calls. Although the Weibull
# plotting positions are chosen, internally EMPIRcop uses ranks, but the model
# here is to imagine one having a sample in native units of the random variables
# and then casting them into probabilities for other purposes.
fakeU <- lmomco::pp(psp[,1], sort=FALSE) # Weibull plotting position i/(n+1)
fakeV <- lmomco::pp(psp[,2], sort=FALSE) # Weibull plotting position i/(n+1)
uv <- data.frame(U=fakeU, V=fakeV); # our U-statistics

# The next four values should be very close if n above were say 1000, but the
# ctype="bernstein"" should not be used if n >> 34 because of inherently long runtime.
PSP(0.4,0.6)              # 0.3157895 (compare to listed values below)

# Two seeds are shown so that the user can see that depending on the distribution
# of the values given by para that different coincidences of which method is
# equivalent to another exist.
# For set.seed(62) --- "hazen" == "weibull" by coincidence
#    "hazen"     --> 0.3529412
#    "weibull"   --> 0.3529412
#    "1/n"       --> 0.3235294
#    "bernstein" --> 0.3228916
# For set.seed(85) --- "1/n" == "hazen" by coincidence
#    "hazen"     --> 0.3529412
#    "weibull"   --> 0.3823529
#    "1/n"       --> 0.3529412
#    "bernstein" --> 0.3440387

# For set.seed(62) --- not all measures of association can be used for all
# empirical copulas because of 'divergent' integral errors, but this is an example
# for Hoeffding Phi. These computations are CPU intensive, esp. Bernstein.
hoefCOP(as.sample=TRUE, para=uv) #  (sample estimator is fast)  # 0.4987755
hoefCOP(cop=EMPIRcop,   para=uv, ctype="hazen")                 # 0.5035348
hoefCOP(cop=EMPIRcop,   para=uv, ctype="weibull")               # 0.4977145
hoefCOP(cop=EMPIRcop,   para=uv, ctype="1/n")                   # 0.4003646
hoefCOP(cop=EMPIRcop,   para=uv, ctype="bernstein")             # 0.4563724
hoefCOP(cop=EMPIRcop,   para=uv, ctype="checkerboard")          # 0.4952427
## End(Not run)

# All other example suites shown below are dependent on the pseudo-data in the
# variable uv. It is suggested to not run with a sample size much larger than the
# above n=34 if the Bernstein comparison is intended (wanted) simply because of
# lengthy(!) run times, but the n=34 does provide a solid demonstration how the
# level curves for berstein weights are quite smooth.

## Not run: 
# Now let us construct as many as three sets of level curves to the sample
# resided in the uv sample from above using the PSP copula.
level.curvesCOP(cop=PSP); # TRUE, parametric, fast, BLACK CURVES

# Empirical copulas can consume lots of CPU.
# RED CURVES, if n is too small, uniroot() errors might be triggered and likely
# will be using the sample size of 34 shown above.
level.curvesCOP(cop=EMPIRcop, para=uv, delu=0.03, col=2, ploton=FALSE)

# GREEN CURVES (large CPU committment)
# Bernstein progress is uninformative because level.curvesCOP() has taken over control.
bpara <- list(para=uv, ctype="bernstein", bernprogress=FALSE)
level.curvesCOP(cop=EMPIRcop, para=bpara, delu=0.03, col=3, ploton=FALSE)
# The delu is increased for faster execution but more important,
# notice the greater smoothness of the Bernstein refinement.
## End(Not run)

## Not run: 
# Experimental from R Graphics by Murrell (2005, p.112)
"trans3d" <-                         # blackslashes seem needed for the package
function(x,y,z, pmat) {              # for user manual building but bad syntax
  tmat <- cbind(x,y,z,1) %*% pmat    # because remember the percent sign is a
  return(tmat[,1:2] / tmat[,4])      # a comment character in LaTeX.
}

the.grid <- EMPIRgrid(para=uv, ctype="checkerboard")
the.diag <- diagCOP(cop=EMPIRcop, para=uv, ploton=FALSE, lines=FALSE)

the.persp <- persp(the.grid$empcop, theta=-25, phi=20,
                   xlab="U VARIABLE", ylab="V VARIABLE", zlab="COPULA C(u,v)")
the.trace <- trans3d(the.diag$t, the.diag$t, the.diag$diagcop, the.persp)
lines(the.trace, lwd=2, col=2) # The diagonal of the copula

# The following could have been used as an alternative to call persp()
the.persp <- persp(x=the.grid$u, y=the.grid$v, z=the.grid$empcop, theta=-25, phi=20,
                   xlab="U VARIABLE", ylab="V VARIABLE", zlab="COPULA C(u,v)")
lines(the.trace, lwd=2, col=2) # The diagonal of the copula #
## End(Not run)

Data Frame Representation of the Bivariate Empirical Copula

Description

Generate an R data.frame representation of the bivariate empirical copula (Salvadori et al., 2007, p. 140) using the coordinates as preserved in the raw data in the parameter object of the bivariate empirical copula.

Usage

EMPIRcopdf(para=NULL, ...)

Arguments

Value

An R data.frame of u, v, and \mathbf{C}_{n}(u, v) values of the bivariate empirical copula is returned.

Author(s)

W.H. Asquith

References

Salvadori, G., De Michele, C., Kottegoda, N.T., and Rosso, R., 2007, Extremes in Nature—An approach using copulas: Springer, 289 p.

See Also

EMPIRcop

Examples

## Not run: 
psp <- simCOP(n=39, cop=PSP, ploton=FALSE, points=FALSE) * 150
# Pretend psp is real data, the * 150 is to clearly get into an arbitrary unit system.

# The sort=FALSE is critical in the following two calls to pp() from lmomco.
fakeU <- lmomco::pp(psp[,1], sort=FALSE) # Weibull plotting position i/(n+1)
fakeV <- lmomco::pp(psp[,2], sort=FALSE) # Weibull plotting position i/(n+1)
uv <- data.frame(U=fakeU, V=fakeV) # our U-statistics

empcop <- EMPIRcopdf(para=uv)
plot(empcop$u, empcop$v, cex=1.75*empcop$empcop, pch=16,
     xlab="U, NONEXCEEDANCE PROBABILITY", ylab="V, NONEXCEEDANCE PROBABILITY")
# Dot size increases with joint probability (height of the copulatic surface).
points(empcop$u, empcop$v, col=2) # red circles
## End(Not run)

Grid of the Bivariate Empirical Copula

Description

Generate a gridded representation of the bivariate empirical copula (see EMPIRcop, Salvadori et al., 2007, p. 140). This function has the primary intention of supporting 3-D renderings or 2-D images of the copulatic surface, but many empirical copula functions in copBasic rely on the grid of the empirical copula—unlike the functions that support parametric copulas.

Usage

EMPIRgrid(para=NULL, deluv=0.05, verbose=FALSE, ...)

Arguments

Value

An R list of the gridded values of u, v, and \mathbf{C}_{n}(u,v) values of the bivariate empirical copula is returned. (Well only \mathbf{C}_{n}(u,v) is in the form of a grid as an R matrix.) The deluv used to generated the grid also is returned.

Note

The extensive suite of examples is included here because the various ways that algorithms involving empirical copulas can be tested. The figures also provide excellent tools for education on copulas.

Author(s)

W.H. Asquith

References

Salvadori, G., De Michele, C., Kottegoda, N.T., and Rosso, R., 2007, Extremes in Nature—An approach using copulas: Springer, 289 p.

See Also

EMPIRcop, EMPIRcopdf

Examples

## Not run: 
# EXAMPLE 1:
psp <- simCOP(n=490, cop=PSP, ploton=FALSE, points=FALSE) * 150
# Pretend psp is real data, the * 150 is to clearly get into an arbitrary unit system.

# The sort=FALSE is critical in the following two calls to pp() from lmomco.
fakeU <- lmomco::pp(psp[,1], sort=FALSE)   # Weibull plotting position i/(n+1)
fakeV <- lmomco::pp(psp[,2], sort=FALSE)   # Weibull plotting position i/(n+1)
uv <- data.frame(U=fakeU, V=fakeV) # our U-statistics

# The follow function is used to make 3-D --> 2-D transformation
# From R Graphics by Murrell (2005, p.112)
"trans3d" <-                         # blackslashes seem needed for the package
function(x,y,z, pmat) {              # for user manual building but bad syntax
  tmat <- cbind(x,y,z,1) %*% pmat    # because remember the percent sign is a
  return(tmat[,1:2] / tmat[,4])      # a comment character in LaTeX.
}

the.grid <- EMPIRgrid(para=uv)
cop.diag <- diagCOP(cop=EMPIRcop, para=uv, ploton=FALSE, lines=FALSE)
empcop   <- EMPIRcopdf(para=uv) # data.frame of all points

# EXAMPLE 1: PLOT NUMBER 1
the.persp <- persp(the.grid$empcop, theta=-25, phi=20,
                   xlab="U VARIABLE", ylab="V VARIABLE", zlab="COPULA C(u,v)")

# EXAMPLE 1: PLOT NUMBER 2 (see change in interaction with variable 'the.grid')
the.persp <- persp(x=the.grid$u, y=the.grid$v, z=the.grid$empcop, theta=-25, phi=20,
                   xlab="U VARIABLE", ylab="V VARIABLE", zlab="COPULA C(u,v)")

the.diag <- trans3d(cop.diag$t, cop.diag$t, cop.diag$diagcop, the.persp)
lines(the.diag, lwd=4, col=3, lty=2)

points(trans3d(empcop$u, empcop$v, empcop$empcop, the.persp),
       col=rgb(0,1-sqrt(empcop$empcop),1,sqrt(empcop$empcop)), pch=16)
# the sqrt() is needed to darken or enhance the colors

S <- sectionCOP(cop=PSP, 0.2, ploton=FALSE, lines=FALSE)
thelines <- trans3d(rep(0.2, length(S$t)), S$t, S$seccop, the.persp)
lines(thelines, lwd=2, col=6)
S <- sectionCOP(cop=PSP, 0.2, ploton=FALSE, lines=FALSE, dercop=TRUE)
thelines <- trans3d(rep(0.2, length(S$t)), S$t, S$seccop, the.persp)
lines(thelines, lwd=2, col=6, lty=2)

S <- sectionCOP(cop=PSP, 0.85, ploton=FALSE, lines=FALSE, wrtV=TRUE)
thelines <- trans3d(S$t, rep(0.85, length(S$t)), S$seccop, the.persp)
lines(thelines, lwd=2, col=2)
S <- sectionCOP(cop=PSP, 0.85, ploton=FALSE, lines=FALSE, dercop=TRUE)
thelines <- trans3d(S$t, rep(0.85, length(S$t)), S$seccop, the.persp)
lines(thelines, lwd=2, col=2, lty=2)

empder <- EMPIRgridder(empgrid=the.grid)
thelines <- trans3d(rep(0.2, length(the.grid$v)), the.grid$v, empder[3,], the.persp)
lines(thelines, lwd=4, col=6) #
## End(Not run)

## Not run: 
# EXAMPLE 2:
# An asymmetric example to demonstrate that the grid is populated with the
# correct orientation---meaning U is the horizontal and V is the vertical.
"MOcop" <- function(u,v, para=NULL) { # Marshall-Olkin copula
   alpha <- para[1]; beta  <- para[2]; return(min(v*u^(1-alpha), u*v^(1-beta)))
}
# EXAMPLE 2: PLOT NUMBER 1 # See the asymmetry
uv <- simCOP(1000, cop=MOcop, para=c(0.4,0.9)) # The parameters cause asymmetry.
mtext("Simulation from a defined Marshall-Olkin Copula")
the.grid <- EMPIRgrid(para=uv, deluv=0.025)

# EXAMPLE 2: PLOT NUMBER 2
# The second plot by image() will show a "hook" of sorts along the singularity.
image(the.grid$empcop, col=terrain.colors(40)) # Second plot is made
mtext("Image of gridded Empirical Copula")

# EXAMPLE 2: PLOT NUMBER 3
empcop <- EMPIRcopdf(para=uv) # data.frame of all points
# The third plot is the 3-D version overlain with the data points.
the.persp <- persp(x=the.grid$u, y=the.grid$v, z=the.grid$empcop, theta=240, phi=40,
                   xlab="U VARIABLE", ylab="V VARIABLE", zlab="COPULA C(u,v)")
points(trans3d(empcop$u, empcop$v, empcop$empcop, the.persp),
       col=rgb(0,1-sqrt(empcop$empcop),1,sqrt(empcop$empcop)), pch=16)
mtext("3-D representation of gridded empirical copula with data points")

# EXAMPLE 2: PLOT NUMBER 4
# The fourth plot shows a simulation and the quasi-emergence of the singularity
# that of course the empirical perspective "knows" nothing about. Do not use
# the Kumaraswamy smoothing because in this case the singularity because
# too smoothed out relative to the raw empirical, but of course the sample size
# is large enough to see such things. (Try kumaraswamy=TRUE)
empsim <- EMPIRsim(n=1000, empgrid = the.grid, kumaraswamy=FALSE)
mtext("Simulations from the Empirical Copula") #
## End(Not run)

## Not run: 
# EXAMPLE 3:
psp <- simCOP(n=4900, cop=PSP, ploton=FALSE, points=FALSE) * 150
# Pretend psp is real data, the * 150 is to clearly get into an arbitrary unit system.

# The sort=FALSE is critical in the following two calls to pp() from lmomco.
fakeU <- lmomco::pp(psp[,1], sort=FALSE)   # Weibull plotting position i/(n+1)
fakeV <- lmomco::pp(psp[,2], sort=FALSE)   # Weibull plotting position i/(n+1)
uv <- data.frame(U=fakeU, V=fakeV) # our U-statistics

# EXAMPLE 3: # PLOT NUMBER 1
deluv <- 0.0125 # going to cause long run time with large n
# The small deluv is used to explore solution quality at U=0 and 1.
the.grid <- EMPIRgrid(para=uv, deluv=deluv)
the.persp <- persp(x=the.grid$u, y=the.grid$v, z=the.grid$empcop, theta=-25, phi=20,
                   xlab="U VARIABLE", ylab="V VARIABLE", zlab="COPULA C(u,v)")

S <- sectionCOP(cop=PSP, 1, ploton=FALSE, lines=FALSE)
thelines <- trans3d(rep(1, length(S$t)), S$t, S$seccop, the.persp)
lines(thelines, lwd=2, col=2)

S <- sectionCOP(cop=PSP, 0, ploton=FALSE, lines=FALSE)
thelines <- trans3d(rep(0, length(S$t)), S$t, S$seccop, the.persp)
lines(thelines, lwd=2, col=2)

S <- sectionCOP(cop=PSP, 1, ploton=FALSE, lines=FALSE, dercop=TRUE)
thelines <- trans3d(rep(1, length(S$t)), S$t, S$seccop, the.persp)
lines(thelines, lwd=2, col=2, lty=2)

S <- sectionCOP(cop=PSP, 2*deluv, ploton=FALSE, lines=FALSE, dercop=TRUE)
thelines <- trans3d(rep(2*deluv, length(S$t)), S$t, S$seccop, the.persp)
lines(thelines, lwd=2, col=2, lty=2)

empder <- EMPIRgridder(empgrid=the.grid)
thelines <- trans3d(rep(2*deluv,length(the.grid$v)),the.grid$v,empder[3,],the.persp)
lines(thelines, lwd=4, col=5, lty=2)

pdf("conditional_distributions.pdf")
  ix <- 1:length(attributes(empder)$rownames)
  for(i in ix) {
     u <- as.numeric(attributes(empder)$rownames[i])
     S <- sectionCOP(cop=PSP, u, ploton=FALSE, lines=FALSE, dercop=TRUE)
     # The red line is the true.
     plot(S$t, S$seccop, lwd=2, col=2, lty=2, type="l", xlim=c(0,1), ylim=c(0,1),
          xlab="V, NONEXCEEDANCE PROBABILITY", ylab="V, VALUE")
     lines(the.grid$v, empder[i,], lwd=4, col=5, lty=2) # empirical
     mtext(paste("Conditioned on U=",u," nonexceedance probability"))
  }
dev.off() #
## End(Not run)

Derivatives of the Grid of the Bivariate Empirical Copula for V with respect to U

Description

Generate derivatives of V with respect to U of a gridded representation of the bivariate empirical copula (see EMPIRcop). This function is the empirical analog to derCOP.

Usage

EMPIRgridder(empgrid=NULL, ...)

Arguments

Value

The gridded values of the derivatives of the bivariate empirical copula.

Author(s)

W.H. Asquith

See Also

EMPIRcop, EMPIRcopdf, EMPIRgrid, EMPIRgridder2

Examples

## Not run: 
para   <- list(alpha=0.15,  beta=0.65, cop1=PLACKETTcop, cop2=PLACKETTcop,
               para1=0.005, para2=1000)
uv <- simCOP(n=1000, cop=composite2COP, para=para)
fakeU <- lmomco::pp(uv[,1], sort=FALSE)
fakeV <- lmomco::pp(uv[,2], sort=FALSE)
uv <- data.frame(U=fakeU, V=fakeV)

"trans3d" <-                         # blackslashes seem needed for the package
function(x,y,z, pmat) {              # for user manual building but bad syntax
  tmat <- cbind(x,y,z,1) %*% pmat    # because remember the percent sign is a
  return(tmat[,1:2] / tmat[,4])      # a comment character in LaTeX.
}

the.grid <- EMPIRgrid(para=uv, deluv=0.1)
the.diag <- diagCOP(cop=EMPIRcop, para=uv, ploton=FALSE, lines=FALSE)
empcop <- EMPIRcopdf(para=uv) # data.frame of all points

the.persp <- persp(the.grid$empcop, theta=-25, phi=20,
                   xlab="U VARIABLE", ylab="V VARIABLE", zlab="COPULA C(u,v)")
points(trans3d(empcop$u, empcop$v, empcop$empcop, the.persp),
       col=rgb(0,1-sqrt(empcop$empcop),1,sqrt(empcop$empcop)), pch=16, cex=0.75)

# Now extract the copula sections
some.lines <- trans3d(rep(0.2, length(the.grid$v)),
                      the.grid$v, the.grid$empcop[3,], the.persp)
lines(some.lines, lwd=2, col=2)
some.lines <- trans3d(the.grid$u, rep(0.6, length(the.grid$u)),
                      the.grid$empcop[,7], the.persp)
lines(some.lines, lwd=2, col=3)
some.lines <- trans3d(rep(0.7, length(the.grid$v)), the.grid$v,
                      the.grid$empcop[8,], the.persp)
lines(some.lines, lwd=2, col=6)

# Now compute some derivatives or conditional cumulative
# distribution functions
empder <- EMPIRgridder(empgrid=the.grid)
some.lines <- trans3d(rep(0.2, length(the.grid$v)), the.grid$v, empder[3,], the.persp)
lines(some.lines, lwd=4, col=2)

empder <- EMPIRgridder2(empgrid=the.grid)
some.lines <- trans3d(the.grid$u, rep(0.6, length(the.grid$u)), empder[,7], the.persp)
lines(some.lines, lwd=4, col=3)

empder <- EMPIRgridder(empgrid=the.grid)
some.lines <- trans3d(rep(0.7, length(the.grid$v)), the.grid$v, empder[8,], the.persp)
lines(some.lines, lwd=4, col=6)

# Demonstrate conditional quantile function extraction for
# the 70th percentile of U and see how it plots on top of
# the thick purple line
empinv <- EMPIRgridderinv(empgrid=the.grid)
some.lines <- trans3d(rep(0.7, length(the.grid$v)), empinv[8,],
                      attributes(empinv)$colnames, the.persp)
lines(some.lines, lwd=4, col=5, lty=2)#
## End(Not run)

Derivatives of the Grid of the Bivariate Empirical Copula for U with respect to V

Description

Generate derivatives of U with respect to V of a gridded representation of the bivariate empirical copula (see EMPIRcop). This function is the empirical analog to derCOP2.

Usage

EMPIRgridder2(empgrid=NULL, ...)

Arguments

Value

The gridded values of the derivatives of the bivariate empirical copula.

Author(s)

W.H. Asquith

See Also

EMPIRcop, EMPIRcopdf, EMPIRgrid, EMPIRgridder

Examples

# See examples under EMPIRgridder

Derivative Inverses of the Grid of the Bivariate Empirical Copula for V with respect to U

Description

Generate a gridded representation of the inverse of the derivatives of the bivariate empirical copula of V with respect to U. This function is the empirical analog to derCOPinv.

Usage

EMPIRgridderinv(empgrid=NULL, kumaraswamy=FALSE, dergrid=NULL, ...)

Arguments

Value

The gridded values of the inverse of the derivative of V with respect U.

Author(s)

W.H. Asquith

See Also

EMPIRcop, EMPIRcopdf, EMPIRgrid, EMPIRgridder2

Examples

## Not run: 
uv <- simCOP(n=10000, cop=PSP, ploton=FALSE, points=FALSE)
fakeU <- lmomco::pp(uv[,1], sort=FALSE)
fakeV <- lmomco::pp(uv[,2], sort=FALSE)
uv <- data.frame(U=fakeU, V=fakeV)

uv.grid <- EMPIRgrid(para=uv, deluv=.1) # CPU hungry
uv.inv1 <- EMPIRgridderinv(empgrid=uv.grid)
uv.inv2 <- EMPIRgridderinv2(empgrid=uv.grid)
plot(uv, pch=16, col=rgb(0,0,0,.1), xlim=c(0,1), ylim=c(0,1),
     xlab="U, NONEXCEEDANCE PROBABILITY", ylab="V, NONEXCEEDANCE PROBABILITY")
lines(qua.regressCOP(f=0.5, cop=PSP), col=2)
lines(qua.regressCOP(f=0.2, cop=PSP), col=2)
lines(qua.regressCOP(f=0.7, cop=PSP), col=2)
lines(qua.regressCOP(f=0.1, cop=PSP), col=2)
lines(qua.regressCOP(f=0.9, cop=PSP), col=2)

med.wrtu <- EMPIRqua.regress(f=0.5, empinv=uv.inv1)
lines(med.wrtu, col=2, lwd=4)
qua.wrtu <- EMPIRqua.regress(f=0.2, empinv=uv.inv1)
lines(qua.wrtu, col=2, lwd=2, lty=2)
qua.wrtu <- EMPIRqua.regress(f=0.7, empinv=uv.inv1)
lines(qua.wrtu, col=2, lwd=2, lty=2)
qua.wrtu <- EMPIRqua.regress(f=0.1, empinv=uv.inv1)
lines(qua.wrtu, col=2, lwd=2, lty=4)
qua.wrtu <- EMPIRqua.regress(f=0.9, empinv=uv.inv1)
lines(qua.wrtu, col=2, lwd=2, lty=4)

lines(qua.regressCOP2(f=0.5, cop=PSP), col=4)
lines(qua.regressCOP2(f=0.2, cop=PSP), col=4)
lines(qua.regressCOP2(f=0.7, cop=PSP), col=4)
lines(qua.regressCOP2(f=0.1, cop=PSP), col=4)
lines(qua.regressCOP2(f=0.9, cop=PSP), col=4)

med.wrtv <- EMPIRqua.regress2(f=0.5, empinv=uv.inv2)
lines(med.wrtv, col=4, lwd=4)
qua.wrtv <- EMPIRqua.regress2(f=0.2, empinv=uv.inv2)
lines(qua.wrtv, col=4, lwd=2, lty=2)
qua.wrtv <- EMPIRqua.regress2(f=0.7, empinv=uv.inv2)
lines(qua.wrtv, col=4, lwd=2, lty=2)
qua.wrtv <- EMPIRqua.regress2(f=0.1, empinv=uv.inv2)
lines(qua.wrtv, col=4, lwd=2, lty=4)
qua.wrtv <- EMPIRqua.regress2(f=0.9, empinv=uv.inv2)
lines(qua.wrtv, col=4, lwd=2, lty=4)#
## End(Not run)

## Not run: 
# Now try a much more complex shape
para   <- list(alpha=0.15,  beta=0.65, cop1=PLACKETTcop, cop2=PLACKETTcop,
               para1=0.005, para2=1000)
uv <- simCOP(n=30000, cop=composite2COP, para=para)
fakeU <- lmomco::pp(uv[,1], sort=FALSE)
fakeV <- lmomco::pp(uv[,2], sort=FALSE)
uv <- data.frame(U=fakeU, V=fakeV)

uv.grid <- EMPIRgrid(para=uv, deluv=0.05) # CPU hungry
uv.inv1 <- EMPIRgridderinv(empgrid=uv.grid)
uv.inv2 <- EMPIRgridderinv2(empgrid=uv.grid)
plot(uv, pch=16, col=rgb(0,0,0,0.1), xlim=c(0,1), ylim=c(0,1),
     xlab="U, NONEXCEEDANCE PROBABILITY", ylab="V, NONEXCEEDANCE PROBABILITY")
lines(qua.regressCOP(f=0.5, cop=composite2COP, para=para), col=2)
lines(qua.regressCOP(f=0.2, cop=composite2COP, para=para), col=2)
lines(qua.regressCOP(f=0.7, cop=composite2COP, para=para), col=2)
lines(qua.regressCOP(f=0.1, cop=composite2COP, para=para), col=2)
lines(qua.regressCOP(f=0.9, cop=composite2COP, para=para), col=2)

med.wrtu <- EMPIRqua.regress(f=0.5, empinv=uv.inv1)
lines(med.wrtu, col=2, lwd=4)
qua.wrtu <- EMPIRqua.regress(f=0.2, empinv=uv.inv1)
lines(qua.wrtu, col=2, lwd=2, lty=2)
qua.wrtu <- EMPIRqua.regress(f=0.7, empinv=uv.inv1)
lines(qua.wrtu, col=2, lwd=2, lty=2)
qua.wrtu <- EMPIRqua.regress(f=0.1, empinv=uv.inv1)
lines(qua.wrtu, col=2, lwd=2, lty=4)
qua.wrtu <- EMPIRqua.regress(f=0.9, empinv=uv.inv1)
lines(qua.wrtu, col=2, lwd=2, lty=4)

lines(qua.regressCOP2(f=0.5, cop=composite2COP, para=para), col=4)
lines(qua.regressCOP2(f=0.2, cop=composite2COP, para=para), col=4)
lines(qua.regressCOP2(f=0.7, cop=composite2COP, para=para), col=4)
lines(qua.regressCOP2(f=0.1, cop=composite2COP, para=para), col=4)
lines(qua.regressCOP2(f=0.9, cop=composite2COP, para=para), col=4)

med.wrtv <- EMPIRqua.regress2(f=0.5, empinv=uv.inv2)
lines(med.wrtv, col=4, lwd=4)
qua.wrtv <- EMPIRqua.regress2(f=0.2, empinv=uv.inv2)
lines(qua.wrtv, col=4, lwd=2, lty=2)
qua.wrtv <- EMPIRqua.regress2(f=0.7, empinv=uv.inv2)
lines(qua.wrtv, col=4, lwd=2, lty=2)
qua.wrtv <- EMPIRqua.regress2(f=0.1, empinv=uv.inv2)
lines(qua.wrtv, col=4, lwd=2, lty=4)
qua.wrtv <- EMPIRqua.regress2(f=0.9, empinv=uv.inv2)
lines(qua.wrtv, col=4, lwd=2, lty=4)#
## End(Not run)

Derivative Inverses of the Grid of the Bivariate Empirical Copula for U with respect to V

Description

Generate a gridded representation of the inverse of the derivatives of the bivariate empirical copula of U with respect to V. This function is the empirical analog to derCOPinv2.

Usage

EMPIRgridderinv2(empgrid=NULL, kumaraswamy=FALSE, dergrid=NULL, ...)

Arguments

Value

The gridded values of the inverse of the derivative of U with respect to V.

Author(s)

W.H. Asquith

See Also

EMPIRcop, EMPIRcopdf, EMPIRgrid, EMPIRgridder2, EMPIRgridderinv, EMPIRgridderinv2

Examples

# See examples under EMPIRgridderinv

Median Regression of the Grid of the Bivariate Empirical Copula for V with respect to U

Description

Perform median regression from the gridded inversion of the bivariate empirical copula of V with respect to U.

Usage

EMPIRmed.regress(...)

Arguments

Value

The gridded values of the median regression of V with respect to U.

Author(s)

W.H. Asquith

See Also

EMPIRgridderinv, EMPIRqua.regress, EMPIRmed.regress2, EMPIRmed.regress2

Examples

# See examples under EMPIRqua.regress

Median Regression of the Grid of the Bivariate Empirical Copula for U with respect to V

Description

Perform median regression from the gridded inversion of the bivariate empirical copula of U with respect to V.

Usage

EMPIRmed.regress2(...)

Arguments

Value

The gridded values of the median regression of U with respect to V.

Author(s)

W.H. Asquith

See Also

EMPIRgridderinv2, EMPIRqua.regress, EMPIRmed.regress, EMPIRmed.regress2

Examples

# See examples under EMPIRqua.regress

Quantile Regression of the Grid of the Bivariate Empirical Copula for V with respect to U

Description

Perform quantile regression from the gridded inversion of the bivariate empirical copula of V with respect to U.

Usage

EMPIRqua.regress(f=0.5, u=seq(0.01,0.99, by=0.01), empinv=NULL,
                 lowess=FALSE, f.lowess=1/5, ...)

Arguments

Value

The gridded values of the quantile regression of V with respect to U.

Author(s)

W.H. Asquith

See Also

EMPIRgridderinv, EMPIRqua.regress2, EMPIRmed.regress, EMPIRmed.regress2

Examples

## Not run:  # EXAMPLE 1
theta <- 25
uv <- simCOP(n=1000, cop=PLACKETTcop, para=theta, ploton=FALSE, points=FALSE)
fakeU <- lmomco::pp(uv[,1], sort=FALSE)
fakeV <- lmomco::pp(uv[,2], sort=FALSE)
uv <- data.frame(U=fakeU, V=fakeV)

uv.grid <- EMPIRgrid(para=uv, deluv=0.05) # CPU hungry
uv.inv1 <- EMPIRgridderinv(empgrid=uv.grid)
plot(uv, pch=16, col=rgb(0,0,0,.1), xlim=c(0,1), ylim=c(0,1),
     xlab="U, NONEXCEEDANCE PROBABILITY", ylab="V, NONEXCEEDANCE PROBABILITY")
lines(qua.regressCOP(f=0.5, cop=PLACKETTcop, para=theta), lwd=2)
lines(qua.regressCOP(f=0.2, cop=PLACKETTcop, para=theta), lwd=2)
lines(qua.regressCOP(f=0.7, cop=PLACKETTcop, para=theta), lwd=2)
lines(qua.regressCOP(f=0.1, cop=PLACKETTcop, para=theta), lwd=2)
lines(qua.regressCOP(f=0.9, cop=PLACKETTcop, para=theta), lwd=2)

med.wrtu <- EMPIRqua.regress(f=0.5, empinv=uv.inv1, lowess=TRUE, f.lowess=0.1)
lines(med.wrtu, col=2, lwd=4)
qua.wrtu <- EMPIRqua.regress(f=0.2, empinv=uv.inv1, lowess=TRUE, f.lowess=0.1)
lines(qua.wrtu, col=2, lwd=2, lty=2)
qua.wrtu <- EMPIRqua.regress(f=0.7, empinv=uv.inv1, lowess=TRUE, f.lowess=0.1)
lines(qua.wrtu, col=2, lwd=2, lty=2)
qua.wrtu <- EMPIRqua.regress(f=0.1, empinv=uv.inv1, lowess=TRUE, f.lowess=0.1)
lines(qua.wrtu, col=2, lwd=2, lty=4)
qua.wrtu <- EMPIRqua.regress(f=0.9, empinv=uv.inv1, lowess=TRUE, f.lowess=0.1)
lines(qua.wrtu, col=2, lwd=2, lty=4)

library(quantreg) # Quantile Regression by quantreg
U <- seq(0.01, 0.99, by=0.01)
rqlm <- rq(V~U, data=uv, tau=0.1)
rq.1 <- rqlm$coefficients[1] + rqlm$coefficients[2]*U
rqlm <- rq(V~U, data=uv, tau=0.2)
rq.2 <- rqlm$coefficients[1] + rqlm$coefficients[2]*U
rqlm <- rq(V~U, data=uv, tau=0.5)
rq.5 <- rqlm$coefficients[1] + rqlm$coefficients[2]*U
rqlm <- rq(V~U, data=uv, tau=0.7)
rq.7 <- rqlm$coefficients[1] + rqlm$coefficients[2]*U
rqlm <- rq(V~U, data=uv, tau=0.9)
rq.9 <- rqlm$coefficients[1] + rqlm$coefficients[2]*U

lines(U, rq.1, col=4, lwd=2, lty=4)
lines(U, rq.2, col=4, lwd=2, lty=2)
lines(U, rq.5, col=4, lwd=4)
lines(U, rq.7, col=4, lwd=2, lty=2)
lines(U, rq.9, col=4, lwd=2, lty=4)#
## End(Not run)

## Not run:  # EXAMPLE 2
# Start again with the PSP copula
uv <- simCOP(n=10000, cop=PSP, ploton=FALSE, points=FALSE)
fakeU <- lmomco::pp(uv[,1], sort=FALSE)
fakeV <- lmomco::pp(uv[,2], sort=FALSE)
uv <- data.frame(U=fakeU, V=fakeV)

uv.grid <- EMPIRgrid(para=uv, deluv=0.05) # CPU hungry
uv.inv1 <- EMPIRgridderinv(empgrid=uv.grid)
plot(uv, pch=16, col=rgb(0,0,0,0.1), xlim=c(0,1), ylim=c(0,1),
     xlab="U, NONEXCEEDANCE PROBABILITY", ylab="V, NONEXCEEDANCE PROBABILITY")
lines(qua.regressCOP(f=0.5, cop=PSP), lwd=2)
lines(qua.regressCOP(f=0.2, cop=PSP), lwd=2)
lines(qua.regressCOP(f=0.7, cop=PSP), lwd=2)
lines(qua.regressCOP(f=0.1, cop=PSP), lwd=2)
lines(qua.regressCOP(f=0.9, cop=PSP), lwd=2)

med.wrtu <- EMPIRqua.regress(f=0.5, empinv=uv.inv1, lowess=TRUE, f.lowess=0.1)
lines(med.wrtu, col=2, lwd=4)
qua.wrtu <- EMPIRqua.regress(f=0.2, empinv=uv.inv1, lowess=TRUE, f.lowess=0.1)
lines(qua.wrtu, col=2, lwd=2, lty=2)
qua.wrtu <- EMPIRqua.regress(f=0.7, empinv=uv.inv1, lowess=TRUE, f.lowess=0.1)
lines(qua.wrtu, col=2, lwd=2, lty=2)
qua.wrtu <- EMPIRqua.regress(f=0.1, empinv=uv.inv1, lowess=TRUE, f.lowess=0.1)
lines(qua.wrtu, col=2, lwd=2, lty=4)
qua.wrtu <- EMPIRqua.regress(f=0.9, empinv=uv.inv1, lowess=TRUE, f.lowess=0.1)
lines(qua.wrtu, col=2, lwd=2, lty=4)

library(quantreg) # Quantile Regression by quantreg
U <- seq(0.01, 0.99, by=0.01)
rqlm <- rq(V~U, data=uv, tau=0.1)
rq.1 <- rqlm$coefficients[1] + rqlm$coefficients[2]*U
rqlm <- rq(V~U, data=uv, tau=0.2)
rq.2 <- rqlm$coefficients[1] + rqlm$coefficients[2]*U
rqlm <- rq(V~U, data=uv, tau=0.5)
rq.5 <- rqlm$coefficients[1] + rqlm$coefficients[2]*U
rqlm <- rq(V~U, data=uv, tau=0.7)
rq.7 <- rqlm$coefficients[1] + rqlm$coefficients[2]*U
rqlm <- rq(V~U, data=uv, tau=0.9)
rq.9 <- rqlm$coefficients[1] + rqlm$coefficients[2]*U

lines(U, rq.1, col=4, lwd=2, lty=4)
lines(U, rq.2, col=4, lwd=2, lty=2)
lines(U, rq.5, col=4, lwd=4)
lines(U, rq.7, col=4, lwd=2, lty=2)
lines(U, rq.9, col=4, lwd=2, lty=4)#
## End(Not run)

## Not run:  # EXAMPLE 3
uv <- simCOP(n=10000, cop=PSP, ploton=FALSE, points=FALSE)
fakeU <- lmomco::pp(uv[,1], sort=FALSE)
fakeV <- lmomco::pp(uv[,2], sort=FALSE)
uv <- data.frame(U=fakeU, V=fakeV)

uv.grid <- EMPIRgrid(para=uv, deluv=0.1) # CPU hungry
uv.inv1 <- EMPIRgridderinv(empgrid=uv.grid)
uv.inv2 <- EMPIRgridderinv2(empgrid=uv.grid)
plot(uv, pch=16, col=rgb(0,0,0,.1), xlim=c(0,1), ylim=c(0,1),
     xlab="U, NONEXCEEDANCE PROBABILITY", ylab="V, NONEXCEEDANCE PROBABILITY")
lines(qua.regressCOP(f=0.5, cop=PSP), col=2)
lines(qua.regressCOP(f=0.2, cop=PSP), col=2)
lines(qua.regressCOP(f=0.7, cop=PSP), col=2)
lines(qua.regressCOP(f=0.1, cop=PSP), col=2)
lines(qua.regressCOP(f=0.9, cop=PSP), col=2)

med.wrtu <- EMPIRqua.regress(f=0.5, empinv=uv.inv1)
lines(med.wrtu, col=2, lwd=4)
qua.wrtu <- EMPIRqua.regress(f=0.2, empinv=uv.inv1)
lines(qua.wrtu, col=2, lwd=2, lty=2)
qua.wrtu <- EMPIRqua.regress(f=0.7, empinv=uv.inv1)
lines(qua.wrtu, col=2, lwd=2, lty=2)
qua.wrtu <- EMPIRqua.regress(f=0.1, empinv=uv.inv1)
lines(qua.wrtu, col=2, lwd=2, lty=4)
qua.wrtu <- EMPIRqua.regress(f=0.9, empinv=uv.inv1)
lines(qua.wrtu, col=2, lwd=2, lty=4)

lines(qua.regressCOP2(f=0.5, cop=PSP), col=4)
lines(qua.regressCOP2(f=0.2, cop=PSP), col=4)
lines(qua.regressCOP2(f=0.7, cop=PSP), col=4)
lines(qua.regressCOP2(f=0.1, cop=PSP), col=4)
lines(qua.regressCOP2(f=0.9, cop=PSP), col=4)

med.wrtv <- EMPIRqua.regress2(f=0.5, empinv=uv.inv2)
lines(med.wrtv, col=4, lwd=4)
qua.wrtv <- EMPIRqua.regress2(f=0.2, empinv=uv.inv2)
lines(qua.wrtv, col=4, lwd=2, lty=2)
qua.wrtv <- EMPIRqua.regress2(f=0.7, empinv=uv.inv2)
lines(qua.wrtv, col=4, lwd=2, lty=2)
qua.wrtv <- EMPIRqua.regress2(f=0.1, empinv=uv.inv2)
lines(qua.wrtv, col=4, lwd=2, lty=4)
qua.wrtv <- EMPIRqua.regress2(f=0.9, empinv=uv.inv2)
lines(qua.wrtv, col=4, lwd=2, lty=4)#
## End(Not run)

## Not run:  # EXAMPLE 4
# Now try a much more complex shape
# lowess smoothing on quantile regression is possible,
# see next example
para   <- list(alpha=0.15,  beta=0.65,
               cop1=PLACKETTcop, cop2=PLACKETTcop, para1=0.005, para2=1000)
uv <- simCOP(n=20000, cop=composite2COP, para=para)
fakeU <- lmomco::pp(uv[,1], sort=FALSE)
fakeV <- lmomco::pp(uv[,2], sort=FALSE)
uv <- data.frame(U=fakeU, V=fakeV)

uv.grid <- EMPIRgrid(para=uv, deluv=0.025) # CPU hungry
uv.inv1 <- EMPIRgridderinv(empgrid=uv.grid)
uv.inv2 <- EMPIRgridderinv2(empgrid=uv.grid)
plot(uv, pch=16, col=rgb(0,0,0,0.1), xlim=c(0,1), ylim=c(0,1),
     xlab="U, NONEXCEEDANCE PROBABILITY", ylab="V, NONEXCEEDANCE PROBABILTIY")
lines(qua.regressCOP(f=0.5, cop=composite2COP, para=para), col=2)
lines(qua.regressCOP(f=0.2, cop=composite2COP, para=para), col=2)
lines(qua.regressCOP(f=0.7, cop=composite2COP, para=para), col=2)
lines(qua.regressCOP(f=0.1, cop=composite2COP, para=para), col=2)
lines(qua.regressCOP(f=0.9, cop=composite2COP, para=para), col=2)

med.wrtu <- EMPIRqua.regress(f=0.5, empinv=uv.inv1)
lines(med.wrtu, col=2, lwd=4)
qua.wrtu <- EMPIRqua.regress(f=0.2, empinv=uv.inv1)
lines(qua.wrtu, col=2, lwd=2, lty=2)
qua.wrtu <- EMPIRqua.regress(f=0.7, empinv=uv.inv1)
lines(qua.wrtu, col=2, lwd=2, lty=2)
qua.wrtu <- EMPIRqua.regress(f=0.1, empinv=uv.inv1)
lines(qua.wrtu, col=2, lwd=2, lty=4)
qua.wrtu <- EMPIRqua.regress(f=0.9, empinv=uv.inv1)
lines(qua.wrtu, col=2, lwd=2, lty=4)

lines(qua.regressCOP2(f=0.5, cop=composite2COP, para=para), col=4)
lines(qua.regressCOP2(f=0.2, cop=composite2COP, para=para), col=4)
lines(qua.regressCOP2(f=0.7, cop=composite2COP, para=para), col=4)
lines(qua.regressCOP2(f=0.1, cop=composite2COP, para=para), col=4)
lines(qua.regressCOP2(f=0.9, cop=composite2COP, para=para), col=4)

med.wrtv <- EMPIRqua.regress2(f=0.5, empinv=uv.inv2)
lines(med.wrtv, col=4, lwd=4)
qua.wrtv <- EMPIRqua.regress2(f=0.2, empinv=uv.inv2)
lines(qua.wrtv, col=4, lwd=2, lty=2)
qua.wrtv <- EMPIRqua.regress2(f=0.7, empinv=uv.inv2)
lines(qua.wrtv, col=4, lwd=2, lty=2)
qua.wrtv <- EMPIRqua.regress2(f=0.1, empinv=uv.inv2)
lines(qua.wrtv, col=4, lwd=2, lty=4)
qua.wrtv <- EMPIRqua.regress2(f=0.9, empinv=uv.inv2)
lines(qua.wrtv, col=4, lwd=2, lty=4)#
## End(Not run)

## Not run:  # EXAMPLE 5
plot(uv, pch=16, col=rgb(0,0,0,.1), xlim=c(0,1), ylim=c(0,1),
     xlab="U, NONEXCEEDANCE PROBABILITY", ylab="V, NONEXCEEDANCE PROBABILITY")
lines(qua.regressCOP(f=0.5, cop=composite2COP, para=para), col=2)
lines(qua.regressCOP(f=0.2, cop=composite2COP, para=para), col=2)
lines(qua.regressCOP(f=0.7, cop=composite2COP, para=para), col=2)
lines(qua.regressCOP(f=0.1, cop=composite2COP, para=para), col=2)
lines(qua.regressCOP(f=0.9, cop=composite2COP, para=para), col=2)

med.wrtu <- EMPIRqua.regress(f=0.5, empinv=uv.inv1, lowess=TRUE)
lines(med.wrtu, col=2, lwd=4)
qua.wrtu <- EMPIRqua.regress(f=0.2, empinv=uv.inv1, lowess=TRUE)
lines(qua.wrtu, col=2, lwd=2, lty=2)
qua.wrtu <- EMPIRqua.regress(f=0.7, empinv=uv.inv1, lowess=TRUE)
lines(qua.wrtu, col=2, lwd=2, lty=2)
qua.wrtu <- EMPIRqua.regress(f=0.1, empinv=uv.inv1, lowess=TRUE)
lines(qua.wrtu, col=2, lwd=2, lty=4)
qua.wrtu <- EMPIRqua.regress(f=0.9, empinv=uv.inv1, lowess=TRUE)
lines(qua.wrtu, col=2, lwd=2, lty=4)

lines(qua.regressCOP2(f=0.5, cop=composite2COP, para=para), col=4)
lines(qua.regressCOP2(f=0.2, cop=composite2COP, para=para), col=4)
lines(qua.regressCOP2(f=0.7, cop=composite2COP, para=para), col=4)
lines(qua.regressCOP2(f=0.1, cop=composite2COP, para=para), col=4)
lines(qua.regressCOP2(f=0.9, cop=composite2COP, para=para), col=4)

med.wrtv <- EMPIRqua.regress2(f=0.5, empinv=uv.inv2, lowess=TRUE)
lines(med.wrtv, col=4, lwd=4)
qua.wrtv <- EMPIRqua.regress2(f=0.2, empinv=uv.inv2, lowess=TRUE)
lines(qua.wrtv, col=4, lwd=2, lty=2)
qua.wrtv <- EMPIRqua.regress2(f=0.7, empinv=uv.inv2, lowess=TRUE)
lines(qua.wrtv, col=4, lwd=2, lty=2)
qua.wrtv <- EMPIRqua.regress2(f=0.1, empinv=uv.inv2, lowess=TRUE)
lines(qua.wrtv, col=4, lwd=2, lty=4)
qua.wrtv <- EMPIRqua.regress2(f=0.9, empinv=uv.inv2, lowess=TRUE)
lines(qua.wrtv, col=4, lwd=2, lty=4)#
## End(Not run)

## Not run:  # EXAMPLE 6 (changing the smoothing on the lowess)
plot(uv, pch=16, col=rgb(0,0,0,0.1), xlim=c(0,1), ylim=c(0,1),
     xlab="U, NONEXCEEDANCE PROBABILITY", ylab="V, NONEXCEEDANCE PROBABILTIY")
lines(qua.regressCOP(f=0.5, cop=composite2COP, para=para), col=2)
lines(qua.regressCOP(f=0.2, cop=composite2COP, para=para), col=2)
lines(qua.regressCOP(f=0.7, cop=composite2COP, para=para), col=2)
lines(qua.regressCOP(f=0.1, cop=composite2COP, para=para), col=2)
lines(qua.regressCOP(f=0.9, cop=composite2COP, para=para), col=2)

med.wrtu <- EMPIRqua.regress(f=0.5, empinv=uv.inv1, lowess=TRUE, f.lowess=0.1)
lines(med.wrtu, col=2, lwd=4)
qua.wrtu <- EMPIRqua.regress(f=0.2, empinv=uv.inv1, lowess=TRUE, f.lowess=0.1)
lines(qua.wrtu, col=2, lwd=2, lty=2)
qua.wrtu <- EMPIRqua.regress(f=0.7, empinv=uv.inv1, lowess=TRUE, f.lowess=0.1)
lines(qua.wrtu, col=2, lwd=2, lty=2)
qua.wrtu <- EMPIRqua.regress(f=0.1, empinv=uv.inv1, lowess=TRUE, f.lowess=0.1)
lines(qua.wrtu, col=2, lwd=2, lty=4)
qua.wrtu <- EMPIRqua.regress(f=0.9, empinv=uv.inv1, lowess=TRUE, f.lowess=0.1)
lines(qua.wrtu, col=2, lwd=2, lty=4)

lines(qua.regressCOP2(f=0.5, cop=composite2COP, para=para), col=4)
lines(qua.regressCOP2(f=0.2, cop=composite2COP, para=para), col=4)
lines(qua.regressCOP2(f=0.7, cop=composite2COP, para=para), col=4)
lines(qua.regressCOP2(f=0.1, cop=composite2COP, para=para), col=4)
lines(qua.regressCOP2(f=0.9, cop=composite2COP, para=para), col=4)

med.wrtv <- EMPIRqua.regress2(f=0.5, empinv=uv.inv2, lowess=TRUE, f.lowess=0.1)
lines(med.wrtv, col=4, lwd=4)
qua.wrtv <- EMPIRqua.regress2(f=0.2, empinv=uv.inv2, lowess=TRUE, f.lowess=0.1)
lines(qua.wrtv, col=4, lwd=2, lty=2)
qua.wrtv <- EMPIRqua.regress2(f=0.7, empinv=uv.inv2, lowess=TRUE, f.lowess=0.1)
lines(qua.wrtv, col=4, lwd=2, lty=2)
qua.wrtv <- EMPIRqua.regress2(f=0.1, empinv=uv.inv2, lowess=TRUE, f.lowess=0.1)
lines(qua.wrtv, col=4, lwd=2, lty=4)
qua.wrtv <- EMPIRqua.regress2(f=0.9, empinv=uv.inv2, lowess=TRUE, f.lowess=0.1)
lines(qua.wrtv, col=4, lwd=2, lty=4)#
## End(Not run)

Quantile Regression of the Grid of the Bivariate Empirical Copula for U with respect to V

Description

Generate quantile regression from the gridded inversion of the bivariate empirical copula of U with respect to V.

Usage

EMPIRqua.regress2(f=0.5, v=seq(0.01,0.99, by=0.01), empinv=NULL,
                  lowess=FALSE, f.lowess=1/5, ...)

Arguments

Value

The gridded values of the quantile regression of U with respect to V.

Author(s)

W.H. Asquith

See Also

EMPIRgridderinv2, EMPIRqua.regress, EMPIRmed.regress, EMPIRmed.regress2

Examples

# See examples under EMPIRqua.regress

Simulate a Bivariate Empirical Copula

Description

EXPERIMENTAL—Perform a simulation on a bivariate empirical copula to produce the random variates U and V and return an R data.frame of them. The method is more broadly known as conditional simulation method. This function is an empirical parallel to simCOP that is used for parametric copulas. If circumstances require conditional simulation of V{\mid}U, then function EMPIRsimv, which produces a vector of V from a fixed u, should be used.

For the usual situation in which an individual u during the simulation loops is not a value aligned on the grid, then the bounding conditional quantile functions are solved for each of the n simulations and the following interpolation is made by

v = \frac{v_1/w_1 + v_2/w_2}{1/w_1 + 1/w_2}\mbox{,}

which states that that the weighted mean is computed. The values v_1 and v_2 are ordinates of the conditional quantile function for the respective grid lines to the left and right of the u value. The values w_1 = u - u^\mathrm{left}_\mathrm{grid} and w_2 = u^\mathrm{right}_\mathrm{grid} - u.

Usage

EMPIRsim(n=100, empgrid=NULL, kumaraswamy=FALSE, na.rm=TRUE, keept=FALSE,
                graphics=TRUE, ploton=TRUE, points=TRUE, snv=FALSE,
                infsnv.rm=TRUE, trapinfsnv=.Machine$double.eps, ...)

Arguments

Value

An R data.frame of the simulated values is returned.

Author(s)

W.H. Asquith

See Also

EMPIRgrid, EMPIRgridderinv, EMPIRsimv

Examples

# See other examples under EMPIRsimv

## Not run: 
pdf("EMPIRsim_experiment.pdf")
  nsim <- 5000
  para <- list(alpha=0.15, beta=0.65,
               cop1=PLACKETTcop, cop2=PLACKETTcop, para1=0.005, para2=1000)
  set.seed(1)
  uv <- simCOP(n=nsim, cop=composite2COP, para=para, snv=TRUE,
               pch=16, col=rgb(0,0,0,.2))
  mtext("A highly complex simulated bivariate relation")
  # set.seed(1) # try not resetting the seed
  uv.grid <- EMPIRgrid(para=uv, deluv=0.025)

  uv2 <- EMPIRsim(n=nsim, empgrid=uv.grid, kumaraswamy=FALSE, snv=TRUE,
                  col=rgb(1,0,0,0.1), pch=16)
  mtext("Resimulation without Kumaraswamy smoothing")

  uv3 <- EMPIRsim(n=nsim, empgrid=uv.grid, kumaraswamy=TRUE, snv=TRUE,
                  col=rgb(1,0,0,0.1),pch=16)
  mtext("Resimulation but using the Kumaraswamy Distribution for smoothing")
dev.off()#
## End(Not run)

Simulate a Bivariate Empirical Copula For a Fixed Value of U

Description

EXPERIMENTAL—Perform a simulation on a bivariate empirical copula to extract the random variates V from a given and fixed value for u= constant. The purpose of this function is to return a simple vector of the V simulations. This behavior is similar to simCOPmicro but differs from the general 2-D simulation implemented in the other functions: EMPIRsim and simCOP—these two functions generate R data.frames of simulated random variates U and V and optional graphics as well.

For the usual situation in which u is not a value aligned on the grid, then the bounding conditional quantile functions are solved for each of the n simulations and the following interpolation is made by

v = \frac{v_1/w_1 + v_2/w_2}{1/w_1 + 1/w_2}\mbox{,}

which states that that the weighted mean is computed. The values v_1 and v_2 are ordinates of the conditional quantile function for the respective grid lines to the left and right of the u value. The values w_1 = u - u^\mathrm{left}_\mathrm{grid} and w_2 = u^\mathrm{right}_\mathrm{grid} - u.

Usage

EMPIRsimv(u, n=1, empgrid=NULL, kumaraswamy=FALSE, ...)

Arguments

Value

A vector of simulated V values is returned.

Author(s)

W.H. Asquith

See Also

EMPIRgrid, EMPIRsim

Examples

## Not run: 
nsim <- 3000
para <- list(alpha=0.15,  beta=0.65,
             cop1=PLACKETTcop, cop2=PLACKETTcop, para1=.005, para2=1000)
set.seed(10)
uv <- simCOP(n=nsim, cop=composite2COP, para=para, pch=16, col=rgb(0,0,0,0.2))
uv.grid <- EMPIRgrid(para=uv, deluv=.1)
set.seed(1)
V1 <- EMPIRsimv(u=0.6, n=nsim, empgrid=uv.grid)
set.seed(1)
V2 <- EMPIRsimv(u=0.6, n=nsim, empgrid=uv.grid, kumaraswamy=TRUE)
plot(V1,V2)
abline(0,1)

invgrid1 <- EMPIRgridderinv(empgrid=uv.grid)
invgrid2 <- EMPIRgridderinv(empgrid=uv.grid, kumaraswamy=TRUE)
att <- attributes(invgrid2); kur <- att$kumaraswamy
# Now draw random variates from the Kumaraswamy distribution using
# rlmomco() and vec2par() provided by the lmomco package.
set.seed(1)
kurpar <- lmomco::vec2par(c(kur$Alpha[7], kur$Beta[7]), type="kur")
Vsim <- lmomco::rlmomco(nsim, kurpar)

print(summary(V1))   # Kumaraswamy not core in QDF reconstruction
print(summary(V2))   # Kumaraswamy core in QDF reconstruction
print(summary(Vsim)) # Kumaraswamy use of the kumaraswamy

# Continuing with a conditional quantile 0.74 that will not land along one of the
# grid lines, a weighted interpolation will be done.
set.seed(1) # try not resetting the seed
nsim <- 5000
V <- EMPIRsimv(u=0.74, n=nsim, empgrid=uv.grid)
# It is important that the uv.grid used to make V is the same grid used in inversion
# with kumaraswamy=TRUE to guarantee that the correct Kumaraswamy parameters are
# available if a user is doing cut and paste and exploring these examples.
set.seed(1)
V1 <- lmomco::rlmomco(nsim, lmomco::vec2par(c(kur$Alpha[8], kur$Beta[8]), type="kur"))
set.seed(1)
V2 <- lmomco::rlmomco(nsim, lmomco::vec2par(c(kur$Alpha[9], kur$Beta[9]), type="kur"))

plot( lmomco::pp(V),  sort(V), type="l", lwd=4, col=8) # GREY is empirical from grid
lines(lmomco::pp(V1), sort(V1), col=2, lwd=2) # Kumaraswamy at u=0.7 # RED
lines(lmomco::pp(V2), sort(V2), col=3, lwd=2) # Kumaraswamy at u=0.8 # GREEN

W1 <- 0.74 - 0.7; W2 <- 0.8 - 0.74
Vblend <- (V1/W1 + V2/W2) / sum(1/W1 + 1/W2)
lines(lmomco::pp(Vblend), sort(Vblend), col=4, lwd=2) # BLUE LINE
# Notice how the grey line and the blue diverge for about F < 0.1 and F > 0.9.
# These are the limits of the grid spacing and linear interpolation within the
# grid intervals is being used and not direct simulation from the Kumaraswamy.
## End(Not run)

Expected value of U given V

Description

Compute the expected value of U given a V (the Y direction) through the conditional distribution function G(Y) using the appropriate partial derivative of a copula (\mathbf{C}(u,v)) with respect to V. The inversion of the partial derivative is the conditional quantile function. Basic principles provide the expectation for a y \ge 0 is

E[Y] = \int_0^\infty yf(y)\mathrm{d}y = \int_0^\infty \bigl(1-G_y(Y)\bigr)\mathrm{d}y\mbox{,}

which for the setting here becomes

E[U \mid V = v] = \int_0^1 \bigl(1 - \frac{\delta}{\delta v} \mathbf{C}(u,v)\bigr)\mathrm{d}u\mbox{.}

This function solves the integral using the derCOP2 function. This avoids a call of the derCOPinv2 through its uniroot() inversion of the derivative. The example shown for EuvCOP() below does a validation check using conditional simulation, which is dependence (of course) of the design of the copBasic package, as part of simple isolation of a horizontal slice of the simulation and computing the mean of the V within the slice.

Usage

EuvCOP(v=seq(0.01, 0.99, by=0.01), cop=NULL, para=NULL, asuv=FALSE, nsim=1E5,
    subdivisions=100L, rel.tol=.Machine$double.eps^0.25, abs.tol=rel.tol, ...)

Arguments

Value

Value(s) for the expectation are returned.

Note

The author is well aware that the name of this function does not contain the number 2 as the family of functions also sharing this with respect to v nature. It was a design mistake in 2008 to have used the 2. The uv in the function name is the moniker for this with respect to v.

There can be the rare examples of the numerical integration failing. In such circumstances, Monte Carlo integration is performed and the returned vector becomes a named vector with the sim identifying values stemming from the simulation.

  para <- list(cop=RFcop, para=0.9)
  para <- list(cop=COP, para=para, reflect=1, alpha=0, beta=0.3)
  EuvCOP(c(0.0001, 0.0002, 0.001, 0.01, 0.1), cop=composite1COP, para=para)
  #            sim
  #[1] 0.001319395 0.002238238 0.006905300 0.034608078 0.173451788

Author(s)

W.H. Asquith

See Also

EvuCOP, derCOP2

Examples

# We can show algorithmic validation using a highly asymmetric case of a
# copula having its parameter also nearly generating a singular component.
v <- c(0.2, 0.8); n <- 5E2; set.seed(1)
para <- list(cop=HRcop, para=120, alpha=0.4, beta=0.05)
UV   <- simCOP(n, cop=composite1COP, para=para, graphics=FALSE) # set TRUE to view

sapply(v, function(vv) EuvCOP(vv, cop=composite1COP, para=para))
# [1] 0.3051985 0.7059999

sapply(v, function(vv) mean( UV$U[UV$V > vv - 50/n & UV$V < vv + 50/n] ) )
# [1] 0.2796518 0.7092755 # general validation is thus shown as n-->large

# If visualized, we see in the lower corner than heuristics suggest a mean further
# to the right of the "singularity" for v=0.2 than v=0.80. For v=0.80, the
# "singularity" appears tighter given the upper tail dependency contrast of the
# coupla in the symmetrical case (alpha=0, beta=0) and changing the parameter to
# a Spearman Rho (say) similar to the para settting in this example. So, 0.70 for
# the mean given v=0.80 makes sense. Further notice that the two estimates of the
# mean are further apparent for v=0.2 relative to v=0.80. Again, this makes sense
# when the copula is visualized even at small n let alone large n.

# See additional Examples under EvuCOP().

## Not run: 
  set.seed(1)
  n <- 5000; Vlo <- rep(0.001, n); Vhi <- rep(0.95, n); Theta <- 3
  Ulo <- simCOPmicro(Vlo, cop=JOcopB5, para=Theta); dlo <- density(Ulo)
  Uhi <- simCOPmicro(Vhi, cop=JOcopB5, para=Theta); dhi <- density(Uhi)
  dlo$x[dlo$x < 0] <- 0; dhi$x[dhi$x < 0] <- 0
  dlo$x[dlo$x > 1] <- 1; dhi$x[dhi$x > 1] <- 1

  summary(Ulo)
  Ulomu <- EuvCOP(Vlo[1], cop=JOcopB5, para=Theta); print(Ulomu)
  #      Min.   1st Qu.    Median      Mean   3rd Qu.      Max.
  # 0.0000669 0.0887330 0.2006123 0.2504796 0.3802847 0.9589315
  #                  Ulomu -----> 0.2502145
  summary(Uhi)
  Uhimu <- EuvCOP(Vhi[1], cop=JOcopB5, para=Theta); print(Uhimu)
  #      Min.   1st Qu.    Median      Mean   3rd Qu.      Max.
  #   0.01399  0.90603    0.93919 0.9157600   0.95946   0.99411
  #                  Uhimu -----> 0.9154093

  UV <- simCOP(n, cop=JOcopB5, para=Theta,
                  cex=0.6, pch=21, bg="palegreen", col="darkgreen")
  abline(h=Vlo[1], col="salmon", lty=3) # near the bottom to form datum for density
  abline(h=Vhi[1], col="purple", lty=3) # near the   top  to form datum for density
  lines(dlo$x,   dlo$y/max(dlo$y)/2 +    Vlo[1],  col="salmon", lwd=2)
  # re-scaled density along the line already drawn near the bottom (Vlo)
  # think rug plotting to bottom the values plotting very close to the line
  lines(dhi$x, 1-dhi$y/max(dhi$y)/2 - (1-Vhi[1]), col="purple", lwd=2)
  # re-scaled  density along the line already drawn near the  top  (Vhi)
  # think rug plotting to bottom the values plotting very close to the line
  uv <- seq(0.001, 0.999, by=0.001) # for trajectory of E[U | V=v]
  lines(EuvCOP(uv, cop=JOcopB5, para=Theta), uv, col="blue", lwd=3.5, lty=2)
  points(Ulomu, Vlo[1], pch=16, col="salmon", cex=2)
  points(Uhimu, Vhi[1], pch=16, col="purple", cex=2) #
## End(Not run)

Expected value of V given U

Description

Compute the expected value of V given a U (the X direction) through the conditional distribution function F(X) using the appropriate partial derivative of a copula (\mathbf{C}(u,v)) with respect to U. The inversion of the partial derivative is the conditional quantile function. Basic principles provide the expectation for a x \ge 0 is

E[X] = \int_0^\infty xf(x)\mathrm{d}x = \int_0^\infty \bigl(1-F_x(X)\bigr)\mathrm{d}x\mbox{,}

which for the setting here becomes

E[V \mid U = u] = \int_0^1 \bigl(1 - \frac{\delta}{\delta u} \mathbf{C}(u,v)\bigr)\mathrm{d}v\mbox{.}

This function solves the integral using the derCOP function. Verification study is provided in the Note section.

Usage

EvuCOP(u=seq(0.01, 0.99, by=0.01), cop=NULL, para=NULL, asuv=FALSE, nsim=1E5,
    subdivisions=100L, rel.tol=.Machine$double.eps^0.25, abs.tol=rel.tol, ...)

Arguments

Value

Value(s) for the expectation are returned.

Note

For the PSP copula with no parameters, compute the the median and mean V given U=0.4, respectively:

  U <- 0.4; n <- 1E4
  med.regressCOP(u=U, cop=PSP)                            # V = 0.4912752
  set.seed(1)
  median(replicate(n, derCOPinv(cop=PSP, U, runif(1)) ) ) # V = 0.4876440
  mean(  replicate(n, derCOPinv(cop=PSP, U, runif(1)) ) ) # V = 0.5049729

It is seen in the above that the median V given U is very close to the mean, but is not equal. Using the derivative inversion within med.regressCOP the median is about 0.491 and then using large-sample simulation, about 0.491 too is computed. This confirms the median and long standing proven use of derCOP (conditional distribution function) and derCOPinv (conditional quantile function) within the package. The expectation (mean) by simulation provides the anchor point to check implementation of EuvCOP(). The mean for V given U is about 0.505. Continuing, the core logic of EvuCOP() is to use numerical integration of the conditional distribution function (the partial derivative) and not bother for speed purposes to use the inversion of the partial derivative:

  integrate(function(v)                      1-derCOP(   cop=PSP, U, v),
            lower=0, upper=1) # 0.5047805 with absolute error < 1.4e-11

  integrate(function(v) sapply(v, function(t)  derCOPinv(cop=PSP, U, t)),
            lower=0, upper=1) # 0.5047862 with absolute error < 7.2e-05

The two integrals match, which functions as a confirmation of the (1-F) term in the mathematical definition. Finally, the two integrals match the simulation results. The expectation or mean V \mid U=0.4 for the PSP copula is about 0.5048.

Author(s)

W.H. Asquith

See Also

EuvCOP, derCOP

Examples

# Highly asymmetric and reflected Clayton copula for which visualization
para <- list(cop=CLcop, para=30, alpha=0.2, beta=0.6, reflect=3)
# UV <- simCOP(5000, cop=breveCOP, para=para, cex=0.5); abline(v=0.25, col="red")
EvuCOP(0.25, cop=breveCOP, para=para)  # 0.5982261
# confirms that at U=0.25 that an intuitive estimate would be about 0.6.

## Not run: 
  # Secondary validation of the EvuCOP() and EuvCOP() implementation
  UV <- simCOP(200, cop=PSP)
  u <- seq(0.005, 0.995, by=0.005)
  v <- sapply(u, function(t) integrate(function(k)
                         1 - derCOP(cop=PSP, t, k),  lower=0, upper=1)$value)
  lines(u,v, col="red", lwd=7, lty=1)   # red line
  v <- seq(0.005, 0.995, by=0.005)
  u <- sapply(v, function(t) integrate(function(k)
                         1 - derCOP2(cop=PSP, k, t), lower=0, upper=1)$value)
  lines(u,v, col="red", lwd=7, lty=2)   # dashed red line

  uv <- seq(0.005, 0.995, by=0.005)     # solid and dashed white lines
  lines(EvuCOP(uv, cop=PSP, asuv=TRUE), col="white",  lwd=3,   lty=1)
  lines(EuvCOP(uv, cop=PSP, asuv=TRUE), col="white",  lwd=3,   lty=3)

  # median regression lines for comparison, green and green dashed lines
  lines(med.regressCOP( uv, cop=PSP), col="seagreen", lwd=1.5, lty=1)
  lines(med.regressCOP2(uv, cop=PSP), col="seagreen", lwd=1.5, lty=4) #
## End(Not run)

## Not run: 
  uv <- seq(0.005, 0.995, by=0.005) # stress testing eample with singularity
  UV <- simCOP(50, cop=M_N5p12b, para=2)
  lines(EvuCOP(uv, cop=M_N5p12b, para=2, asuv=TRUE), col="red",     lwd=5)
  lines(EuvCOP(uv, cop=M_N5p12b, para=2, asuv=TRUE), col="skyblue", lwd=1) #
## End(Not run)

## Not run: 
  uv <- seq(0.005, 0.995, by=0.005) # more asymmetry ---- mean regression in UV and VU
  para <- list(cop=GHcop, para=23, alpha=0.1, beta=0.6, reflect=3)
  para <- list(cop=breveCOP, para=para)
  UV <- simCOP(200, cop=COP, para=para)
  lines(EuvCOP(uv,  cop=COP, para=para, asuv=TRUE), col="red",  lwd=2)
  lines(EvuCOP(uv,  cop=COP, para=para, asuv=TRUE), col="blue", lwd=2) #
## End(Not run)

## Not run: 
  # Open questions? The derCOP() and derCOPinv() functions of the package have long
  # been known to work "properly." But let us think again on the situation of
  # permutation symmetry about the equal value line. Recalling that this symmetry is
  # orthogonal to the equal value line, it remains open whether there could be
  # asymmetry in the vertical (or horizontal). Let us draw some median regression lines
  # and see that the do not plot perfectly on the equal value line, but coudl this be
  # down to numerical issues and by association the simulation of the copula itself
  # that is also using derCOPinv() (conditional simulation method). Then, we can plot
  # the expections and we see that these are not equal to the medians, but again are
  # close. *** Do results here indicate edges of numerical performance? ***
  t <- seq(0.01, 0.99, by=0.01)
  UV <- simCOP(10000,   cop=N4212cop, para=4, pch=21, lwd=0.8, col=8, bg="white")
  lines(med.regressCOP( cop=N4212cop, para=4, asuv=TRUE), col="red")
  lines(med.regressCOP2(cop=N4212cop, para=4, asuv=TRUE), col="red")
  abline(0, 1, col="deepskyblue", lwd=3); abline(v=0.5, col="deepskyblue", lwd=4)
  lines(EvuCOP(t, cop=N4212cop, para=4, asuv=TRUE), pch=16, col="darkgreen")
  lines(EuvCOP(t, cop=N4212cop, para=4, asuv=TRUE), pch=16, col="darkgreen") #
## End(Not run)

The Generalized Farlie–Gumbel–Morgenstern Copula

Description

The generalized Farlie–Gumbel–Morgenstern copula (Bekrizade et al., 2012) is

\mathbf{C}_{\Theta, \alpha, n}(u,v) = \mathbf{FGM}(u,v) = uv[1 + \Theta(1-u^\alpha)(1-v^\alpha)]^n\mbox{,}

where \Theta \in [-\mathrm{min}\{1, 1/(n\alpha^2)\}, +1/(n\alpha)], \alpha > 0, and n \in 0,1,2,\cdots. The copula \Theta = 0 or \alpha = 0 or n = 0 becomes the independence copula (\mathbf{\Pi}(u,v); P). When \alpha = n = 1, then the well-known, single-parameter Farlie–Gumbel–Morgenstern copula results, and Spearman Rho (rhoCOP) is \rho_\mathbf{C} = \Theta/3 but in general

\rho_\mathbf{C} = 12\sum_{r=1}^n {n \choose r} \Theta^r \biggl[\frac{\phantom{\alpha}\Gamma(r+1)\Gamma(2/\alpha)}{\alpha\Gamma(r+1+2/\alpha)} \biggr]^2 \mbox{.}

The support of \rho_\mathbf{C}(\cdots;\Theta, 1, 1) is [-1/3, +1/3] but extends via \alpha and n to \approx [-0.50, +0.43], which shows that the generalization of the copula increases the range of dependency. The generalized version is implemented by FGMcop.

The iterated Farlie–Gumbel–Morgenstern copula (Chine and Benatia, 2017) for the rth iteration is

\mathbf{C}_{\beta}(u,v) = \mathbf{FGMi}(u,v) = uv + \sum_{j=1}^{r} \beta_j\cdot(uv)^{[j/2]}\cdot(u'v')^{[(j+1)/2]}\mbox{,}

where u' = 1-u and v' = 1-v for |\beta_j| \le 1 that has r dimensions \beta = (\beta_1, \cdots, \beta_j, \cdots, \beta_r) and [t] is the integer part of t. The copula \beta = 0 becomes the independence copula (\mathbf{\Pi}(u,v); P). The support of \rho_\mathbf{C}(\cdots;\beta) is approximately [-0.43, +0.43]. The iterated version is implemented by FGMicop. Internally, the r is determined from the length of the \beta in the para argument.

Usage

FGMcop( u, v, para=c(NA, 1,1), ...)
FGMicop(u, v, para=NULL,       ...)

Arguments

Value

Value(s) for the copula are returned.

Author(s)

W.H. Asquith

References

Bekrizade, Hakim, Parham, G.A., Zadkarmi, M.R., 2012, The new generalization of Farlie–Gumbel–Morgenstern copulas: Applied Mathematical Sciences, v. 6, no. 71, pp. 3527–3533.

Chine, Amel, and Benatia, Fatah, 2017, Bivariate copulas parameters estimation using the trimmed L-moments methods: Afrika Statistika, v. 12, no. 1, pp. 1185–1197.

See Also

P, mleCOP

Examples

## Not run: 
  # Bekrizade et al. (2012, table 1) report for a=2 and n=3 that range in
  # theta = [-0.1667, 0.1667] and range in rho = [-0.1806641, 0.4036458]. However,
  # we see that they have seemingly made an error in listing the lower bounds of theta:
  rhoCOP(FGMcop, para=c(  1/6, 2, 3))  #  0.4036458
  rhoCOP(FGMcop, para=c( -1/6, 2, 3))  # Following error results
  # In cop(u, v, para = para, ...) : parameter Theta < -0.0833333333333333
  rhoCOP(FGMcop, para=c(-1/12, 2, 3))  # -0.1806641 
## End(Not run)

## Not run: 
  # Support of FGMrcop(): first for r=1 iterations and then for large r.
  sapply(c(-1, 1), function(t) rhoCOP(cop=FGMicop, para=rep(t, 1)) )
  # [1] -0.3333333  0.3333333
  sapply(c(-1, 1), function(t) rhoCOP(cop=FGMicop, para=rep(t,50)) )
  # [1] -0.4341385  0.4341385
## End(Not run)

## Not run: 
  # Maximum likelihood estimation near theta upper bounds for a=3 and n=2.
  set.seed(832)
  UV <- simCOP(3000, cop=FGMcop, para=c(+0.16, 3, 2))
  # Define a transform function for parameter domain, though mleCOP does
  # provide some robustness anyway---not forcing n into the positive
  # domain via as.integer(exp(p[3])) seems to not always be needed.
  FGMpfunc <- function(p) {
    d <- p[1]; a <- exp(p[2]); n <- as.integer(exp(p[3]))
    lwr <- -min(c(1,1/(n*a^2))); upr <- 1/(n*a)
    d <- ifelse(d <= lwr, lwr, ifelse(d >= upr, upr, d))
    return( c(d, a, n) )
  }
  para <- c(0.16, 3, 2); init <- c(0, 1, 1)
  ML <- mleCOP(UV$U, UV$V, cop=FGMcop, init.para=init, parafn=FGMpfunc)
  print(ML$para) # [1] 0.1596361 3.1321228 2.0000000
  # So, we have recovered reasonable estimates of the three parameters
  # given through MLE estimation.
  densityCOPplot(cop=FGMcop, para=   para, contour.col="red")
  densityCOPplot(cop=FGMcop, para=ML$para, ploton=FALSE) #
## End(Not run)

The Fréchet Family Copula

Description

The Fréchet Family copula (Durante, 2007, pp. 256–259) is

\mathbf{C}_{\alpha, \beta}(u,v) = \mathbf{FF}(u,v) = \alpha\mathbf{M}(u,v) + (1-\alpha-\beta)\mathbf{\Pi}(u,v)+\beta\mathbf{W}(u,v)\mbox{,}

where \alpha, \beta \ge 0 and \alpha + \beta \le 1. The Fréchet Family copulas are convex combinations of the fundamental copulas \mathbf{W} (Fréchet–Hoeffding lower-bound copula; W), \mathbf{\Pi} (independence; P), and \mathbf{M} (Fréchet–Hoeffding upper-bound copula; M). The copula is comprehensive because both \mathbf{W} and \mathbf{M} can be obtained. The parameters are readily estimated using Spearman Rho (\rho_\mathbf{C}; rhoCOP) and Kendall Tau (\tau_\mathbf{C}; tauCOP) by

\tau_\mathbf{C} = \frac{(\alpha - \beta)(\alpha + \beta + 2)}{3}\mbox{\ and\ } \rho_\mathbf{C} = \alpha - \beta\mbox{.}

The Fréchet Family copula virtually always has a visible singular component unless \alpha, \beta = 0. The copula has respective lower- and upper-tail dependency parameters of \lambda^L = \alpha and \lambda^U = \alpha (taildepCOP). Durante (2007, p. 257) reports that the Fréchet Family copula can approximate any bivariate copula in a “unique way” and the error bound can be estimated.

Usage

FRECHETcop(u,v, para=NULL, rho=NULL, tau=NULL, par2rhotau=FALSE, ...)

Arguments

Details

The function will check the consistency of the parameters whether given by argument or computed from \rho_\mathbf{C} and \tau_\mathbf{C}. The term “Family” is used with this particular copula in copBasic so as to draw distinction to the Fréchet lower- and upper-bound copulas as the two limiting copulas are called.

For no other reason than that it can be easily done and makes a nice picture, loop through a nest of \rho and \tau for the Fréchet Family copula and plot the domain of the resulting parameters:

  ops <- options(warn=-1) # warning supression because "loops" are dumb
  taus <- rhos <- seq(-1,1, by=0.01)
  plot(NA, NA, type="n", xlim=c(0,1), ylim=c(0,1),
       xlab="Frechet Copula Parameter Alpha",
       ylab="Frechet Copula Parameter Beta")
  for(tau in taus) {
    for(rho in rhos) {
      fcop <- FRECHETcop(rho=rho, tau=tau)
      if(! is.na(fcop$para[1])) points(fcop$para[1], fcop$para[2])
    }
  }
  options(ops)

Value

Value(s) for the copula are returned using the \alpha and \beta as set by argument para; however, if para=NULL and rho and tau are set and compatible with the copula, then \{\rho_\mathbf{C}, \tau_\mathbf{C}\} \rightarrow \{\alpha, \beta\}, parameter estimation made, and an R list is returned.

Note

A convex combination (convex2COP) of \mathbf{\Pi} and \mathbf{M}, which is a modification of the Fréchet Family, is the Linear Spearman copula:

\mathbf{C}_\alpha(u,v) = (1-\alpha)\mathbf{\Pi}(u,v) + \alpha\mathbf{M}(u,v)\mbox{,}

for 0 \le \alpha \le 1, and the parameter is equal to \rho_\mathbf{C}. When the convex combination is used for construction, the complement of the parameter is equal to \rho_\mathbf{C} (e.g. 1-\alpha = \rho_\mathbf{C}; rhoCOP), which can be validated by

  rhoCOP(cop=convex2COP, para=list(alpha=1-0.48, cop1=P, cop2=M)) # 0.4799948

Author(s)

W.H. Asquith

References

Durante, F., 2007, Families of copulas, Appendix C, in Salvadori, G., De Michele, C., Kottegoda, N.T., and Rosso, R., 2007, Extremes in Nature—An approach using copulas: Springer, 289 p.

See Also

M, P, W

Examples

## Not run: 
ppara <- c(0.25, 0.50)
fcop <- FRECHETcop(para=ppara, par2rhotau=TRUE)
RHO <- fcop$rho; TAU <- fcop$tau

level.curvesCOP(cop=FRECHETcop, para=ppara) # Durante (2007, Fig. C.27(b))
mtext("Frechet Family copula")
 UV <- simCOP(n=50, cop=FRECHETcop, para=ppara, ploton=FALSE, points=FALSE)
tau <- cor(UV$U, UV$V, method="kendall" ) # sample Kendall Tau
rho <- cor(UV$U, UV$V, method="spearman") # sample Spearman Rho
spara <- FRECHETcop(rho=rho, tau=tau) # a fitted Frechet Family copula
spara <- spara$para
if(is.na(spara[1])) { # now a fittable combination is not guaranteed
   warning("sample rho and tau do not provide valid parameters, ",
           "try another simulation")
} else { # now if fit, draw some red-colored level curves for comparison
   level.curvesCOP(cop=FRECHETcop, para=spara, ploton=FALSE, col=2)
} #
## End(Not run)

The Frank Copula

Description

The Frank copula (Joe, 2014, p. 165) is

\mathbf{C}_{\Theta}(u,v) = \mathbf{FR}(u,v) = -\frac{1}{\Theta}\mathrm{log}\biggl[\frac{1 - \mathrm{e}^{-\Theta} - \bigl(1 - \mathrm{e}^{-\Theta u}\bigr) \bigl(1 - \mathrm{e}^{-\Theta v}\bigr)}{1 - \mathrm{e}^{-\Theta}}\biggr]\mbox{,}

where \Theta \in [-\infty, +\infty], \Theta \ne 0. The copula, as \Theta \rightarrow -\infty limits, to the countermonotonicity coupla (\mathbf{W}(u,v); W), as \Theta \rightarrow 0^{\pm} limits to the independence copula (\mathbf{\Pi}(u,v); P), and as \Theta \rightarrow +\infty, limits to the comonotonicity copula (\mathbf{M}(u,v); M). The parameter \Theta is readily computed from a Kendall Tau (tauCOP) by numerical methods as \tau_{\mathbf{C}}(\Theta) = 1 + 4\Theta^{-1}[D_1(\Theta) - 1] or from a Spearman Rho (rhoCOP) as \rho_{\mathbf{C}}(\Theta) = 1 + 4\Theta^{-1}[D_2(\Theta) - D_1(\Theta)] for Debye function as

D_k(x, k) = k x^{-k} \int_0^x t^k \bigl(\mathrm{e}^{t} - 1\bigr)^{-1}\, \mathrm{d}t\mbox{.}

Usage

FRcop(u, v, para=NULL, rhotau=NULL, userhotau_chk=TRUE,
            cortype=c("kendall", "spearman", "tau", "rho"), ...)

Arguments

Value

Value(s) for the copula are returned. Otherwise if tau is given, then the \Theta is computed and a list having

and if para=NULL and tau=NULL, then the values within u and v are used to compute Kendall Tau and then compute the parameter, and these are returned in the aforementioned list. Or if rho is given, then the \Theta is computed and a similar list is returned having similar structure but with Spearman Rho instead.

Note

Whether because of default directions of derivative in derCOP for partial derivative of the copula or other numerical challenges, the implementation uses the negative parameter whether positive or not and rotates the copula as needed for complete operation of simCOP. Several default limiting conditions are in the sources before conversion to independence, perfect positive dependence, or perfect negative dependence.

Author(s)

W.H. Asquith

References

Joe, H., 2014, Dependence modeling with copulas: Boca Raton, CRC Press, 462 p.

See Also

M, P, W

Examples

UV  <- simCOP(n=1000, cop=FRcop, para=20, seed=1)
print(FRcop(UV[,1], UV[,2], cortype="kendall" )$tau) # 0.8072993
print(FRcop(UV[,1], UV[,2], cortype="spearman")$rho) # 0.9536648

## Not run: 
  # Joe (2014) example follows by extendinh the functionality of copBasic
  # into a 3-dimensional C-vine copula using Frank and Gumbel copulas and
  # Kendall Taus and Kendall Partial Taus. The example is expanded to show
  # how advanced features of copBasic can be incorporated for asymmetry
  # (if needed) and reflections (rotations) of copula:
  nsim <- 5000 # number of simulations but not too large for long CPU
  d <- 3       # three dimensions in Joe (2014, algorithm 15) implementation
  GHcop_para <- GHcop(tau   =0.5                   )$para # theta = 2
  FRcop_para <- FRcop(rhotau=0.7, cortype="kendall")$para # theta = 11.41155
  # Substantial notation complexity by structuring the C-vine by matrices for
  # copula families and their parameters then dial in asymmetry by "breves"
  # (see copBasic::breveCOP) and then reflection (rotation ability in the
  # copulas themselves). With zero breves, we have no asymmetry (permutation)
  # and we are going with the basic copula formula, so Reflects are all 1.
  Cops     <- matrix(c(NA,    "GHcop",     "FRcop",
                       NA,         NA,         "M",
                       NA,         NA,         NA),  nrow=d, ncol=d, byrow=TRUE)
  Thetas   <- matrix(c(NA, GHcop_para,  FRcop_para,
                       NA,         NA,          NA,
                       NA,         NA,          NA), nrow=d, ncol=d, byrow=TRUE)
  Breves   <- matrix(c(NA,          0,           0,
                       NA,         NA,           0,
                       NA,         NA,          NA), nrow=d, ncol=d, byrow=TRUE)
  Reflects <- matrix(c(NA,          1,           1,
                       NA,         NA,           1,
                       NA,         NA,          NA), nrow=d, ncol=d, byrow=TRUE)
  # see copBasic::breveCOP(), copBasic::GHcop(), copBasic::M()
  # see also copBasic::COP() for how reflection work within the package
  set.seed(1); U <- NULL # seed and vector of the U_{(1,2,3)} probabilities
  for(i in 1:nsim) {
    w <- runif(d); u <- rep(NA, d); u[1] <- w[1]
    # looks messy but just a way dump a host of "parameters" including family
    # itself down into copBasic logic
    para <- list(cop=breveCOP, para=list(cop=eval(parse(text=Cops[1,2])),
            para=Thetas[1,2], breve=Breves[1,2], reflect=Reflects[1,2]))
    u[2] <- derCOPinv(u[1], t=w[2], cop=COP, para=para) # conditional quantiles
    for(j in 3:d) {
      q <- w[j]
      for(l in (j-1):1) { # Joe (2014, algorithm 16)
        para <- list(cop=breveCOP, para=list(cop=eval(parse(text=Cops[l,j])),
                para=Thetas[l,j], breve=Breves[l,j], reflect=Reflects[l,j]))
        q <- derCOPinv(w[l], t=q, cop=COP, para=para)   # conditional quantiles
      }
      u[j] <- q
    }
    U <- rbind(U, matrix(u, ncol=d, byrow=TRUE))
  }
  U <- as.data.frame( U )
  names( U ) <- paste0("U", seq_len(d))

  # Kendall Partial Tau; Joe (2014, p. 8.66, Theorem 8.66)
  "pc3dCOP" <- function(taujk, tauhj, tauhk) { # close attention to h subscript!
    etajk <- sin( pi*taujk / 2) # Expansion to trig by Joe (2014, theorem 8.19),
    etahj <- sin( pi*tauhj / 2) # Joe says this definition "might be"
    etahk <- sin( pi*tauhk / 2) # better than partial tau on scores.
    (2/pi) * asin( (etajk - etahj*etahk) / sqrt( (1-etahj^2) * (1-etahk^2) ) )
  }
  # Joe (2014, pp. 404-405)
  # Kendall partial tau but needs pairwise Kendall taus to compute partial tau.
  "PairwiseTaus" <- function(U) {
    ktau <- matrix(NA, nrow=d, ncol=d)
    for(j in 1:d) { for(l in 1:d) {
        if(j <  l) next
        if(j == l) { ktau[l,j] <- 1; next } # 1s on diagonal as required.
        ktau[l,j] <- ktau[j,l] <- cor(U[,l], U[,j], method="kendall") # symmetrical
    } }
    return(ktau)
  }
  PairwiseTaus  <- PairwiseTaus(U) # [1,2] and [1,3] are 0.5 and 0.7 matching
  # requirement and more importantly for Joe (2014, table 8.3, p. 405). Now, [2,3] is
  # about 0.783 which again matches Joe's results of 0.782.
  Tau23given1pc <- pc3dCOP(PairwiseTaus[2,3], PairwiseTaus[2,1], PairwiseTaus[3,1])
  # Joe (2014, table 8.3, p. 405) reports tau^{pc}_{jk;h} as 0.848 by giant
  # simulation and we get about 0.852199 for some modest nsim and set.seed(1). 
## End(Not run)

The Gumbel–Hougaard Extreme Value Copula

Description

SYMMETRIC GUMBEL-HOUGAARD—The Gumbel–Hougaard copula (Nelsen, 2006, pp. 118 and 164) is

\mathbf{C}_{\Theta}(u,v) = \mathbf{GH}(u,v) = \mathrm{exp}\{-[(-\log u)^\Theta+(-\log v)^\Theta]^{1/\Theta}\}\mbox{,}

where \Theta \in [1 , \infty). The copula here is a bivariate extreme value copula (BEV). The parameter \Theta is readily estimated using a Kendall Tau (say a sample version \hat\tau) where the \tau of the copula (\tau_\mathbf{C}) is defined as

\tau_\mathbf{C} = \frac{\Theta - 1}{\Theta} \rightarrow \Theta = \frac{1}{1-\tau}\mbox{.}

The copula is readily extended into d dimensions by

\mathbf{C}_{\Theta}(u,v) = \mathrm{exp}\{-[(-\log u_1)^\Theta+\cdots+(-\log u_d)^\Theta]^{1/\Theta}\}\mbox{.}

However, such an implementation is not available in the copBasic package.

Every Gumbel–Hougaard copula is a multivariate extreme value (MEV) copula, and hence useful in analysis of extreme value distributions. The Gumbel–Hougaard copula is the only Archimedean MEV (Salvadori et al., 2007, p. 192). The Gumbel–Hougaard copula has respective lower- and upper-tail dependency parameters of \lambda^L = 0 and \lambda^U = 2 - 2^{1/\Theta}, respectively. Nelsen (2006, p. 96) shows that \mathbf{C}^r_\theta(u^{1/r}, v^{1/r}) = \mathbf{C}_\theta(u,v) so that every Gumbel–Hougaard copula has a property known as max-stable. A dependence measure uniquely defined for BEV copulas is shown under rhobevCOP.

A comparison through simulation between Gumbel–Hougaard implementations by the R packages acopula, copBasic, copula, and Gumbel is shown in the Examples section. At least three divergent techniques for random variate generation are used amongst those packages. The simulations also use copBasic-style random variate generation (conditional simulation) using an analytical-numerical hybrid solution to conditional inverse described in the Note section.

TWO-PARAMETER GUMBEL–HOUGAARD—A permutation symmetric (isCOP.permsym) but almost certainly radial asymmetric (isCOP.radsym) version of the copula is readily constructed (Brahimi et al., 2015) into a two-parameter version:

\mathbf{C}(u,v; \beta_1, \beta_2) = \biggl[ \biggl(\bigl(u^{-\beta_2} -1\bigr)^{\beta_1} + \bigl(v^{-\beta_2} -1\bigr)^{\beta_1} \biggr)^{1/\beta_1} + 1 \biggr]^{-1/\beta_2}\mbox{,}

where \beta_1 \ge 1 and \beta_2 > 0. Both parameters controls the general level of association, whereas parameter \beta_2 can be thought of as controlling left-tail dependency (taildepCOP, \lambda^{[U\mid L]}_{(\beta_1, \beta_2)}; e.g. \lambda^U_{(1.5; \beta_2)} = 0.413 for all \beta_2 but \lambda^L_{(1.5; 0.2)} = 0.811 and \lambda^L_{(1.5; 2.2)} = 0.099. Brahimi et al. (2015) report a Spearman Rho (rhoCOP) for a \mathbf{GH}_{(1.5, 0.2)}(u,v) is 0.5, which is readily confirmed in copBasic by the function call rhoCOP(cop=GHcop, para=c(1.5,0.2)). The two-parameter \mathbf{GH} is triggered if the length of the para argument is exactly 2.

ASYMMETRIC GUMBEL–HOUGAARD—An asymmetric version of the copula is readily constructed (Joe, 2014, p. 185–186) into a three-parameter version with Marshall–Olkin copulas on the boundaries:

\mathbf{C}(u,v; \Theta, \pi_2, \pi_3) = \mathrm{exp}[-\mathcal{A}(-\log u, -\log v; \Theta, \pi_2, \pi_3)]\mbox{,}

where \Theta \ge 1 as before, 0 \le \pi_2, \pi_3 \le 1, and

\mathcal{A}(x, y; \Theta, \pi_2, \pi_3) = [(\pi_2 x)^\Theta + (\pi_3 y)^\Theta]^{1/\Theta} + (1-\pi_2)x + (1-\pi_3)y\mbox{.}

The asymmetric \mathbf{GH} is triggered if the length of the para argument is exactly 3. The GHcop function provides no mechanism for estimation of the parameters for the asymmetric version. Reviewing simulations, the bounds on the \pi parameters in Joe (2014, p. 185) “[0 \le \pi_2 < \pi_3 \le 1]” might be incorrect—by Joe back referencing to Joe (2014, eq. 4.35, p. 183) the \pi-limits as stated for copBasic are shown. An algorithm for parameter estimation for the asymmetric \mathbf{GH} using two different measures of bivariate skewness as well as an arbitrary measure of association is shown in section Details in joeskewCOP.

Usage

GHcop(u, v, para=NULL, tau=NULL, tau.big=0.985, cor=NULL, ...)

Arguments

Details

Numerical experiments seem to indicate for \tau_\mathbf{C} > 0.985 that failures in the numerical partial derivatives in derCOP and derCOP2 result—a \tau_\mathbf{C} this large is indeed large. As \Theta \rightarrow \infty the Gumbel–Hougaard copula becomes the Fréchet–Hoeffding upper-bound copula \mathbf{M} (see M). A \tau_\mathbf{C} \approx 0.985 yields \Theta \approx 66 + 2/3, then for \Theta > 1/(1-\tau_\mathbf{C}) flips over to the \mathbf{M} copula with a warning issued.

Value

Value(s) for the copula are returned using the \Theta as set by argument para. Alternative returned values are possible: (1) If para=NULL and tau is set, then \tau_\mathbf{C} \rightarrow \Theta and an R list is returned. (2) If para=NULL and tau=NULL, then an attempt to estimate \Theta from the u and v is made by \mathrm{cor}(u,v)_\tau \rightarrow \tau_\mathbf{C} \rightarrow \Theta by either trigger using cor(u,v, method="kendall") in R, and an R list is returned. The possibly returned list has the following elements:

Note

SYMMETRIC GUMBEL–HOUGAARD—A function for the derivative of the copula (Joe, 2014, p. 172) given u is

  "GHcop.derCOP" <- function(u, v, para=NULL, ...) {
     x <- -log(u); y <- -log(v)
     A <- exp(-(x^para + y^para)^(1/para)) * (1 + (y/x)^para)^(1/para - 1)
     return(A/u)
  }

that can be tested by the following

  Theta <- 1/(1-.15) # a Kendall Tau of 0.15
  GHcop.derCOP(     0.5, 0.75, para=Theta) # 0.7787597
  derCOP(cop=GHcop, 0.5, 0.75, para=Theta) # 0.7787597
  # The next two nearly return same value but conversion to GRVs
  # (Gumbel Reduced Variates) to magnify the numerical differences.
  # The GHcop.derCOP is expected to be the more accurate of the two.
  lmomco::prob2grv(GHcop.derCOP(     0.5, 0.9999999, para=Theta)) # 18.83349
  lmomco::prob2grv(derCOP(cop=GHcop, 0.5, 0.9999999, para=Theta)) # 18.71497
  lmomco::prob2grv(derCOP(cop=GHcop, 0.5, 0.9999999, para=Theta,
                                   delu=.Machine$double.eps^.25)) # 18.83341

where the last numerical approximation shows that tighter tolerance is needed. A function for the inverse of the derivative (Joe, 2014, p. 172) given u by an analytical-numerical hybrid is

  "GHcop.derCOPinv" <- function(u,t, para=NULL, verbose=FALSE,
                                     tol=.Machine$double.eps, ...) {
    if(length(u) > 1) warning("only the first value of u will be used")
    if(length(t) > 1) warning("only the first value of t will be used")
    if(is.null(para)) { warning("para can not be NULL"); return(NA) }
    u <- u[1]; t <- t[1]; rt <- NULL
    x <- -log(u); A <- (x + (para - 1)*log(x) - log(t))
    hz <- function(z) { z + (para - 1)*log(z) - A }
    zmax <- x; i <- 0; hofz.lo <- hz(zmax)
    if(sign(hofz.lo) != -1) warning("sign for h(z) is not negative!")
    while(1) {
       i <- i + 1
       if(i > 100) {
          warning("maximum iterations looking for zmax reached"); break
       }
       # increment zmax by 1/2 log cycle, sign(hofz.lo) should be negative!
       if(sign(hz(zmax <- zmax + 1/2)) != sign(hofz.lo)) break
    }
    try(rt <- uniroot(hz, c(x, zmax), tol=tol, ...), silent=FALSE)
    if(verbose) print(rt)
    if(is.null(rt)) {
       warning("NULL on the inversion of the GH copula derivative")
       return(NA)
    }
    zo <- rt$root
    y <- (zo^para - x^para)^(1/para)
    names(y) <- NULL
    return(exp(-y))
  }

that can be tested by the following, which also shows how to increase the tolerance on the numerical implementation

  u <- 0.999; p <- 0.999
  GHcop.derCOPinv(     u, p, para=1.56) # 0.999977
  derCOPinv(cop=GHcop, u, p, para=1.56) # 1 (unity), needs tighter tolerance
  derCOPinv(cop=GHcop, u, p, para=1.56, tol=.Machine$double.eps/10) # 0.999977

ASYMMETRIC GUMBEL–HOUGAARD—Set \tau_\mathbf{C} = 0.35 then for a symmetric and then reflection on the 1:1 line of the asymmetric Gumbel–Hougaard copula and compute the primary parameter \Theta, and lastly, compute three bivariate \nu_\mathbf{C} skewnesses (nuskewCOP):

  Theta1 <- uniroot(function(t) {
                0.35 - tauCOP(cop=GHcop, para=c(t)) },           c(1,10))$root
  Theta2 <- uniroot(function(t) { # asymmetric
                0.35 - tauCOP(cop=GHcop, para=c(t, 0.6, 0.9)) }, c(1,30))$root
  Theta3 <- uniroot(function(t) { # asymmetric reflection on 1:1
                0.35 - tauCOP(cop=GHcop, para=c(t, 0.9, 0.6)) }, c(1,30))$root
  # Theta1 = 1.538462   and   Theta2 = Theta3 = 2.132856
  # Three "skews" based on a combination of U, V, and C(u,v) [nuskew()]
  nuskewCOP(cop=GHcop,   1.538462) # zero bivariate skewness
  nuskewCOP(cop=GHcop, c(2.132856, 0.6, 0.9)) #  0.008245653
  nuskewCOP(cop=GHcop, c(2.132856, 0.9, 0.6)) # -0.008245653

So, we see, holding \tau_\mathbf{C} constant, that the \mathbf{GH} has a \nu_{\mathbf{GH}(1.538)} = 0 but the asymmetric case \nu_{\mathbf{GH}(2.133, 0.6, 0.9)} = 0.0082 and \nu_{\mathbf{GH}(2.133, 0.9, 0.6)} = -0.0082 where the change in sign represents reflection about the 1:1 line. Finally, compute L-coskew by large simulation and the adjective “bow” representing the direction of bowing or curvature of the principle copula density.

  # Because the Tau's are all similar, there is nothing to learn from the
  # L-correlation, let us inspect the L-coskew instead:
  coT3.1<-lmomco::lcomoms2(simCOP(n=8000, cop=GHcop, para=c(Theta1      )))$T3
  coT3.2<-lmomco::lcomoms2(simCOP(n=8000, cop=GHcop, para=c(Theta2,.6,.9)))$T3
  coT3.3<-lmomco::lcomoms2(simCOP(n=8000, cop=GHcop, para=c(Theta3,.9,.6)))$T3
  # The simulations for Theta1 have no curvature about the diagonal.
  # The simulations for Theta2 have curvature towards the upper left.
  # The simulations for Theta3 have curvature towards the lower right.
  message("# L-coskews: ",round(coT3.1[1,2],digits=4),"(symmetric) ",
                          round(coT3.2[1,2],digits=4),"(asym.--bow UL) ",
                          round(coT3.3[1,2],digits=4),"(asym.--bow UL)")
  message("# L-coskews: ",round(coT3.1[2,1],digits=4),"(symmetric) ",
                          round(coT3.2[2,1],digits=4),"(asym.--bow LR) ",
                          round(coT3.3[2,1],digits=4),"(asym.--bow LR)")
  # L-coskews: 0.0533(symmetric) 0.1055(asym.--bow UL) 0.0021(asym.--bow UL)
  # L-coskews: 0.0679(symmetric) 0.0112(asym.--bow LR) 0.1154(asym.--bow LR)

Thus, the L-comoments (Asquith, 2011) using their sample values measure something fundamental about the bivariate association between the three copulas choosen. The L-coskews for the symmetrical case are about equal and are

\tau^{\mathbf{GH}(\Theta_1)}_{3[12]} \approx \tau^{\mathbf{GH}(\Theta_1)}_{3[21]} \rightarrow (0.0533 + 0.0679)/2 = 0.0606\mbox{,}

whereas the L-coskew for the curvature to the upper left are

\tau^{\mathbf{GH}(\Theta_2, 0.6, 0.9)}_{3[12]} = 0.1055\mbox{\ and\ } \tau^{\mathbf{GH}(\Theta_2, 0.6, 0.9)}_{3[12]} = 0.0112\mbox{,}

whereas the L-coskew for the curvature to the lower right are

\tau^{\mathbf{GH}(\Theta_3, 0.9, 0.6)}_{3[12]} = 0.0021\mbox{\ and\ } \tau^{\mathbf{GH}(\Theta_3, 0.6, 0.9)}_{3[12]} = 0.1154\mbox{.}

Thus, the \pi_2 and \pi_3 parameters as choosen add about ((0.1154+0.1055)/2 - 0.0606 \rightarrow 0.1105 - 0.0606 = 0.05) L-coskew units to the bivariate distribution.

Author(s)

W.H. Asquith

References

Asquith, W.H., 2011, Distributional analysis with L-moment statistics using the R environment for statistical computing: Createspace Independent Publishing Platform, ISBN 978–146350841–8.

Brahimi, B., Chebana, F., and Necir, A., 2015, Copula representation of bivariate L-moments—A new estimation method for multiparameter two-dimensional copula models: Statistics, v. 49, no. 3, pp. 497–521.

Joe, H., 2014, Dependence modeling with copulas: Boca Raton, CRC Press, 462 p.

Nelsen, R.B., 2006, An introduction to copulas: New York, Springer, 269 p.

Salvadori, G., De Michele, C., Kottegoda, N.T., and Rosso, R., 2007, Extremes in Nature—An approach using copulas: Springer, 289 p.

Zhang, L., and Singh, V.P., 2007, Gumbel–Hougaard copula for trivariate rainfall frequency analysis: Journal Hydrologic Engineering, v. 12, Special issue—Copulas in Hydrology, pp. 409–419.

See Also

M, GLcop, HRcop, tEVcop, rhobevCOP

Examples

Theta    <- 2.2 # Let us see if numerical and analytical tail deps are the same.
del.lamU <- abs( taildepCOP(cop=GHcop, para=Theta)$lambdaU - (2-2^(1/Theta)) )
as.logical(del.lamU < 1E-6) # TRUE
## Not run: 
# The simulations match Joe (2014, p. 72) for Gumbel-Hougaard
n <- 600; nsim <- 1000; set.seed(946) # see for reproducibility
SM <- sapply(1:nsim, function(i) { rs <- semicorCOP(cop=GHcop, para=1.35, n=n)
                                 c(rs$botleft.semicor, rs$topright.semicor) })
RhoM     <- round(mean(SM[1,]),          digits=3)
RhoP     <- round(mean(SM[2,]),          digits=3)
SE.RhoM  <- round(  sd(SM[1,]),          digits=3)
SE.RhoP  <- round(  sd(SM[2,]),          digits=3)
SE.RhoMP <- round(  sd(SM[2,] - SM[1,]), digits=3)
# Semi-correlations (sRho) and standard errors (SEs)
message("# sRho[-]=", RhoM, " (SE[-]=", SE.RhoM, ") Joe(p.72)=0.132 (SE[-]=0.08)")
message("# sRho[+]=", RhoP, " (SE[+]=", SE.RhoP, ") Joe(p.72)=0.415 (SE[+]=0.07)")
message("# SE(sRho[-] - sRho[+])=", SE.RhoMP, " Joe(p.72) SE=0.10")
# sRho[-]=0.134 (SE[-]=0.076) Joe(p.72)=0.132 (SE[-]=0.08)
# sRho[+]=0.407 (SE[+]=0.074) Joe(p.72)=0.415 (SE[+]=0.07)
# SE(sRho[-] - sRho[+])=0.107 Joe(p.72) SE=0.10
# Joe (2014, p. 72) reports the values 0.132, 0.415, 0.08, 0.07, 0.10, respectively.
## End(Not run)

## Not run: 
file <- "Lcomom_study_of_GHcopPLACKETTcop.txt"
x <- data.frame(tau=NA, trho=NA, srho=NA, PLtheta=NA, PLT2=NA, PLT3=NA, PLT4=NA,
                                          GHtheta=NA, GHT2=NA, GHT3=NA, GHT4=NA )
write.table(x, file=file, row.names=FALSE, quote=FALSE)
n <- 250 # Make a large number for very long CPU run but seems stable
for(tau in seq(0,0.98, by=0.005)) {
   thetag <- GHcop(u=NULL, v=NULL, tau=tau)$para
   trho   <- rhoCOP(cop=GHcop, para=thetag)
   GH     <- simCOP(n=n, cop=GHcop, para=thetag, points=FALSE, ploton=FALSE)
   srho   <- cor(GH$U, GH$V, method="spearman")
   thetap <- PLACKETTpar(rho=trho)
   PL     <- simCOP(n=n, cop=PLACKETTcop, para=thetap, points=FALSE, ploton=FALSE)
   GHl    <- lmomco::lcomoms2(GH, nmom=4); PLl <- lmomco::lcomoms2(PL, nmom=4)
   x <- data.frame(tau=tau, trho=trho, srho=srho,
                   GHtheta=thetag, PLtheta=thetap,
                   GHT2=mean(c(GHl$T2[1,2], GHl$T2[2,1])),
                   GHT3=mean(c(GHl$T3[1,2], GHl$T3[2,1])),
                   GHT4=mean(c(GHl$T4[1,2], GHl$T4[2,1])),
                   PLT2=mean(c(PLl$T2[1,2], PLl$T2[2,1])),
                   PLT3=mean(c(PLl$T3[1,2], PLl$T3[2,1])),
                   PLT4=mean(c(PLl$T4[1,2], PLl$T4[2,1])) )
   write.table(x, file=file, row.names=FALSE, col.names=FALSE, append=TRUE)
}

# After a processing run with very large "n", then meaningful results exist.
D <- read.table(file, header=TRUE); D <- D[complete.cases(D),]
plot(D$tau, D$GHT3, ylim=c(-0.08,0.08), type="n",
     xlab="KENDALL TAU", ylab="L-COSKEW OR NEGATED L-COKURTOSIS")
points(D$tau,  D$GHT3, col=2);             points(D$tau,  D$PLT3, col=1)
points(D$tau, -D$GHT4, col=4, pch=2);      points(D$tau, -D$PLT4, col=1, pch=2)
LM3 <- lm(D$GHT3~I(D$tau^1)+I(D$tau^2)+I(D$tau^4)-1)
LM4 <- lm(D$GHT4~I(D$tau^1)+I(D$tau^2)+I(D$tau^4)-1)
LM3c <- LM3$coe; LM4c <- LM4$coe
Tau <- seq(0,1, by=.01); abline(0,0, lty=2, col=3)
lines(Tau,   0 + LM3c[1]*Tau^1 + LM3c[2]*Tau^2 + LM3c[3]*Tau^4,  col=4, lwd=3)
lines(Tau, -(0 + LM4c[1]*Tau^1 + LM4c[2]*Tau^2 + LM4c[3]*Tau^4), col=2, lwd=3) #
## End(Not run)

## Not run: 
# Let us compare the conditional simulation method of copBasic by numerics and by the
# above analytical solution for the Gumbel-Hougaard copula to two methods implemented
# by package gumbel, a presumed Archimedean technique by package acopula, and an
# Archimedean technique by package copula. Setting seeds by each "method" below does
# not appear diagnostic because of the differences in which the simulations are made.
nsim <- 10000; kn <- "kendall" #  The theoretical KENDALL TAU is (1.5-1)/1.5 = 1/3
# Simulate by conditional simulation using numerical derivative and then inversion
A <- cor(copBasic::simCOP(nsim, cop=GHcop, para=1.5, graphics=FALSE), method=kn)[1,2]
U <- runif(nsim) # GHcop.derCOPinv() comes from earlier in this documentation.
V <- sapply(1:nsim, function(i) { GHcop.derCOPinv(U[i], runif(1), para=1.5) })
# Simulate by conditional simulation using exact analytical solution
B <- cor(U, y=V, method=kn);  rm(U, V)
# Simulate by the "common frailty" technique
C <- cor(gumbel::rgumbel(nsim, 1.5, dim=2, method=1), method=kn)[1,2]
# Simulate by "K function" (Is the K function method, Archimedean?)
D <- cor(gumbel::rgumbel(nsim, 1.5, dim=2, method=2), method=kn)[1,2]
# Simulate by an Archimedean implementation (presumably)
E <- cor(acopula::rCopula(nsim, pars=1.5), method=kn)[1,2]
# Simulate by an Archimedean implementation
G <- cor(copula::rCopula(nsim, copula::gumbelCopula(1.5)), method=kn)[1,2]
K <- round(c(A, B, C, D, E, G), digits=5); rm(A, B, C, D, E, G, kn); tx <- ", "
message("Kendall Tau: ", K[1], tx, K[2], tx, K[3], tx, K[4], tx, K[5], tx, K[6])
# Kendall Tau: 0.32909, 0.32474, 0.33060, 0.32805, 0.32874, 0.33986 -- run 1
# Kendall Tau: 0.33357, 0.32748, 0.33563, 0.32913, 0.32732, 0.32416 -- run 2
# Kendall Tau: 0.34311, 0.33415, 0.33815, 0.33224, 0.32961, 0.33008 -- run 3
# Kendall Tau: 0.32830, 0.33573, 0.32756, 0.33401, 0.33567, 0.33182 -- nsim=50000!
# All solutions are near 1/3 and it is unknown without further study which of the
# six methods would result in the least bias and (or) sampling variability.
## End(Not run)

The Galambos Extreme Value Copula (with Gamma Power Mixture [Joe/BB4] and Lower Extreme Value Limit)

Description

The Galambos copula (Joe, 2014, p. 174) is

\mathbf{C}_{\Theta}(u,v) = \mathbf{GL}(u,v) = uv\,\mathrm{exp}\bigl[\bigl(x^{-\Theta} + y^{-\Theta}\bigr)^{-1/\Theta}\bigr]\mbox{,}

where \Theta \in [0, \infty), x = -\log u, and y = -\log v. As \Theta \rightarrow 0^{+}, the copula limits to independence (\mathbf{\Pi}; P) and as \Theta \rightarrow \infty, the copula limits to perfect association (\mathbf{M}; M). The Galambos is a bivariate extreme value copula (BEV), and parameter estimation for \Theta requires numerical methods.

There are two other genetically related forms. Joe (2014, p. 197) describes an extension of the Galambos copula as a Galambos gamma power mixture (GLPM), which is Joe's BB4 copula, with the following form

\mathbf{C}_{\Theta,\delta}(u,v) = \mathbf{GLPM}(u,v) = \biggl(x + y - 1 - \bigl[(x - 1)^{-\delta} + (y - 1)^{-\delta} \bigr]^{-1/\delta} \biggr)^{-1/\Theta}\mbox{,}

where x = u^{-\Theta}, y = v^{-\Theta}, and \Theta \ge 0, \delta \ge 0. (Joe shows \delta > 0, but zero itself seems to work without numerical problems in practical application.) As \delta \rightarrow 0^{+}, the “MTCJ family” (Mardia–Takahasi–Cook–Johnson) results (implemented internally with \Theta as the incoming parameter). As \Theta \rightarrow 0^{+}, the Galambos above results with \delta as the incoming parameter.

This Galambos extension in turn has a lower extreme value limit form that leads to a min-stable bivariate exponential having Pickand dependence function of

A(x,y; \Theta, \delta) = x + y - \bigl[x^{-\Theta} + y^{-\Theta} - (x^{\Theta\delta} + y^{\Theta\delta})^{-1/\delta} \bigr]^{-1/\Theta}\mbox{,}

where this third copula is

\mathbf{C}^{LEV}_{\Theta,\delta}(u,v) = \mathbf{GLEV}(u,v) = \mathrm{exp}[-A(-\log u, -\log v; \Theta, \delta)]\mbox{,}

for \Theta \ge 0, \delta \ge 0 and is known as the two-parameter Galambos. (Joe shows \delta > 0, but \delta = 0 itself seems to work without numerical problems in practical application.)

Usage

GLcop(   u, v, para=NULL, ...)
GLEVcop( u, v, para=NULL, ...)
GLPMcop( u, v, para=NULL, ...) # inserts third parameter automatically
JOcopBB4(u, v, para=NULL, ...) # inserts third parameter automatically

Arguments

Value

Value(s) for the copula are returned.

Note

Joe (2014, p. 198) shows \mathbf{GLEV}(u,v; \Theta, \delta) as a two-parameter Galambos, but its use within the text seemingly is not otherwise obvious. However, testing of the implementation here seems to show that this copula is really not broader in form than \mathbf{GL}(u,v; \alpha). The \alpha can always(?) be chosen to mimic the \{\Theta, \delta\}. This assertion can be tested from a semi-independent direction. First, define an alternative style of one-parameter Galambos:

  GL1cop <- function(u,v, para=NULL, ...) {
     GL1pA <- function(x,y,t) { # Pickend dependence func form 1p Galambos
        x + y - (x^-t + y^-t)^(-1/t)
     }
     if(length(u) == 1) { u <- rep(u, length(v)) } else
     if(length(v) == 1) { v <- rep(v, length(u)) }
     exp(-GL1pA(-log(u), -log(v), para[1]))
  }

Second, redefine the two-parameter Galambos:

  GL2cop <- function(u,v, para=NULL, ...) {
     GL2pA <- function(x,y,t,d) { # Pickend dependence func form 2p Galambos
        x + y - (x^-t + y^-t - (x^(t*d) + y^(t*d))^(-1/d))^(-1/t)
     }
     if(length(u) == 1) { u <- rep(u, length(v)) } else
     if(length(v) == 1) { v <- rep(v, length(u)) }
     exp(-GL2pA(-log(u), -log(v), para[1], para[2]))
  }

Next, we can combine the Pickend dependence functions into an objective function. This objective function will permit the computation of the \alpha given a pair \{\Theta, \delta\}.

  objfunc <- function(a,t=NA,d=NA, x=0.7, y=0.7) {
     lhs <- (x^-t + y^-t - (x^(t*d) + y^(t*d))^(-1/d))^(-1/t)
     rhs <- (x^-a + y^-a)^(-1/a); return(rhs - lhs) # to be uniroot'ed
  }

A demonstration can now be made:

  t <- 0.6; d <- 4; lohi <- c(0,100)
  set.seed(3); UV <- simCOP(3000, cop=GL2cop, para=c(t,d), pch=16,col=3,cex=0.5)
  a <- uniroot(objfunc, interval=lohi, t=t, d=d)$root
  set.seed(3); UV <- simCOP(3000, cop=GL1cop, para=a, lwd=0.5, ploton=FALSE)

The graphic so produced shows almost perfect overlap in the simulated values. To date, the author has not really found that the two parameters can be chosen such that the one-parameter version can not attain. Extensive numerical experiments using simulated parameter combinations through the use of various copula metrics (tail dependencies, L-comoments, etc) have not found material differences. Has the author of this package missed something?

Author(s)

W.H. Asquith

References

Joe, H., 2014, Dependence modeling with copulas: Boca Raton, CRC Press, 462 p.

See Also

M, P, GHcop, HRcop, tEVcop

Examples

# Theta = pi for GLcop and recovery through Blomqvist Beta     (Joe, 2014, p. 175)
log(2)/(log(log(2)/log(1+blomCOP(cop=GLcop, para=pi))))

# Theta = 2 and delta = 3 for the GLPM form and Blomqvist Beta (Joe, 2014, p. 197)
t <- 2; Btheo <- blomCOP(GLPMcop, para=c(t,3))
Bform <- (2^(t+1) - 1 - taildepCOP(GLPMcop, para=c(t,3))$lambdaU*(2^t -1))^(-1/t)
print(c(Btheo, 4*Bform-1)) # [1] 0.8611903 0.8611900

## Not run: 
  # See the Note section but check Blomqvist Beta here:
  blomCOP(cop=GLcop, para=c(6.043619))  # 0.8552863 (2p version)
  blomCOP(cop=GLcop, para=c(5.6, 0.3))  # 0.8552863 (1p version) 
## End(Not run)

The Hüsler–Reiss Extreme Value Copula

Description

The Hüsler–Reiss copula (Joe, 2014, p. 176) is

\mathbf{C}_{\Theta}(u,v) = \mathbf{HR}(u,v) = \mathrm{exp}\bigr[-x \Phi(X) - y\Phi(Y)\bigr]\mbox{,}

where \Theta \ge 0, x = - \log(u), y = - \log(v), \Phi(.) is the cumulative distribution function of the standard normal distribution, X and Y are defined as:

X = \frac{1}{\Theta} + \frac{\Theta}{2} \log\biggl(\frac{x}{y}\biggr)\mbox{\ and\ } Y = \frac{1}{\Theta} + \frac{\Theta}{2} \log\biggl(\frac{y}{x}\biggr)\mbox{.}

As \Theta \rightarrow 0^{+}, the copula limits to independence (\mathbf{\Pi}; P). The copula here is a bivariate extreme value copula (BEV), and the parameter \Theta requires numerical methods.

Usage

HRcop(u, v, para=NULL, ...)

Arguments

Value

Value(s) for the copula are returned.

Author(s)

W.H. Asquith

References

Joe, H., 2014, Dependence modeling with copulas: Boca Raton, CRC Press, 462 p.

See Also

P, GHcop, GLcop, tEVcop

Examples

# Parameter Theta = pi recovery through the Blomqvist Beta (Joe, 2014, p. 176)
qnorm(1 - log( 1 + blomCOP(cop=HRcop, para=pi) ) / ( 2 * log(2) ) )^(-1)

The Joe/B5 Copula (B5)

Description

The Joe/B5 copula (Joe, 2014, p. 170) is

\mathbf{C}_{\Theta}(u,v) = \mathbf{B5}(u,v) = 1 - \bigl((1-u)^\Theta + (1-v)^\Theta - (1-u)^\Theta (1-v)^\Theta\bigr)^{1/\Theta}\mbox{,}

where \Theta \in [1,\infty). The copula as \Theta \rightarrow \infty limits to the comonotonicity coupla (\mathbf{M}(u,v) and M), as \Theta \rightarrow 1^{+} limits to independence copula (\mathbf{\Pi}(u,v); P). Finally, the parameter \Theta is readily computed from a Kendall Tau (tauCOP) by

\tau_\mathbf{C} = 1 + \frac{2}{2-\Theta}\bigl(\psi(2) - \psi(1 + 2/\Theta)\bigr)\mbox{,}

where \psi is the digamma() function and as \Theta \rightarrow 2 then

\tau_\mathbf{C}(\Theta \rightarrow 2) = 1 - \psi'(2)

where \psi' is the trigamma() function.

Usage

JOcopB5(u, v, para=NULL, tau=NULL, ...)

Arguments

Value

Value(s) for the copula are returned. Otherwise if tau is given, then the \Theta is computed and a list having

and if para=NULL and tau=NULL, then the values within u and v are used to compute Kendall Tau and then compute the parameter, and these are returned in the aforementioned list.

Author(s)

W.H. Asquith

References

Joe, H., 2014, Dependence modeling with copulas: Boca Raton, CRC Press, 462 p.

See Also

M, P

Examples

# Upper tail dependency of Theta = pi --> 2 - 2^(1/pi) = 0.753131 (Joe, 2014, p. 171).
taildepCOP(cop=JOcopB5, para=pi)$lambdaU # 0.75313

# Blomqvist Beta of Theta = pi (Joe, 2014, p. 171).
blomCOP(cop=JOcopB5, para=pi)        # 0.5521328
3 - 4*(2*(1/2)^pi - (1/4)^pi)^(1/pi) # 0.5521328

## Not run: 
  # A test near the limiting Theta for trigamma()
  UV   <- simCOP(cop=JOcopB5, para=2, n=10000)
  para <- JOcopB5(UV[,1], UV[,2])$para
  message("Tau difference ", round(2-para, digits=2), " is small.") #
## End(Not run)

## Not run: 
   # embeddment of parameters for permutation asymmetry and rotation
   para <- list(cop=JOcopB5, para=30, reflect=3, breve=0.5)
   UV <- simCOP(cop=COP, para=list(cop=breveCOP, para=para), n=1000) #
## End(Not run)

Maximum Asymmetry Measure (or Vector) of a Copula by Exchangeability (Permutation Symmetry)

Description

Compute a measure of maximum exchangable asymmetry of a copula \mathbf{C}_\Theta using Exchangeability (permutation symmetry) according to De Baets and De Meyer (2017) by

\mu_{\infty\mathbf{C}}^{\mathrm{permsym}} = \mu_\infty^{\mathrm{permsym}} = 3 \times \mathrm{max}\bigl(\,|\,\mathbf{C}_\Theta(u,v) - \mathbf{C}_\Theta(v,u)\,|\,\bigr)

for (u,v) \in \mathcal{I}^2. De Baets and De Meyer (2017) comment that among many asymmetric metrics with copulas that \mu_\infty^{\mathrm{permsym}} is “by far the most interesting” (De Baets and De Meyer, 2017, p. 36). The 3 multiplier in the definition ensures that \mu_\infty^{\mathrm{permsym}} \in [0, 1]. De Baets and De Meyer also conclude that permutation symmetry of random variables, in general, is not a desired property in statistical models, and those authors use the \mu_\infty notation in lieu of L_\infty^{\mathrm{permsym}} (see documentation related to LpCOPpermsym within hoefCOP of Hoeffding Phi). The term “Permutation-Mu” is used for this measure in copBasic-package and in similar contexts.

Usage

LzCOPpermsym(cop=NULL, para=NULL, n=5E4,
             type=c("halton", "sobol", "torus", "runif"),
             as.abs=TRUE, as.vec=FALSE, as.mat=FALSE, plot=FALSE, ...)

Arguments

Details

EFFECT OF RANDOM NUMBER GENERATION—Package randtoolbox provides for random number generation on forms different than simply simulating uniform independent random variables for \mathcal{I}^2. The Halton, Sobol, and Torus types are implemented. The plot argument is useful for the user to see the differences in how these generators canvas the \mathcal{I}^2 domain.

The default is Halton, which visually appears to better canvas \mathcal{I}^2 without the clumping that simple uniform random variables does and without the larger gaps of Sobol or Torus. Testing indicates that Halton might generally require the smallest simulation size of the others with simple uniform random variables potentially being the worst and hence such is not the default. Exceptions surely exist depending on the style of the asymmetry. Nevertheless, Halton, Sobol, and Torus produce more consistent estimation behavior with each having a monotone approach towards the true maximum than simple uniform random variables.

The following example is a useful illustration of an asymmetrical Clayton copula (\mathbf{CL}(u,v; \Theta), CLcop) by composition of a single copula (composite1COP) with the theorical \mu_\infty^{\mathrm{permsym}} maxima computed by large sample simulation. A user might explore the effect of the random number generation by changing the type variable.

  type <- "halton"
  para <- list(cop=CLcop, para=20, alpha=0.3, beta=0.1) # asymmetrical Clayton
  ti <- LzCOPpermsym(cop=composite1COP, para=para, n=2E6, type=type) # large
  ns <- as.integer( 10^seq(1, 4, by=0.05) ) # sequence of simulation sizes
  mi <- sapply(ns, function(n) { # produce vector of maxima for simulation size
               LzCOPpermsym(cop=composite1COP, para=para, n=n, type=type) })
  ylim <- range(c(0.06, mi, ti)) # vertical limits to ensure visibility
  plot(ns, mi, log="x", pch=21, bg=grey(0.9), ylim=ylim, main=type,
       xlab="Simulation size", ylab="Maximum asymmetry measure")
  abline(h=ti, lwd=3, col="seagreen") # large sample size estimate in green

RELATION TO ANOTHER DISTANCES—The documentation for LpCOPpermsym lists a supremum definition L_\infty^{\mathrm{permsym}}, which is like \mu_\infty^{\mathrm{permsym}} but lacks the multiplier of 3. However, that documentation mentions a ratio of 1/3 being as upper bounds and hence the De Baets and De Meyer (2017) reasoning for the 3 multiplier to rescale \mu_\infty^{\mathrm{permsym}} \in (0,1). The simple interrelations between the two functions are explored in the following example:

  para <- c(30, 0.2, 0.95); n <- 5E4
  p <- 1
  mean(abs(LzCOPpermsym(cop=GHcop, para=para, n=n,
                          as.vec=TRUE)/3)^p)^(1/p)   # 0.01867929
           LpCOPpermsym(cop=GHcop, para=para, p=p)   # 0.01867940
  p <- 3
  mean(abs(LzCOPpermsym(cop=GHcop, para=para, n=n,
                          as.vec=TRUE)/3)^p)^(1/p)   # 0.02649376
           LpCOPpermsym(cop=GHcop, para=para, p=p)   # 0.02649317

The critical note is that LpCOPpermsym is the integral of the absolute differences in permuted differences across \mathcal{I}^2. Hence, it is an expectation. The LzCOPpermsym is difference because of the maximum of the differences. The computations in the example above show how the same information can be extracted from the two functions. De Baets and De Meyer (2017) do not make reference to raising and then rooting by the power p as shown. The examples here provide credence to the default setting of n (simulation size) for several significant figures of similarity.

COPULA PARAMETER ESTIMATION—Parameter estimation using signed permutation asymmetry vector can readily be accomplished, which means that we are interested in near-preservation of what permutation asymmetry might be present within the sample. In the self-contained example below, we will assume a parent of Gumbel–Hougaard (\mathbf{GH}(u,v; \Theta), GHcop) extended to asymmetry by using three parameters (\Theta = (10, 0.8, 0.6). Imagine that we unfortunately have a very small sample size (n = 100) as “hundred years of data.” The small sample size facilitates the use of the checkboard empirical copula (EMPIRcop); the sample size is small enough that the checkerboard helps smooth through ties. The simulation size for LzCOPpermsym is set “large” as presumed by the existing default. The premise here is that we desire to have near-precise matching to the sample Spearman Rho in conjunction with the permutation asymmetry.

  para <- c(10, 0.8, 0.6) # parameters of the parent
  nsam <- 100; seed <- 2  # sample size to fit and seed for RNG
  nsim <- 2E4 # note a change from default n argument in LzCOPpermsym()
  as.vec <- TRUE          # set to FALSE to use just Permutation-Mu
  rhoP <- rhoCOP(cop=GHcop, para=para)          # parent Spearman Rho
  UVsS <- simCOP(cop=GHcop, para=para, n=nsam, seed=seed) # simulate a sample
  rhoS <- rhoCOP(as.sample=TRUE,     para=UVsS) # sample Spearman Rho
  infS <- LzCOPpermsym(cop=EMPIRcop, para=UVsS, n=nsim, type="halton",
                       as.vec=as.vec, ctype="checkerboard")
  # empirical copula used and returning signed asymmetry vector
  # transformation and re-transformation, GHcop paras >1; [0,1]; and [0,1]
  tparf <- function(par) c(exp(par[1]) + 1,  pnorm( par[2] ), pnorm( par[3] ))
  rparf <- function(par) c(log(par[1]  - 1), qnorm( par[2] ), qnorm( par[3] ))

  ofunc <- function(par, norho=FALSE, usetrans=FALSE) { # objective function
    if(usetrans) { mypara <- tparf(par) } else { mypara <- par }
    rhoT   <- rhoCOP(cop=GHcop, para=mypara)    # simulated Spearman Rho
    infT   <- LzCOPpermsym(cop=GHcop, para=mypara, n=nsim, type="halton",
                           as.vec=as.vec)
    err    <-    mean( (infT - infS)^2 )        # mean squared errors
    ifelse(norho, err, (rhoT - rhoS)^2 + err)   # with Spearman Rho or not
  } # norho and usetrans are unaccessible for metaOpt() call to come later
  # ofunc defaults are chosen to keep us from writing two objective functions

  init.par <- c(2, 0.5, 0.5) # initial parameters in real space
  tnit.par <- rparf(init.par); rt <- NULL # initial parameter guess
  try(  rt <- optim(tnit.par, ofunc, norho=FALSE, usetrans=TRUE) )
  # 3D optimization with unbounded parameters using transformation.
  if(is.null(rt)) stop("fatal, optim() returned NULL")
  # construct GHcop parameters from optimization with re-transformation
  sara <- tparf(rt$par)
  rhoT <- rhoCOP(cop=GHcop, para=sara)          # theoretical Spearman Rho
  UVsT <- simCOP(cop=GHcop, para=sara, n=nsam, seed=seed,  # same seed sim by
                 cex=0.3, pch=16, col="red", ploton=FALSE) # est. parameters
  # maximum likelihood
  mara <- mleCOP(UVsS, cop=GHcop, init.para=tnit.par, parafn=tparf)$para

  # metaheuristic methods follow and need lower and upper parameter bounds
  lb <- c(1, 0, 0); ub <- c(100, 1, 1)  # lower and upper parameter bounds
  # Artificial Bee Colony optimization
  # https://en.wikipedia.org/wiki/Artificial_bee_colony_algorithm
  be <- ABCoptim::abc_optim(init.par, ofunc, norho=FALSE, lb=lb, ub=ub)
  sara_bee <- be$par
  # Particle Swarm optimization
  # https://en.wikipedia.org/wiki/Particle_swarm_optimization
  ps <- pso::psoptim(init.par, ofunc, norho=FALSE,  lower=lb, upper=ub)
  sara_pso <- ps$par

  # Genetic Algorithm optimization
  # https://en.wikipedia.org/wiki/Genetic_algorithm
  rngv <- matrix(c(lb, ub), nrow=2, byrow=TRUE)
  ctrl <- list(numPopulation=30) # fairly slow running, so 30 for speed
  mo   <- metaheuristicOpt::metaOpt(ofunc, algorithm="GA",
                             numVar=3, rangeVar=rngv, control=ctrl)
  sara_alt <- mo$result

  level.curvesCOP(cop=GHcop, para=para)
  level.curvesCOP(cop=GHcop, para=mara,     ploton=FALSE, col="blue"    )
  level.curvesCOP(cop=GHcop, para=sara,     ploton=FALSE, col="red"     )
  level.curvesCOP(cop=GHcop, para=sara_bee, ploton=FALSE, col="orchid3" )
  level.curvesCOP(cop=GHcop, para=sara_pso, ploton=FALSE, col="seagreen")
  level.curvesCOP(cop=GHcop, para=sara_alt, ploton=FALSE, col="wheat"   )

Comparison of level curves between the known parent, the parameter estimation using function LzCOPpermsym, and the maximum likelihood by mleCOP shows that signed asymmetry differences can be used for parameter estimation. One could use the maximum as in the definition, but for purposes of high-dimensional optimization, using the vector might be better to prevent local minima (less optimal solutions) being found if the \mu_\infty^{\mathrm{permsym}} was used. Because vectors of differences between empirical copula and the fitted copula are involved, measures of fit using such differences are expected to be more favorable to optimization than using LzCOPpermsym than perhaps maximum likelihood. Some measures of fit like RMSE (rmseCOP), for example, are often, smaller for the sara fitted parameters than for the mara fitted (maximum likelihood). The maximum likelihood approach should favor towards smaller AIC (aicCOP) and BIC (bicCOP). Finally, setting as.vec <- FALSE, re-running, and thus using \mu_\infty^{\mathrm{permsym}}, will likely show parameter estimates, visible through the level curves, that are much less favorable.

  n <- 1E6; nm <- c("Parent", "MLE", "SARA", "ABC", "PSO", "GA")
  AIC <- c(aicCOP(UVsS, cop=GHcop, para=para    ),
           aicCOP(UVsS, cop=GHcop, para=mara    ),
           aicCOP(UVsS, cop=GHcop, para=sara    ),
           aicCOP(UVsS, cop=GHcop, para=sara_bee),
           aicCOP(UVsS, cop=GHcop, para=sara_pso),
           aicCOP(UVsS, cop=GHcop, para=sara_alt))
  RHO <- c(rhoCOP(      cop=GHcop, para=para    ),
           rhoCOP(      cop=GHcop, para=mara    ),
           rhoCOP(      cop=GHcop, para=sara    ),
           rhoCOP(      cop=GHcop, para=sara_bee),
           rhoCOP(      cop=GHcop, para=sara_pso),
           rhoCOP(      cop=GHcop, para=sara_alt)); names(RHO) <- nm
  LZP <- c(LzCOPpermsym(cop=GHcop, para=para,     n=n, type="halton"),
           LzCOPpermsym(cop=GHcop, para=mara,     n=n, type="halton"),
           LzCOPpermsym(cop=GHcop, para=sara,     n=n, type="halton"),
           LzCOPpermsym(cop=GHcop, para=sara_bee, n=n, type="halton"),
           LzCOPpermsym(cop=GHcop, para=sara_pso, n=n, type="halton"),
           LzCOPpermsym(cop=GHcop, para=sara_alt, n=n, type="halton"))
  names(AIC) <- nm; names(RHO) <- nm; names(LZP) <- nm
  print(AIC)
  print(RHO)
  print(LZP) # approximate results are shown in the table below
  #         Parent       MLE      SARA       ABC       PSO        GA
  # AIC  -928.5670 -916.2741 -939.8767 -939.8861 -939.8860 -937.8460
  # RHO  0.6132539 0.5433072 0.6058879 0.6058639 0.6058639 0.6058761
  # LZP  0.1076471 0.1000950 0.1186881 0.1187269 0.1187269 0.1211495

Value

A scalar value for the measure is returned or other as dictated by arguments.

Author(s)

W.H. Asquith

References

De Baets, B., and De Meyer, H., 2017, Chapter 3—A look at copulas in a curved mirror: New York, Springer, ISBN 978–3–319–64221–5, pp. 33–47.

See Also

LpCOPpermsym, isCOP.permsym

Examples

LzCOPpermsym(cop=PSP)                            # 0, permutation symmetric
LzCOPpermsym(cop=GHcop, para=c(10, 0.9, 0.3))    # 0.17722861

# See also results of
# isCOP.permsym(cop=PSP)                         # TRUE
# isCOP.permsym(cop=GHcop, para=c(10, 0.9, 0.3)) # FALSE

## Not run: 
  sapply(1:4, function(r) { # Four rotations of a Galambos copula
    Lz <- LzCOPpermsym(cop=COP, para=list(cop=GLcop, para=2, reflect=r))
    UV <- simCOP(1000, cop=COP, para=list(cop=GLcop, para=2, reflect=r))
    mtext(paste0("Reflection ", r, " : Permutation-Mu =", Lz)); Lz })
  # [1] 0.00000000 0.00000000 0.07430326 0.07430326 
## End(Not run)

The Fréchet–Hoeffding Upper-Bound Copula

Description

Compute the Fréchet–Hoeffding upper-bound copula (Nelsen, 2006, p. 11), which is defined as

\mathbf{M}(u,v) = \mathrm{min}(u,v)\mbox{.}

This is the copula of perfect association (comonotonicity, perfectly positive dependence) between U and V and is sometimes referred to as the comonotonicity copula. Its opposite is the \mathbf{W}(u,v) copula (countermonotonicity copula; W), and statistical independence is the \mathbf{\Pi}(u,v) copula (P).

Usage

M(u, v, ...)

Arguments

Value

Value(s) for the copula are returned.

Author(s)

W.H. Asquith

References

Nelsen, R.B., 2006, An introduction to copulas: New York, Springer, 269 p.

See Also

W, P

Examples

M(0.4,0.6)
M(0,0)
M(1,1)

Shuffles of Upper-Bound Copula, Example 5.12b of Nelsen's Book

Description

Compute shuffles of Fréchet–Hoeffding upper-bound copula (Nelsen, 2006, p. 173), which is defined by partitioning \mathbf{M} within \mathcal{I}^2 into n subintervals:

\mathbf{M}_n(u,v) = \mathrm{min}\biggl(u-\frac{k-1}{n}, v-\frac{n-k}{n} \biggr)

for points within the partitions

(u,v) \in \biggl[\frac{k-1}{n}, \frac{k}{n}\biggr]\times \biggl[ \frac{n-k}{n}, \frac{n-k+1}{n}\biggr]\mbox{,\ }k = 1,2,\cdots,n

and for points otherwise out side the partitions

\mathbf{M}_n(u,v) = \mathrm{max}(u+v-1,0)\mbox{.}

The support of \mathbf{M}_n consists of n line segments connecting coordinate pairs \{(k-1)/n,\, (n-k)/n\} and \{k/n,\, (n-k+1)/n\} as stated by Nelsen (2006). It is useful that Nelsen stated such as this helps to identify that Nelsen's typesetting of the terms in the second square brackets—the V direction—is reversed from that shown in this documentation. The Spearman Rho (rhoCOP) is defined by \rho_\mathbf{C} = (2/n^2) - 1, and the Kendall Tau (tauCOP) by \tau_\mathbf{C} = (2/n) - 1.

Usage

M_N5p12b(u, v, para=1, ...)

Arguments

Value

Value(s) for the copula are returned.

Author(s)

W.H. Asquith

References

Nelsen, R.B., 2006, An introduction to copulas: New York, Springer, 269 p.

See Also

M, ORDSUMcop, W_N5p12a

Examples

M_N5p12b(0.4, 0.6, para=3)

## Not run: 
  # Nelsen (2006, exer. 5.12b, p. 173, fig. 5.3b)
  UV <- simCOP(1000, cop=M_N5p12b, para=4) #
## End(Not run)

The Copula of Equation 4.2.12 of Nelsen's Book

Description

The N4212 copula (Nelsen, 2006, p. 91; eq. 4.2.12) is named by the author (Asquith) for the copBasic package and is defined as

\mathbf{C}_{\mathrm{N4212}}(u,v; \Theta) = \biggl(1 + \bigl[(u^{-1} -1)^\Theta + (v^{-1} -1)^\Theta\bigr]^{1/\Theta}\biggr)^{-1}\mbox{.}

The \mathbf{N4212}(u,v) copula is not comprehensive because for \Theta = 1 the copula becomes the so-called \mathbf{PSP}(u,v) copula (see PSP) and as \Theta \rightarrow \infty the copula becomes \mathbf{M}(u,v) (see M). The copula is undefined for \Theta < 1. The N4212 copula has respective lower- and upper-tail dependency (see taildepCOP).

Although copBasic is intended to not implement or “store house” the enormous suite of copula functions available in the literature, the N4212 copula is included to give the package another copula to test or test in numerical examples.

Usage

N4212cop(u, v, para=NULL, infis=100, ...)

Arguments

Value

Value(s) for the copula are returned.

Author(s)

W.H. Asquith

References

Nelsen, R.B., 2006, An introduction to copulas: New York, Springer, 269 p.

Examples

N4212cop(0.4,0.6, para=1) == PSP(0.4,0.6) # TRUE
N4212cop(0.4,0.6, para=10) # 0.3999928
taildepCOP(cop=N4212cop, para=10) # LamL = 0.93303; LamU = 0.92823
## Not run: 
D <- simCOP(n=400, cop=N4212cop, para=2)
D <- simCOP(n=400, cop=N4212cop, para=10,  ploton=FALSE, col=2)
D <- simCOP(n=400, cop=N4212cop, para=100, ploton=FALSE, col=3)#
## End(Not run)

Ordinal Sums of M-Copula

Description

Compute ordinal sums of a copula (Nelsen, 2006, p. 63) or M-ordinal sum of the summands (Klement et al., 2017) within \mathcal{I}^2 into n partitions (possibly infinite) within \mathcal{I}^2. According to Nelsen, letting \mathcal{J} denote a partition of \mathcal{I}^2 and \mathcal{J}_i = [a_i,\, b_i] be the ith partition that does not overlap with others and letting also \mathbf{C}_i be a copula for the ith partition, then the ordinal sum of these \mathbf{C}_i with parameters \Theta_i with respect to \mathcal{J}_i is the copula \mathbf{C} given by

\mathbf{C}\bigl(u,v; \mathcal{J}_i, \mathbf{C}_i, \Theta_i, i \in 1,2,\cdots,n\bigr) = a_i + (b_i-a_i)\mathbf{C}_i\biggl(\frac{u-a_i}{b_i-a_i},\, \frac{v-a_i}{b_i-a_i}; \Theta_i\biggr)\ \mbox{for}\ (u,v) \in \mathcal{J}^2\mbox{,}

for points within the partitions, and for points otherwise outside the partitions the coupla is given by

\mathbf{C}\bigl(u,v; \mathcal{J}_i, \mathbf{C}_i, i \in 1,2,\cdots,n\bigr) = \mathbf{M}(u,v)\ \mathrm{for}\ (u,v) \ni \mathcal{J}^2\mbox{, and}

let \mathbf{C}_\mathcal{J}(u,v) be a convenient abbreviation for the copula. Finally, Nelsen (2006, theorem 3.2.1) states that a copula is an ordinal sum if and only if for a t if \mathbf{C}(t,t)=t for t \in (0,1). The diagonal of a coupla can be useful for quick assessment (see Examples) of this theorem. (See ORDSUWcop, W-ordinal sum of the summands.)

Usage

ORDSUMcop(u,v, para=list(cop=W, para=NA, part=c(0,1)), ...)

Arguments

Value

Value(s) for the copula are returned.

Author(s)

W.H. Asquith

References

Nelsen, R.B., 2006, An introduction to copulas: New York, Springer, 269 p.

Klement, E.P., Kolesárová, A., Mesiar, R., Saminger-Platz, S., 2017, Copula constructions using ultramodularity (chap. 9) in Copulas and dependence models with applications—Contributions in honor of Roger B. Nelsen, eds. Flores, U.M., Amo Artero, E., Durante, F., Sánchez, J.F.: Springer, Cham, Switzerland, ISBN 978–3–319–64220–9, doi:10.1007/978-3-319-64221-5.

See Also

copBasic-package, W_N5p12a, ORDSUWcop

Examples

## Not run: 
  para <- list(cop=c(CLcop, M, PLcop, GHcop), para=list(4, NA, 0.1, c(3,4)),
              part=list(c(0,0.25), c(0.25,0.35), c(0.35,0.85), c(0.85,1)))
  UV <- simCOP(n=100, cop=ORDSUMcop, para=para, ploton=FALSE)
  plot(c(0,1), c(0,1), xlab="U, NONEXCEEDANCE PROBABILITY", type="n",
                       ylab="V, NONEXCEEDANCE PROBABILITY")
  for(k in seq_len(length(para$part))) {         #  to draw the partitions
    a <- para$part[[k]][1]; b <- para$part[[k]][2]
    polygon(c(a, b, b, a, a), c(a,a,b,b,a), lty=2, lwd=0.8, col="lightgreen")
    text((a+b)/2, (a+b)/2, k, cex=3, col="blue") # numbered by partition
  }
  points(UV, pch=21, cex=0.8, col=grey(0.1), bg="white") #
## End(Not run)

## Not run: 
  para <- list(cop=c(GHcop), para=list(c(2,3)), # internally replicated
               part=list(c(0,0.2), c(0.2,0.3), c(0.3,0.5), c(0.5,0.7), c(0.7,1)))
  UV <- simCOP(n=100, cop=ORDSUMcop, para=para, ploton=FALSE)
  plot(c(0,1), c(0,1), xlab="U, NONEXCEEDANCE PROBABILITY", type="n",
                       ylab="V, NONEXCEEDANCE PROBABILITY")
  for(k in seq_len(length(para$part))) {         #  to draw the partitions
    a <- para$part[[k]][1]; b <- para$part[[k]][2]
    polygon(c(a, b, b, a, a), c(a,a,b,b,a), lty=2, lwd=0.8, col="lightgreen")
    text((a+b)/2, (a+b)/2, k, cex=3, col="blue") # numbered by partition
  }
 points(UV, pch=21, cex=0.8, col=grey(0.1), bg="white") #
## End(Not run)

## Not run: 
  # In this example, it is important that the delt is of the resolution
  # matching the  edges of the partitions.
  para <- list(cop=P, para=list(NULL),
               part=list(c(0,0.257), c(0.257,0.358), c(0.358,1)))
  DI <- diagCOP(cop=ORDSUMcop, para=para, delt=0.001)
  if(sum(DI$diagcop == DI$t) >= 1) {
    message("The ORDSUMcop() operation is an ordinal sum if there exists\n",
            "a t=(0,1) exists such that C(t,t)=t by Nelsen (2006, theorem 3.2.1).")
  }
  abline(0,1, col="red") #
## End(Not run)

Ordinal Sums of W-Copula

Description

Compute W-ordinal sum of the summands (Klement et al., 2017) within \mathcal{I}^2 into n partitions (possibly infinite) within \mathcal{I}^2. Letting \mathcal{J} denote a partition of \mathcal{I}^2 and \mathcal{J}_i = [a_i,\, b_i] be the ith partition that does not overlap with others and letting also \mathbf{C}_i be a copula for the ith partition, then the ordinal sum of these \mathbf{C}_i with parameters \Theta_i with respect to \mathcal{J}_i is the copula \mathbf{C} given by

\mathbf{C}\bigl(u,v; \mathcal{J}_i, \mathbf{C}_i, \Theta_i, i \in 1,2,\cdots,n\bigr) = a_i + (b_i-a_i)\mathbf{C}_i\biggl(\frac{u-a_i}{b_i-a_i},\, \frac{v-1+b_i}{b_i-a_i}; \Theta_i\biggr)\ \mbox{for}\ (u,v) \in \mathcal{J}^2\mbox{,}

for points within the partitions, and for points otherwise outside the partitions the coupla is given by

\mathbf{C}\bigl(u,v; \mathcal{J}_i, \mathbf{C}_i, i \in 1,2,\cdots,n\bigr) = \mathbf{W}(u,v)\ \mathrm{for}\ (u,v) \ni \mathcal{J}^2\mbox{, and}

let \mathbf{C}_\mathcal{J}(u,v) be a convenient abbreviation for the copula. (See ORDSUMcop, M-ordinal sum of the summands.)

Usage

ORDSUWcop(u,v, para=list(cop=M, para=NA, part=c(0,1)), ...)

Arguments

Value

Value(s) for the copula are returned.

Author(s)

W.H. Asquith

References

Klement, E.P., Kolesárová, A., Mesiar, R., Saminger-Platz, S., 2017, Copula constructions using ultramodularity (chap. 9) in Copulas and dependence models with applications—Contributions in honor of Roger B. Nelsen, eds. Flores, U.M., Amo Artero, E., Durante, F., Sánchez, J.F.: Springer, Cham, Switzerland, ISBN 978–3–319–64220–9, doi:10.1007/978-3-319-64221-5.

See Also

copBasic-package, W_N5p12a, ORDSUMcop

Examples

para <- list(cop=c(CLcop, GHcop), para=list(5, 2), part=c(0,0.25,1)) # break points
UV <- simCOP(n=100, cop=ORDSUMcop, seed=1, para=para, ploton=TRUE, pch=16)
UV <- simCOP(n=100, cop=ORDSUWcop, seed=1, para=para, ploton=FALSE)

## Not run: 
  para <- list(cop=c(CLcop, M, PLcop, GHcop), para=list(4, NA, 0.1, c(3,4)),
              part=list(c(0,0.25), c(0.25,0.35), c(0.35,0.85), c(0.85,1)))
  UV <- simCOP(n=100, cop=ORDSUWcop, para=para, ploton=FALSE)
  plot(c(0,1), c(0,1), xlab="U, NONEXCEEDANCE PROBABILITY", type="n",
                       ylab="V, NONEXCEEDANCE PROBABILITY")
  for(k in seq_len(length(para$part))) {         #  to draw the partitions
    a <- para$part[[k]][1]; b <- para$part[[k]][2]
    polygon(c(a, b, b, a, a), c(1-a,1-a,1-b,1-b,1-a), lty=2, lwd=0.8, col="lightgreen")
    text((a+b)/2, (1-a+1-b)/2, k, cex=3, col="blue") # numbered by partition
  }
  points(UV, pch=21, cex=0.8, col=grey(0.1), bg="white") #
## End(Not run)

## Not run: 
  para = list(cop=c(GHcop), para=list(c(2,3)), # internally replicated
              part=list(c(0,0.2), c(0.2,0.3), c(0.3,0.5), c(0.5,0.7), c(0.7,1)))
  UV <- simCOP(n=100, cop=ORDSUWcop, para=para, ploton=FALSE)
  plot(c(0,1), c(0,1), xlab="U, NONEXCEEDANCE PROBABILITY", type="n",
                       ylab="V, NONEXCEEDANCE PROBABILITY")
  for(k in seq_len(length(para$part))) {         #  to draw the partitions
    a <- para$part[[k]][1]; b <- para$part[[k]][2]
    polygon(c(a, b, b, a, a), c(1-a,1-a,1-b,1-b,1-a), lty=2, lwd=0.8, col="lightgreen")
    text((a+b)/2, (1-a+1-b)/2, k, cex=3, col="blue") # numbered by partition
  }
  points(UV, pch=21, cex=0.8, col=grey(0.1), bg="white") #
## End(Not run)

The Product (Independence) Copula

Description

Compute the product copula (Nelsen, 2006, p. 12), which is defined as

\mathbf{\Pi}(u,v) = uv\mbox{.}

This is the copula of statistical independence between U and V and is sometimes referred to as the independence copula. The two extreme antithesis copulas are the Fréchet–Hoeffding upper-bound (M) and Fréchet–Hoeffding lower-bound (W) copulas.

Usage

P(u, v, ...)

Arguments

Value

Value(s) for the copula are returned.

Author(s)

W.H. Asquith

References

Nelsen, R.B., 2006, An introduction to copulas: New York, Springer, 269 p.

See Also

M, W, rhoCOP

Examples

P(c(0.4, 0, 1), c(0, 0.6, 1))

## Not run: 
n <- 100000 # giant sample size, L-comoments are zero
# PERFECT INDEPENDENCE
UV <- simCOP(n=n, cop=P, graphics=FALSE)
lmomco::lcomoms2(UV, nmom=4)
# The following are Taus_r^{12} and Taus_r^{21}
# L-corr:        0.00265 and  0.00264 ---> ZERO
# L-coskew:     -0.00121 and  0.00359 ---> ZERO
# L-cokurtosis:  0.00123 and  0.00262 ---> ZERO

# MODEST POSITIVE CORRELATION
rho <- 0.6; # Spearman Rho
theta <- PLACKETTpar(rho=rho) # Theta = 5.115658
UV <- simCOP(n=n, cop=PLACKETTcop, para=theta, graphics=FALSE)
lmomco::lcomoms2(UV, nmom=4)
# The following are Taus_r^{12} and Taus_r^{21}
# L-corr        0.50136 and  0.50138 ---> Pearson R == Spearman Rho
# L-coskews    -0.00641 and -0.00347 ---> ZERO
# L-cokurtosis -0.00153 and  0.00046 ---> ZERO 
## End(Not run)

The Pareto Copula

Description

The Pareto copula (Nelsen, 2006, pp. 33) is

\mathbf{C}_{\Theta}(u,v) = \mathbf{PA}(u,v) = \bigl[(1-u)^{-\Theta}+(1-v)^{-\Theta}\bigr]^{-1/\Theta}\mbox{,}

where \Theta \in [0, \infty). As \Theta \rightarrow 0^{+}, the copula limits to the \mathbf{\Pi} copula (P) and the \mathbf{M} copula (M). The parameterization here has assocation increasing with increasing \Theta, which differs from Nelsen (2006), and also the Pareto copula is formed with right-tail increasing reflection of the Nelsen (2006) presentation because it is anticipated that copBasic users are more likely to have right-tail dependency situations (say large maxima [right tail] coupling in earth-system data but not small maxima [left tail] coupling).

Usage

PARETOcop(u, v, para=NULL, ...)
    PAcop(u, v, para=NULL, ...)

Arguments

Value

Value(s) for the copula are returned.

Note

The Pareto copula is used in a demonstration of Kendall Function L-moment ratio diagram construction (see kfuncCOPlmoms).

Author(s)

W.H. Asquith

References

Nelsen, R.B., 2006, An introduction to copulas: New York, Springer, 269 p.

See Also

M, P

Examples

## Not run: 
z <- seq(0.01,0.99, by=0.01) # Both copulas have Kendall Tau = 1/3
plot( z, kfuncCOP(z, cop=PAcop, para=1), lwd=2, col="black",
                                xlab="z <= Z", ylab="F_K(z)", type="l")
lines(z, kfuncCOP(z, cop=GHcop, para=1.5), lwd=2, col="red") # red line
# All extreme value copulas have the same Kendall Function [F_K(z)], the
# Gumbel-Hougaard is such a copula and the F_K(z) for the Pareto does not
# plot on top and thus is not an extreme value but shares a "closeness."
## End(Not run)

The Plackett Copula

Description

The Plackett copula (Nelsen, 2006, pp. 89–92) is

\mathbf{C}_\Theta(u,v) = \mathbf{PL}(u,v) = \frac{[1+(\Theta-1)(u+v)]-\sqrt{[1+(\Theta-1)(u+v)]^2 - 4uv\Theta(\Theta-1)}}{2(\Theta - 1)}\mbox{.}

The Plackett copula (\mathbf{PL}(u,v)) is comprehensive because as \Theta \rightarrow 0 the copula becomes \mathbf{W}(u,v) (see W, countermonotonicity), as \Theta \rightarrow \infty the copula becomes \mathbf{M}(u,v) (see M, comonotonicity) and for \Theta = 1 the copula is \mathbf{\Pi}(u,v) (see P, independence).

Nelsen (2006, p. 90) shows that

\Theta = \frac{H(x,y)[1 - F(x) - G(y) + H(x,y)]}{[F(x) - H(x,y)][G(y) - H(x,y)]}\mbox{,}

where F(x) and G(y) are cumulative distribution function for random variables X and Y, respectively, and H(x,y) is the joint distribution function. Only Plackett copulas have a constant \Theta for any pair \{x,y\}. Hence, Plackett copulas are also known as constant global cross ratio or contingency-type distributions. The copula therefore is intimately tied to contingency tables and in particular the bivariate Plackett defined herein is tied to a 2\times2 contingency table. Consider the 2\times 2 contingency table shown at the end of this section, then \Theta is defined as

\Theta = \frac{a/c}{b/d} = \frac{\frac{a}{a+c}/\frac{c}{a+c}}{\frac{b}{b+d}/\frac{d}{b+d}}\mbox{\ and\ }\Theta = \frac{a/b}{c/d} = \frac{\frac{a}{a+b}/\frac{b}{a+b}}{\frac{c}{c+d}/\frac{d}{c+d}}\mbox{,}

where it is obvious that \Theta = ad/bc and a, b, c, and d can be replaced by proporations for a sample of size n by a/n, b/n, c/n, and d/n, respectively. Finally, this copula has been widely used in modeling and as an alternative to bivariate distributions and has respective lower- and upper-tail dependency parameters of \lambda^L = 0 and \lambda^U = 0 (taildepCOP).

Usage

PLACKETTcop(u, v, para=NULL, ...)
      PLcop(u, v, para=NULL, ...)

Arguments

Value

Value(s) for the copula are returned.

Note

The Plackett copula was the first (2008) copula implemented in copBasic as part of initial development of the code base for instructional purposes. Thus, this particular copula has a separate parameter estimation function in PLACKETTpar as a historical vestige of a class project.

Author(s)

W.H. Asquith

References

Joe, H., 2014, Dependence modeling with copulas: Boca Raton, CRC Press, 462 p.

Nelsen, R.B., 2006, An introduction to copulas: New York, Springer, 269 p.

See Also

PLACKETTpar, PLpar, PLACKETTsim, W, M, densityCOP

Examples

PLACKETTcop(0.4, 0.6, para=1)
P(0.4, 0.6) # independence copula, same two values because Theta == 1
PLcop(0.4, 0.6, para=10.25) # joint probability through positive association

## Not run: 
# Joe (2014, p. 164) shows the closed form copula density of the Plackett.
"dPLACKETTcop" <- function(u,v,para) {
   eta <- para - 1; A <- para*(1 + eta*(u+v-2*u*v))
   B <- ((1 + eta*(u+v))^2 - 4*para*eta*u*v)^(3/2); return(A/B)
}
u <- 0.08; v <- 0.67 # Two probabilities to make numerical evaluations.
del <- 0.0001 # a 'small' differential value of probability
u1 <- u; u2 <- u+del; v1 <- v; v2 <- v+del
# Density following (Nelsen, 2006, p. 10)
dCrect <- (PLcop(u2, v2, para=10.25) - PLcop(u2, v1, para=10.25) -
           PLcop(u1, v2, para=10.25) + PLcop(u1, v1, para=10.25)) / del^2
dCanal <- dPLACKETTcop(u, v, para=10.25)
dCfunc <-   densityCOP(u, v, para=10.25, cop=PLcop, deluv = del)
R <- round(c(dCrect, dCanal, dCfunc), digits=6)
message("Density: ", R[1], "(manual), ", R[2], "(analytical), ", R[3], "(function)");
# Density: 0.255377(manual), 0.255373(analytical), 0.255377(function)

# Comparison of partial derivatives
dUr <- (PLcop(u2, v2, para=10.25) - PLcop(u1, v2, para=10.25)) / del
dVr <- (PLcop(u2, v2, para=10.25) - PLcop(u2, v1, para=10.25)) / del
dU  <- derCOP( u, v, cop=PLcop, para=10.25)
dV  <- derCOP2(u, v, cop=PLcop, para=10.25)
R   <- round(c(dU, dV, dUr, dVr), digits=6)
message("Partial derivatives dU=", R[1], " and dUr=", R[3], "\n",
        "                    dV=", R[2], " and dVr=", R[4]) #
## End(Not run)

Estimate the Parameter of the Plackett Copula

Description

The parameter \Theta of the Plackett copula (Nelsen, 2006, pp. 89–92) (PLACKETTcop or PLcop) is related to the Spearman Rho (\rho_S \ne 1, see rhoCOP)

\rho_S(\Theta) = \frac{\Theta + 1}{\Theta - 1} - \frac{2\Theta\log(\Theta)}{(\Theta - 1)^2}\mbox{.}

Alternatively, the parameter can be estimated using a median-split estimator, which is best shown as an algorithm. First, compute the two medians:

  medx <- median(x); medy <- median(y)

Second and third, compute the number of occurrences where both values are less than their medians and express that as a probability:

  k <- length(x[x < medx & y < medy]); m <- k / length(x)

Finally, the median-split estimator of \Theta is computed by

\Theta = \frac{4m^2}{(1-2m)^2}\mbox{.}

Nelsen (2006, p. 92) and Salvadori et al. (2007, p. 247) provide further details. The input values x and y are not used for the median-split estimator if Spearman Rho (see rhoCOP) is provided by rho.

Usage

PLACKETTpar(x, y, rho=NULL, byrho=FALSE, cor=NULL, ...)
      PLpar(x, y, rho=NULL, byrho=FALSE, cor=NULL, ...)

Arguments

Value

A value for the Plackett copula \Theta is returned.

Note

Evidently there “does not appear to be a closed form for \tau(\Theta)” (Fredricks and Nelsen, 2007, p. 2147), but given \rho(\Theta), the equivalent \tau(\Theta) can be computed by either the tauCOP function or by approximation. One of the Examples sweeps through \rho \mapsto [0,1; \Delta\rho{=}\delta], fits the Plackett \theta(\rho), and then solves for Kendall Tau \tau(\theta) using tauCOP. A polynomial is then fit between \tau and \rho to provide rapid conversion between |\rho| and \tau, where the residual standard error is 0.0005705, adjusted R-squared is \approx 1, the maximum residual is \epsilon < 0.006. Because of symmetry, it is only necessary to fit positive association and reflect the result by the sign of \rho. This polynomial is from the Examples is

  rho <- 0.920698
  "getPLACKETTtau" <- function(rho) {
     taupoly <-   0.6229945*abs(rho)   +   1.1621854*abs(rho)^2 -
                 10.7424188*abs(rho)^3 +  48.9687845*abs(rho)^4 -
                119.0640264*abs(rho)^5 + 160.0438496*abs(rho)^6 -
                111.8403591*abs(rho)^7 +  31.8054602*abs(rho)^8
     return(sign(rho)*taupoly)
  }
  getPLACKETTtau(rho) # 0.7777726

The following code might be useful in some applications for the inversion of the polynomial for the \rho as a function of \tau:

  "fun" <- function(rho, tau=NULL) {tp <- getPLACKETTtau(rho); return(tau-tp)}
   tau  <- 0.78
   rho  <- uniroot(fun, interval=c(0, 1), tau=tau)$root # 0.9220636

Author(s)

W.H. Asquith

References

Fredricks, G.A, and Nelsen, R.B., 2007, On the relationship between Spearman's rho and Kendall's tau for pairs of continuous random variables: Journal of Statistical Planning and Inference, v. 137, pp. 2143–2150.

Nelsen, R.B., 2006, An introduction to copulas: New York, Springer, 269 p.

Salvadori, G., De Michele, C., Kottegoda, N.T., and Rosso, R., 2007, Extremes in Nature—An approach using copulas: Springer, 289 p.

See Also

PLACKETTcop, PLcop, PLACKETTsim, rhoCOP

Examples

## Not run: 
Q1 <- rnorm(1000); Q2 <- Q1 + rnorm(1000)
PLpar(Q1, Q2); PLpar(Q1, Q2, byrho=TRUE) # two estimates for same data
PLpar(rho= 0.76) # positive association
PLpar(rho=-0.76) # negative association
tauCOP(cop=PLcop, para=PLpar(rho=-0.15, by.rho=TRUE)) #
## End(Not run)

## Not run: 
RHOS <- seq(0, 0.990, by=0.002); TAUS <- rep(NA, length(RHOS))
for(i in 1:length(RHOS)) {
   #message("Spearman Rho: ", RHOS[i])
   theta <- PLACKETTpar(rho=RHOS[i], by.rho=TRUE); tau <- NA
   try(tau <- tauCOP(cop=PLACKETTcop, para=theta), silent=TRUE)
   TAUS[i] <- ifelse(is.null(tau), NA, tau)
}
LM <- lm(TAUS~  RHOS    + I(RHOS^2) + I(RHOS^3) + I(RHOS^4) +
              I(RHOS^5) + I(RHOS^6) + I(RHOS^7) + I(RHOS^8) - 1)
plot(RHOS,TAUS, type="l", xlab="abs(Spearman Rho)", ylab="abs(Kendall Tau)")
lines(RHOS,fitted.values(LM), col=3)#
## End(Not run)

Direct Simulation of a Plackett Copula

Description

Plackett copula simulation (Nelsen, 2006, pp. 89–92) (PLACKETTcop) is made by this function using analytical formula (Durante, 2007, p. 247; see source code). The PLACKETTsim function exists for comparison against the numerical derivative (conditional distribution method) methods (simCOP, simCOPmicro) otherwise used in copBasic.

Usage

PLACKETTsim(n, para=NULL, ...)

Arguments

Value

An R data.frame of the values U and V for the nonexceedance probabilities is returned.

Author(s)

W.H. Asquith

References

Durante, F., 2007, Families of copulas, Appendix C, in Salvadori, G., De Michele, C., Kottegoda, N.T., and Rosso, R., 2007, Extremes in Nature—An approach using copulas: Springer, 289 p.

Nelsen, R.B., 2006, An introduction to copulas: New York, Springer, 269 p.

See Also

PLACKETTcop, PLACKETTpar

Examples

PLACKETTsim(10, para= 1  ) # simulate P (independence) copula through a Plackett
PLACKETTsim(10, para=20.3) # simulate strong positive Plackett

The Ratio of the Product Copula to Summation minus Product Copula

Description

Compute PSP copula (Nelsen, 2006, p. 23) is named by the author (Asquith) for the copBasic package and is

\mathbf{PSP}(u,v) = \frac{\mathbf{\Pi}}{\mathbf{\Sigma} - \mathbf{\Pi}} = \frac{uv}{u + v - uv}\mbox{,}

where \mathbf{\Pi} is the indpendence or product copula (P) and \mathbf{\Sigma} is the sum \mathbf{\Sigma} = u + v. The \mathbf{PSP}(u,v) copula is a special case of the \mathbf{N4212}(u,v) copula (N4212cop). The \mathbf{PSP} is included in copBasic because of its simplicity and for pedagogical purposes. The name “PSP” comes from “Product, Summation, Product” to loosely reflect the mathematical formula shown. Nelsen (2006, p. 114) notes that the PSP copula shows up in several families and designates it as “\mathbf{\Pi}/(\mathbf{\Sigma}-\mathbf{\Pi}).” The PSP is undefined for u = v = 0 but no internal trapping is made; calling functions will have to intercept the NaN so produced for \{0, 0\}. The \mathbf{PSP} is left internally untrapping NaN so as to be available to stress other copula utility functions within the copBasic package.

Usage

PSP(u, v, ...)

Arguments

Value

Value(s) for the copula are returned.

Author(s)

W.H. Asquith

References

Nelsen, R.B., 2006, An introduction to copulas: New York, Springer, 269 p.

See Also

P, N4212cop

Examples

PSP(0.4,0.6)
PSP(0,0)
PSP(1,1)

The Rayleigh Copula

Description

The Rayleigh copula (Boškoskia and others, 2018) is

\mathbf{C}_{\Theta}(u,v) = \mathbf{RAY}(u,v; \Theta) = 1 + A - B\mbox{,}

A = e^{\Theta a_2 - a_2}\biggl(e^{-a_1}\int_0^{\Theta a_2} e^{-s}I_0\bigl(2\sqrt{a_1 s}\bigr)\,\mathrm{d}s - 1\biggr)\,\mathrm{d}s\mbox{,}

B = e^{-a_1}\int_0^{a_2}e^{-s}I_0\bigl(2\sqrt{\Theta a_1 s}\bigr)\,\mathrm{d}s\mbox{,}

where a1 = -\log(1-u)/(1-\Theta), a2 = -\log(1-v)/(1-\Theta), I_\nu(x) is the modified Bessel function of the first kind of order \nu (see base::besselI()), and \Theta \in (0,1]. The copula, as \Theta \rightarrow 0^{+} limits, to the independence coupla (\mathbf{\Pi}(u,v); P) and as \Theta \rightarrow 1^{-} limits to the comonotonicity copula (\mathbf{M}(u,v); M). Finally, there are formulations of the Rayleigh copula using the Marcum-Q function, but the copBasic developer has not been able to make such work. If the Marcum-Q function could be used, then only one integration and not the two involving the modified Bessel function are possible. Infinite integrations begin occurring in the upper right corner for about \Theta > 0.995 at which point the \mathbf{M}(u,v) copula is called in the source code.

Usage

RAYcop(u, v, para=NULL, rho=NULL, method=c("default"),
             rel.tol=.Machine$double.eps^0.5, ...)

Arguments

Value

Value(s) for the copula are returned.

Note

Documentation in Zeng and others [Part II] appear to have corrected the Marcum-Q function solution to the copula. The essence of that solution is with a Chi-distribution computation the Marcum-Q. Testing indictates that they have the correct solution, but the derivative for the conditional simulation as built into the design of copBasic has difficulties. Perhaps this is related to numerical precision of the Marcum-Q?

  sapply(seq_len(length((u))), function(i) {
    a1 <- -log(1-u[i])
    if(is.infinite(a1)) return(v[i])
    a2 <- -log(1-v[i])
    if(is.infinite(a2)) return(u[i])
    a1 <- exp(log(a1) - log(1-p))
    a2 <- exp(log(a2) - log(1-p))
    a3 <- marcumq.chi(sqrt(2*  a1), sqrt(2*p*a2)) # Zeng and others (Part II)
    a4 <- marcumq.chi(sqrt(2*p*a1), sqrt(2*  a2)) # Zeng and others (Part II)
    zz <- 1 + (1-v[i])*a3 - (1-u[i])*(1-a4)       # Zeng and others (Part II)
    zz[zz < 0] <- 0
    zz[zz > 1] <- 1
    return(zz)
  })

Author(s)

W.H. Asquith

References

Boškoskia, P., Debenjaka, A., Boshkoskab, B.M., 2018, Rayleigh copula for describing impedance data with application to condition monitoring of proton exchange membrane fuel cells: European Journal of Operational Research, v. 266, pp. 269–277, doi:10.1016/j.ejor.2017.08.058.

Zeng, X., Ren, J., Wang, Z., Marshall, S., and Durrani, T., 2014, Copulas for statistical signal processing (Part I)—Extensions and generalization: Signal Processing v. 14, pp. 691–702, doi:10.1016/j.sigpro.2013.07.009.

Zeng, X., Ren, J., Sun, M., Marshall, S., and Durrani, T., 2014, Copulas for statistical signal processing (Part II)—Simulation, optimal selection and practical applications: Signal Processing, v. 94, pp. 681–690, doi:10.1016/j.sigpro.2013.07.006.

See Also

M, P

Examples

RAYcop(0.2, 0.8, para=0.8) # [1] 0.1994658  (by the dual Bessel functions)

RAYcop(0.8, 0.2, para=RAYcop(rho=rhoCOP(cop=RAYcop, para=0.8)))
# [1] 0.1994651 from polynomial conversion of Rho to Theta

## Not run: 
  # Recipe for assembling the Spearman Rho to Theta polynomial in sources.
  Thetas <- seq(0, 0.999, by=0.001); RHOs <- NULL
  for(p in Thetas)  RHOs <- c(RHOs, rhoCOP(cop=RAYcop, para=p))
  LM <- lm(Thetas ~ RHOs  + I(RHOs^2) + I(RHOs^4) + I(RHOs^6) - 1 )
  Rho2Theta <- function(rho) {
    coes <- c(1.32682824, -0.38876290, 0.09072305, -0.02921836)
    sapply(rho, function(r) coes[1]*r^1 + coes[2]*r^2 + coes[3]*r^4 + coes[4]*r^6)
  }
  plot(RHOs, Thetas, type="l", col=grey(0.8), lwd=12, lend=1,
       xlab="Spearman Rho", ylab="Rayleigh Copula Parameter Theta")
  lines(RHOs, Rho2Theta(RHOs), col="red", lwd=2) # 
## End(Not run)

The Raftery Copula

Description

The Raftery copula (Nelsen, 2006, p. 172) is

\mathbf{C}_{\Theta}(u,v) = \mathbf{RF}(u,v) = \mathbf{M}(u,v) + \frac{1-\Theta}{1+\Theta}\biggl(uv\biggr)^{1/(1-\Theta)}\biggl[1-\bigl(\mathrm{max}\{u,v\}\bigr)^{-(1+\Theta)/(1-\Theta)}\biggr]\mbox{,}

where \Theta \in (0,1). The copula, as \Theta \rightarrow 0^{+} limits, to the independence coupla (\mathbf{P}(u,v); P), and as \Theta \rightarrow 1^{-}, limits to the comonotonicity copula (\mathbf{M}(u,v); M). The parameter \Theta is readily computed from Spearman Rho (rhoCOP) by \rho_\mathbf{C} = \Theta(4-3\Theta)/(2-\Theta)^2 or from Kendall Tau (tauCOP) by \tau_\mathbf{C} = 2\Theta/(3-\Theta). However, this copula like others within the copBasic package can be reflected (rotated) at will with the COP abstraction layer to acquire negative or inverse dependency (countermonotonicity) (see the Examples).

Usage

RFcop(u, v, para=NULL, rho=NULL, tau=NULL, fit=c("rho", "tau"), ...)

Arguments

Value

Value(s) for the copula are returned. Otherwise if either rho or tau is given, then the \Theta is computed and a list having

and if para=NULL and rho and tau=NULL, then the values within u and v are used to compute Kendall Tau and then compute the parameter, and these are returned in the aforementioned list.

Author(s)

W.H. Asquith

References

Nelsen, R.B., 2006, An introduction to copulas: New York, Springer, 269 p.

See Also

M, P

Examples

# Lower tail dependency of Theta = 0.5 --> 2*(0.5)/(1+0.5) = 2/3 (Nelsen, 2006, p. 214)
taildepCOP(cop=RFcop, para=0.5)$lambdaL # 0.66667

## Not run: 
  # Simulate for a Spearman Rho of 0.7, then extract estimated Theta that internally
  # is based on Kendall Tau of U and V, then convert estimate to equivalent Rho.
  set.seed(1)
  UV <- simCOP(1000, cop=RFcop, RFcop(rho=0.7)$para)
  Theta <- RFcop(UV$U, UV$V, fit="tau")$para # 0.607544
  Rho   <- Theta*(4-3*Theta)/(2-Theta)^2     # 0.682255 (nearly 0.7) #
## End(Not run)

## Not run: 
  set.seed(1)
  UV <- simCOP(1000, cop=COP, para=list(cop=RFcop, para=RFcop(rho=0.5)$para, reflect=3))
  cor(UV$U, UV$V, method="spearman") # -0.492677 as expected with reversal of V #
## End(Not run)

Porosity and Permeability Data for Well-266 of the Reinecke Oil Field, Horseshoe Atoll, Texas

Description

These data represent porosity and permeability data from laboratory analysis for Well-266 Reinecke Oil Field, Horseshoe Atoll, Texas as used for the outstanding article by Saller and Dickson (2011). Dr. A.H. Saller shared a CSV file with the author of the copBasic package sometime in 2011. These data are included in this package because of the instruction potential of the bivariate relation between the geologic properties of permeability and porosity.

Usage

data(ReineckeWell266)

Format

An R data.frame with

WELLNO

The number of the well, no. 266;

DEPTH

The depth in feet to the center of the incremental spacings of the data;

FRACDOLOMITE

The fraction of the core sample that is dolomite, 0 is 100 percent limestone;

Kmax

The maximum permeability without respect to orientation in millidarcies;

POROSITY

The porosity of the core sample; and

DOLOMITE

Is the interval treated as dolomite (1) or limestone (0).

References

Saller, A.H., Dickson, J.A., 2011, Partial dolomitization of a Pennsylvanian limestone buildup by hydrothermal fluids and its effect on reservoir quality and performance: AAPG Bulletin, v. 95, no. 10, pp. 1745–1762.

Examples

## Not run: 
data(ReineckeWell266)
summary(ReineckeWell266) # show summary statistics
## End(Not run)

Porosity and Permeability Data for the Reinecke Oil Field, Horseshoe Atoll, Texas

Description

These data represent porosity and permeability data from laboratory analysis for the Reinecke Oil Field, Horseshoe Atoll, Texas as used for the outstanding article by Saller and Dickson (2011). Dr. A.H. Art Saller shared a CSV file with the author of the copBasic package sometime in 2011. These data are included in this package because of the instruction potential of the bivariate relation between the geologic properties of permeability and porosity.

Usage

data(ReineckeWells)

Format

An R data.frame with

DOLOMITE

The fraction of the core sample that is dolomite, 0 is 100 percent limestone;

Kmax

The maximum permeability without respect to orientation in millidarcies;

K90

The horizontal (with respect to 90 degrees of the borehole) permeability in millidarcies;

Kvert

The vertical permeability in millidarcies; and

POROSITY

The porosity of the core sample.

References

Saller, A.H., Dickson, J.A., 2011, Partial dolomitization of a Pennsylvanian limestone buildup by hydrothermal fluids and its effect on reservoir quality and performance: AAPG Bulletin, v. 95, no. 10, pp. 1745–1762.

Examples

## Not run: 
data(ReineckeWells)
summary(ReineckeWells) # show summary statistics
## End(Not run)

The Fréchet–Hoeffding Lower-Bound Copula

Description

Compute the Fréchet–Hoeffding lower-bound copula (Nelsen, 2006, p. 11), which is defined as

\mathbf{W}(u,v) = \mathrm{max}(u+v-1,0)\mbox{.}

This is the copula of perfect anti-association (countermonotonicity, perfectly negative dependence) between U and V and is sometimes referred to as the countermonotonicity copula. Its opposite is the \mathbf{M}(u,v) copula (comonotonicity copula; M), and statistical independence is the \mathbf{\Pi}(u,v) copula (P).

Usage

W(u, v, ...)

Arguments

Value

Value(s) for the copula are returned.

Author(s)

W.H. Asquith

References

Nelsen, R.B., 2006, An introduction to copulas: New York, Springer, 269 p.

See Also

M, P

Examples

W(0.41, 0.60) # just barely touching the support, so small, 0.01
W(0.25, 0.45) # no contact with the support, so 0
W(1,    1   ) # total consumption of the support, so 1

Ordinal Sums of Lower-Bound Copula, Example 5.12a of Nelsen's Book

Description

Compute shuffles of Fréchet–Hoeffding lower-bound copula (Nelsen, 2006, p. 173), which is defined by partitioning \mathbf{W} within \mathcal{I}^2 into n subintervals:

\mathbf{W}_n(u,v) = \mathrm{max}\biggl(\frac{k-1}{n}, u+v-\frac{k}{n} \biggr)

for points within the partitions

(u,v) \in \biggl[\frac{k-1}{n}, \frac{k}{n}\biggr]\times \biggl[ \frac{k-1}{n}, \frac{k}{n}\biggr]\mbox{,\ }k = 1,2,\cdots,n

and for points otherwise out side the partitions

\mathbf{W}_n(u,v) = \mathrm{min}(u,v)\mbox{.}

The support of \mathbf{W}_n consists of n line segments connecting coordinate pairs \{(k-1)/n,\, k/n\} and \{k/n,\, (k-1)/n\} as stated by Nelsen (2006). The Spearman Rho (rhoCOP) is defined by \rho_\mathbf{C} = 1 - (2/n^2), and the Kendall Tau (tauCOP) by \tau_\mathbf{C} = 1 - (2/n).

Usage

W_N5p12a(u, v, para=1, ...)

Arguments

Value

Value(s) for the copula are returned.

Author(s)

W.H. Asquith

References

Nelsen, R.B., 2006, An introduction to copulas: New York, Springer, 269 p.

See Also

W, ORDSUMcop, ORDSUWcop, M_N5p12b

Examples

W_N5p12a(0.4, 0.6, para=5)

## Not run: 
  # Nelsen (2006, exer. 5.12a, p. 172, fig. 5.3a)
  UV <- simCOP(1000, cop=W_N5p12a, para=4) # which is the same as
  para <- list(cop=c(W, W, W, W), para=NULL, part=c(0,0.25,0.50,0.75,1))
  UV <- simCOP(1000, cop=ORDSUMcop, para=para) 
## End(Not run)

Akaike Information Criterion between a Fitted Coupla and an Empirical Copula

Description

Compute the Akaike information criterion (AIC) \mathrm{AIC}_\mathbf{C} (Chen and Guo, 2019, p. 29), which is computed using mean square error \mathrm{MSE}_\mathbf{C} as

\mathrm{MSE}_\mathbf{C} = \frac{1}{n}\sum_{i=1}^n \bigl(\mathbf{C}_n(u_i,v_i) - \mathbf{C}_{\Theta_m}(u_i, v_i)\bigr)^2\mbox{ and}

\mathrm{AIC}_\mathbf{C} = 2m + n\log(\mathrm{MSE}_\mathbf{C})\mbox{,}

where \mathbf{C}_n(u_i,v_i) is the empirical copula (empirical joint probability) for the ith observation, \mathbf{C}_{\Theta_m}(u_i, v_i) is the fitted copula having m parameters in \Theta. The \mathbf{C}_n(u_i,v_i) comes from EMPIRcop. The \mathrm{AIC}_\mathbf{C} is in effect saying that the best copula will have its joint probabilities plotting on a 1:1 line with the empirical joint probabilities, which is an \mathrm{AIC}_\mathbf{C} = -\infty. From the \mathrm{MSE}_\mathbf{C} shown above, the root mean square error rmseCOP and Bayesian information criterion (BIC) bicCOP can be computed. These goodness-of-fits can assist in deciding one copula favorability over another, and another goodness-of-fit using the absolute differences between \mathbf{C}_n(u,v) and \mathbf{C}_{\Theta_m}(u, v) is found under statTn.

Usage

aicCOP(u, v=NULL, cop=NULL, para=NULL, m=NA, ...)

Arguments

Value

The value for \mathrm{AIC}_\mathbf{C} is returned.

Author(s)

W.H. Asquith

References

Chen, Lu, and Guo, Shenglian, 2019, Copulas and its application in hydrology and water resources: Springer Nature, Singapore, ISBN 978–981–13–0574–0.

See Also

EMPIRcop, bicCOP, rmseCOP

Examples

## Not run: 
  S <- simCOP(80, cop=GHcop, para=5) # Simulate some probabilities, but we
  # must then treat these as data and recompute empirical probabilities.
  U <- lmomco::pp(S$U, sort=FALSE); V <- lmomco::pp(S$V, sort=FALSE)
  # The parent distribution is Gumbel-Hougaard extreme value copula, but in practical
  # applications, we do not know that. Say we speculate that perhaps the Galambos extreme
  # value might be the parent; maximum likelihood is used to fit the single parameter.
  pGL  <- mleCOP(  U,V, cop=GLcop, interval=c(0, 20))$par
  aics <- c(aicCOP(U,V, cop=GLcop, para=pGL), aicCOP(U,V, cop=P), aicCOP(U,V, cop=PSP))
  names(aics) <- c("GLcop", "P", "PSP")
  print(aics) # We will see that the first AIC is the smallest because the
  # Galambos has the nearest overall behavior than the P and PSP copulas.
## End(Not run)

Wrapper on a User-Level Formula to Become a Copula Function

Description

This function is intended to document and then to extend a simple API to end users to aid in implementation of other copulas for use within the copBasic package. There is no need or requirement to use asCOP for almost all users. However, for the mathematical definition of some copulas, the asCOP function might help considerably. This is because there is a need for special treatment of u and v vectors of probability as each interacts with the vectorization implicit in R. The special treatment is needed because many copulas are based on the operators such as min() and max(). When numerical integration used by the integrate() function in R in some copula operators, such as tauCOP for the Kendall Tau of a copula, special accommodation is needed related to the inherent vectorization in R and how integrate() works.

Basically, the problem is that one can not strictly rely in all circumstances on what R does in terms of value recycling when u and v are of unequal lengths. The source code is straightforward. Simply put, if lengths of u and v are unity, then there is no concern, and even if the length of u (say) is unity and v is 21, then recycling of u would often be okay. The real danger is when u and v have unequal lengths and those lengths are each greater than unity—the R treatment can not be universally relied upon with the various numerics herein involving optimization and nested numerical integration.

The example shows how a formula definition of a copula that is not a copula already implemented by copBasic is set into a function deltacop and then used inside another function UsersCop that will be the official copula that is compatible with a host of functions in copBasic. The use of asCOP provides the length check necessary on u and v, and the argument ... provides optional parameter support should the user's formula require more settings.

Usage

asCOP(u, v, f=NULL, ...)

Arguments

Value

The value(s) for the copula are returned.

Author(s)

W.H. Asquith

References

Nelsen, R.B., 2006, An introduction to copulas: New York, Springer, 269 p.

See Also

COP

Examples

## Not run: 
  # Concerning Nelsen (2006, exer. 3.7, pp. 64--65)
  "trianglecop" <- function(u,v, para=NULL, ...) {
     # If para is set, then the triangle is rotated 90d clockwise.
     if(! is.null(para) && para == 1) { t <- u; u <- v; v <- t }
     if(length(u) > 1 | length(v) > 1) stop("only scalars for this function")
     v2<-v/2; if(0   <= u    &  u   <= v2 & v2 <= 1/2) { return(u    )
     } else   if(0   <= v2   & v2   <  u  &  u < 1-v2) { return(v2   )
     } else   if(1/2 <= 1-v2 & 1-v2 <= u  &  u <= 1  ) { return(u+v-1)
     } else { stop("should not be here in logic") }
  }
  "UsersCop" <- function(u,v, ...) { asCOP(u,v, f=trianglecop, ...) }
  n=20000; UV <- simCOP(n=n, cop=UsersCop)
  # The a-d elements of the problem now follow:
  # (a) Pr[V = 1 - |2*U -1|] = 1 and Cov(U,V) = 0; so that two random variables
  # can be uncorrelated but each is perfectly predictable from the other
  mean(UV$V - (1 - abs(2*UV$U -1))) # near zero; Nelsen says == 0
  cov(UV$U, UV$V)                   # near zero; Nelsen says == 0

  # (b) Cop(m,n) = Cop(n,m); so that two random variables can be identically
  # distributed, uncorrelated, and not exchangeable
  EMPIRcop(0.95,0.17, para=UV) # = A
  EMPIRcop(0.17,0.95, para=UV) # = B; then A != B

  # (c) Pr[V - U > 0] = 2/3; so that two random variables can be identically
  # distributed, but their difference need not be symmetric about zero
  tmp <- (UV$V - UV$U) > 0
  length(tmp[tmp == TRUE])/n # about 2/3; Nelsen says == 2/3
  # the prior two lines yield about 1/2 for independence copula P()

  # (d) Pr[X + Y > 0] = 2/3; so that uniform random variables on (-1,1) can each
  # be symmetric about zero, but their sum need not be.
  tmp <- ((2*UV$V - 1) + (2*UV$U - 1)) > 0
  length(tmp[tmp == TRUE])/n # about 2/3; Nelsen says == 2/3 
## End(Not run)

## Not run: 
  # Concerning Nelsen (2006, exam. 3.10, p. 73)
  "shufflecop" <- # assume scalar arguments for u and v
  function(u,v, para, ...) {
     m <- para$mixer; subcop <- para$subcop
     if(is.na(m) | m <= 0 | m >= 1) stop("m ! in [0,1]")
     if(u <= m) { return(    subcop(1-m+u, v, para=para$para) -
                             subcop(1-m,   v, para=para$para))
     } else {     return(v - subcop(1-m,   v, para=para$para) +
                             subcop(u-m,   v, para=para$para))
     }
  }
  "UsersCop" <- function(u,v, para=NULL) {
     asCOP(u,v, f=shufflecop, para=para)
  }
  n <- 1000; u <- runif(n)
  para <- list(mixer=runif(1), subcop=W, para=20)
  v <- sapply(1:n, function(i) {
      simCOPmicro(u[i], cop=UsersCop, para=para) } )
  plot(data.frame(U=u, V=v), pch=17, col=rgb(1,0,1,1),
     xlab="U, NONEXCEEDANCE PROBABILTY", ylab="V, NONEXCEEDANCE PROBABILITY")
  mtext("Shuffle Copula Nelsen (2006, exam. 3.10, p. 73)")

  # Concerning Nelsen (2006, exam. 5.14, p. 195)
  "deltacop" <- function(u,v, ...) { min(c(u,v,(u^2+v^2)/2))     }
  "UsersCop" <- function(u,v, ...) { asCOP(u,v, f=deltacop, ...) }
  isCOP.PQD(cop=UsersCop) # TRUE + Rho=0.288 and Tau=0.333 as Nelsen says
  isCOP.LTD(cop=UsersCop, wrtV=TRUE) # FALSE as Nelsen says
  isCOP.RTI(cop=UsersCop, wrtV=TRUE) # FALSE as Nelsen says 
## End(Not run)

Bayesian Information Criterion between a Fitted Coupla and an Empirical Copula

Description

Compute the Bayesian information criterion (BIC) \mathrm{BIC}_\mathbf{C} (Chen and Guo, 2019, p. 29), which is computed using mean square error \mathrm{MSE}_\mathbf{C} as

\mathrm{MSE}_\mathbf{C} = \frac{1}{n}\sum_{i=1}^n \bigl(\mathbf{C}_n(u_i,v_i) - \mathbf{C}_{\Theta_m}(u_i, v_i)\bigr)^2\mbox{ and}

\mathrm{BIC}_\mathbf{C} = m\log(n) + n\log(\mathrm{MSE}_\mathbf{C})\mbox{,}

where \mathbf{C}_n(u_i,v_i) is the empirical copula (empirical joint probability) for the ith observation, \mathbf{C}_{\Theta_m}(u_i, v_i) is the fitted copula having m parameters in \Theta. The \mathbf{C}_n(u_i,v_i) comes from EMPIRcop. The \mathrm{BIC}_\mathbf{C} is in effect saying that the best copula will have its joint probabilities plotting on a 1:1 line with the empirical joint probabilities, which is an \mathrm{BIC}_\mathbf{C} = -\infty. From the \mathrm{MSE}_\mathbf{C} shown above, the root mean square error rmseCOP and Akaike information criterion (AIC) aicCOP can be computed. These goodness-of-fits can assist in deciding on one copula favorability over another, and another goodness-of-fit using the absolute differences between \mathbf{C}_n(u,v) and \mathbf{C}_{\Theta_m}(u, v) is found under statTn.

Usage

bicCOP(u, v=NULL, cop=NULL, para=NULL, m=NA, ...)

Arguments

Value

The value for \mathrm{BIC}_\mathbf{C} is returned.

Author(s)

W.H. Asquith

References

Chen, Lu, and Guo, Shenglian, 2019, Copulas and its application in hydrology and water resources: Springer Nature, Singapore, ISBN 978–981–13–0574–0.

See Also

EMPIRcop, aicCOP, rmseCOP

Examples

## Not run: 
S <- simCOP(80, cop=GHcop, para=5) # Simulate some probabilities, but we
# must then treat these as data and recompute empirical probabilities.
U <- lmomco::pp(S$U, sort=FALSE); V <- lmomco::pp(S$V, sort=FALSE)
# The parent distribution is Gumbel-Hougaard extreme value copula.
# But in practical application we don't know that but say we speculate that
# perhaps the Galambos extreme value might be the parent. Then maximum
# likelihood is used on that copula to fit the single parameter.
pGL <- mleCOP(U,V, cop=GLcop, interval=c(0,20))$par

bics <- c(bicCOP(U,V, cop=GLcop, para=pGL), bicCOP(U,V, cop=P), bicCOP(U,V, cop=PSP))
names(bics) <- c("GLcop", "P", "PSP")
print(bics) # We will see that the first BIC is the smallest as the
# Galambos has the nearest overall behavior than the P and PSP copulas.
## End(Not run)

Analog to Line of Organic Correlation by Copula Diagonal

Description

HIGHLY EXPERIMENTAL AND SUBJECT TO OVERHAUL OR REMOVAL—Compute an analog to the line of organic correlation (reduced major axis) using the diagonal of a copula.

\mathrm{Pr}[U \le u, V \le v] = \mathbf{C}(u,v) = f\mbox{.}

The primary diagonal is defined as

\mathbf{\delta}_\mathbf{C}(t) = \mathbf{C}(t,t) = f\mbox{.}

Two diagnostic plots can be plotted by the arguments available for this function. The plot for (U,V) coordinate nonexceedance probability domain along with the analyses involving the copula diagonal inversion comes first, which is followed by that for (X,Y) coordinate domain along with the well-known line of organic correlation by the method of L-moments and such a “line” (could be a curve) by copula diagonal inversion.

This much infrastructure written for flexibility in how a copula would interact for the purpose of estimation with moment preservation. The simple u = v might be sufficient but let us have some flexibility.

Usage

bicoploc(xp, yp=NULL, xout=NA, xpara=NULL, ypara=NULL, dtypex="nor", dtypey="nor",
         ctype=c("weibull", "hazen", "bernstein", "checkerboard"), kumaraswamy=TRUE,
         plotuv=TRUE, plotxy=TRUE, adduv=FALSE, addxy=FALSE, snv=FALSE, limout=TRUE,
         autoleg=TRUE, xleg="topleft", yleg=NULL, rugxy=TRUE, ruglwd=0.5,
         xlim=NULL, ylim=NULL, titleuv="", titlexy="", titlecex=1,
         a=0, ff=pnorm(seq(-5, +5, by=0.1)), locdigits=6,
         paracop=TRUE, verbose=TRUE, x=NULL, y=NULL, ...)

Arguments

Details

ON THE USE OF AN PARAMETRIC ASYMMETRIC COPULA—

Value

Lists, vectors, and data frames for the computations and predictions are returned.

Note

The use of a copula diagonal inversion for purposes of a line of organic correlation analog within the text-book literature and elsewhere is unknown to the developers (December 2023).

Though bicoploc has extensive logic for working through the copula diagonal, if we know the parent distribution and we just have the marginal probabilities equal to each other (the diagonal), then we recover the moments of Y simply with u = v:

  library(lmomco)
  ff    <- c(0.0001, seq(0.001, 0.999, by=0.001), 0.9999)
  xpara <- lmomco::vec2par(c(3, 0.6, -0.4), type="pe3")
  ypara <- lmomco::vec2par(c(3, 0.4, +0.6), type="pe3")
  xx <-   rlmomco(100000,  xpara)
  yy <- approx(qlmomco(ff, xpara), qlmomco(ff, ypara), xout=xx)$y
  lmr2par(yy, type="aep4")$para
  #        mu     sigma     gamma
  # 2.9972742 0.3993914 0.5980866

Author(s)

W.H. Asquith

References

Kruskal, W.H., 1953, On the uniqueness of the line of organic correlation: Biometrics, vol. 9, no. 1, pp. 47–58, doi:10.2307/3001632.

See Also

diagCOPatf

Examples

# paracop set to FALSE in these examples for speed
set.seed(4); nsim <- 50
X  <- rnorm(nsim, mean=3, sd=0.6)
Y  <- rnorm(nsim, mean=0, sd=0.2)
zz <- bicoploc(X,Y, xout=c(2.5, 3.5, 4), dtypex="nor", dtypey="nor",   paracop=FALSE)
# cor(X,Y, method="spearman") # +0.0785114 POSITIVE

set.seed(1); nsim <- 50
X  <- rnorm(nsim, mean=3, sd=0.6)
Y  <- rnorm(nsim, mean=0, sd=0.2)
zz <- bicoploc(X,Y, xout=c(2.5, 3.5, 4), dtypex="nor", dtypey="nor",   paracop=FALSE)
# cor(X,Y, method="spearman") # -0.1351741 NEGATIVE

set.seed(1); nsim <- 50
X  <-           rnorm(nsim, mean=3, sd=0.6)
Y  <- 0.843*X + rnorm(nsim, mean=0, sd=0.2)
zz <- bicoploc(X,Y, xout=c(2.5, 3.5, 4), dtypex="nor", dtypey="nor",   paracop=FALSE)
# cor(X,Y, method="spearman") # for nsim=1E6 RHO=0.92367

set.seed(1); nsim <- 50
X  <-           lmomco::rlmomco(nsim, lmomco::vec2par(c(3, 0.6, +0.5), type="pe3"))
Y  <- 0.3*X^2 + lmomco::rlmomco(nsim, lmomco::vec2par(c(0, 0.4, 0),    type="pe3"))
zz <- bicoploc(X,Y, xout=c(2.5, 3.5, 4.5), dtypex="nor", dtypey="nor", paracop=FALSE)
# cor(X,Y, method="spearman") # for nsim=1E6 RHO=0.92366

set.seed(1); nsim <- 50
X  <-           lmomco::rlmomco(nsim, lmomco::vec2par(c(3, 0.6, +0.5), type="pe3"))
Y  <- 0.3*X^2 + lmomco::rlmomco(nsim, lmomco::vec2par(c(0, 0.4, 0),    type="pe3"))
zz <- bicoploc(X,Y, xout=c(2.5, 3.5, 4.5), dtypex="gev", dtypey="gev", paracop=FALSE)

## Not run: 
########################################################################################
# Image 800 samples in X and Y and though created as pairs, let us assume only
# 50 are actually paired for purposes of demonstration of specified parameters
# and (or) alternative x and y vectors providing the larger sample.
set.seed(1); nsim <- 800; npair <- 50
X  <-           lmomco::rlmomco(nsim, lmomco::vec2par(c(3, 0.6, +0.5), type="pe3"))
Y  <- 0.3*X^2 + rnorm(nsim, mean=0, sd=0.3)
ix <- sample(seq_len(nsim), npair, replace=FALSE)
Xp <- X[ix]; Yp <- Y[ix]; dtypex <- "gev"; dtypey <- "gev"
xpara <- lmomco::lmr2par(X, type=dtypex); ypara <- lmomco::lmr2par(Y, type=dtypey)

# The next two bicoploc() calls produce identical results except for the density
# of data points along the axes for the rug plots. Ultimately, the same parameter
# estimates for the margins exists for both calls. The plotuv is disabled so that
# the user can tab between the two plotxy plots and see that they are the same.
zz <- bicoploc(Xp,Yp, xout=c(2.5, 3.5, 4.5), ruglwd=0.9, plotuv=FALSE,
               xpara=xpara, ypara=ypara, dtypex=NULL, dtypey=NULL)
mtext("Example of specific xpara and ypara from larger sample", line=0.5)

zz <- bicoploc(Xp,Yp, xout=c(2.5, 3.5, 4.5), ruglwd=0.9, plotuv=FALSE,
               xpara=xpara, ypara=ypara, dtypex=NULL, dtypey=NULL, x=X, y=Y)
mtext("Example of specific xpara and ypara from larger sample", line=0.5) #
## End(Not run)

## Not run: 
########################################################################################
set.seed(1); nsim <- 50
UV <- rCOP(nsim, cop=breveCOP, para=list(cop=W, alpha=0, beta=0))
X  <- qnorm(UV[,1], mean=3, sd=0.6)
Y  <- qnorm(UV[,2], mean=2, sd=0.2)
zz <- bicoploc(X,Y, xout=c(1.5, 2.5, 3.5, 4), dtypex="nor", dtypey="nor")

set.seed(1); nsim <- 50
UV <- rCOP(nsim, cop=breveCOP, para=list(cop=W, alpha=0, beta=0.5))
X  <- qnorm(UV[,1], mean=3, sd=0.6)
Y  <- qnorm(UV[,2], mean=2, sd=0.2)
zz <- bicoploc(X,Y, xout=c(1.5, 2.5, 3.5, 4), dtypex="nor", dtypey="nor")

set.seed(1); nsim <- 50
UV <- rCOP(nsim, cop=breveCOP, para=list(cop=M_N5p12b, para=3, alpha=0, beta=0.5))
X  <- qnorm(UV[,1], mean=3, sd=0.6)^2
Y  <- qnorm(UV[,2], mean=2, sd=0.2)
zz <- bicoploc(X,Y, xout=c(1.5, 2.5, 3.5, 4), ylim=c(1,2.5),
                    xleg="bottomleft", dtypex="aep4", dtypey="nor")

# A TRUE COUNTER EXAMPLE? Are the 1-v operations not sufficient depending on
# rotation? Is the secondary diagonal of a copula useful? Is there something wrong
# with the reflection operations as implemented at the end of November 2023?
# Should negatives be turned into positives by reversing Y within the internal logic?
# The solution current at end of November 2023 seems proper.
set.seed(1); nsim <- 500
para <- list(cop1=W, para1=4, cop2=GHcop, para2=c(30,.6, .9), alpha=0, beta=0.1)
UV <- rCOP(nsim, cop=composite2COP, para=para)
X  <- -qexp(UV[,1], rate=10)+0.1 # Or the problem is a reflected exponential but the
Y  <- qnorm(UV[,2], mean=2, sd=0.2)  # exp version in lmomco can not handle
zz <- bicoploc(X,Y, xout=c(-0.05, 0, 0.2), dtypex="exp", dtypey="nor")
# Possibly, try another distribution.
zz <- bicoploc(X,Y, xout=c(-0.3, -0.2, 0), ylim=c(1,4), dtypex="aep4", dtypey="nor") #
## End(Not run)

## Not run: 
########################################################################################
set.seed(1); nsim <- 200; npair <- 30
para <- list(cop=PLcop, para=80, alpha=0.3, beta=0.05)
UV <- rCOP(nsim, cop=composite1COP, para=para, resamv01=TRUE)
X  <- lmomco::qlmomco(UV[,1], lmomco::vec2par(c(3, 0.6, +0.4), type="pe3"))
Y  <- lmomco::qlmomco(UV[,2], lmomco::vec2par(c(3, 0.4, +0.0), type="pe3"))
ix <- sample(seq_len(nsim), npair, replace=FALSE)
Xp <- X[ix]; Yp <- Y[ix]; dtypex <- "pe3"; dtypey <- "pe3"
xpara <- lmomco::lmr2par(X, type=dtypex); ypara <- lmomco::lmr2par(Y, type=dtypey)
plot(10^X, 10^Y, log="xy", las=1, pch=21, lwd=0.8, col="black", bg="white",
                 xlab="SOME RISK PHENOMENON IN X-DIRECTION",
                 ylab="SOME RISK PHENOMENON IN Y-DIRECTION")
xout <- c(1.5, 2.5, 3.5, 4)
xlim <- c(1.5, 4.5); ylim <- c(1.8, 5.0)
zz <- bicoploc(Xp,Yp, xout=xout,xpara=xpara,ypara=ypara,  xlim=xlim,ylim=ylim)

zz <- bicoploc(Xp,Yp, xout=xout,xpara=xpara,ypara=ypara,  xlim=xlim,ylim=ylim,x=X,y=Y)
zz <- bicoploc(Xp,Yp, xout=xout,dtypex="pe3",dtypey="pe3",xlim=xlim,ylim=ylim,x=X,y=Y)

zz <- bicoploc(X, Y,  xout=xout,dtypex="pe3",dtypey="pe3",xlim=xlim,ylim=ylim)#
## End(Not run)

Bivariate L-moments and L-comoments of a Copula

Description

Attention: This function is deprecated in favor of lcomCOP, which uses only direct numerical integrate() on the integrals shown below. The bilmoms function is strictly based on Monte Carlo integration.

Compute the bivariate L-moments (ratios) (\delta^{[\ldots]}_{k;\mathbf{C}}) of a copula \mathbf{C}(u,v; \Theta) and remap these into the L-comoment matrix counterparts (Serfling and Xiao, 2007; Asquith, 2011) including L-correlation (Spearman Rho), L-coskew, and L-cokurtosis. As described by Brahimi et al. (2015), the first four bivariate L-moments \delta^{[12]}_k for random variable X^{(1)} or U with respect to (wrt) random variable X^{(2)} or V are defined as

\delta^{[12]}_{1;\mathbf{C}} = 2\int\!\!\int_{\mathcal{I}^2} \mathbf{C}(u,v)\,\mathrm{d}u\mathrm{d}v - \frac{1}{2}\mbox{,}

\delta^{[12]}_{2;\mathbf{C}} = \int\!\!\int_{\mathcal{I}^2} (12v - 6) \mathbf{C}(u,v)\,\mathrm{d}u\mathrm{d}v - \frac{1}{2}\mbox{,}

\delta^{[12]}_{3;\mathbf{C}} = \int\!\!\int_{\mathcal{I}^2} (60v^2 - 60v + 12) \mathbf{C}(u,v)\,\mathrm{d}u\mathrm{d}v - \frac{1}{2}\mbox{, and}

\delta^{[12]}_{4;\mathbf{C}} = \int\!\!\int_{\mathcal{I}^2} (280v^3 - 420v^2 + 180v - 20) \mathbf{C}(u,v)\,\mathrm{d}u\mathrm{d}v - \frac{1}{2}\mbox{,}

where the bivariate L-moments are related to the L-comoment ratios by

6\delta^{[12]}_k = \tau^{[12]}_{k+1}\mbox{\quad and \quad}6\delta^{[21]}_k = \tau^{[21]}_{k+1}\mbox{,}

where in otherwords, “the third bivariate L-moment \delta^{[12]}_3 is one sixth the L-cokurtosis \tau^{[12]}_4.” The first four bivariate L-moments yield the first five L-comoments (there is no first order L-comoment ratio). The terms and nomenclature are not easy and also the English grammar adjective “ratios” is not always consistent in the literature. The \delta^{[\ldots]}_{k;\mathbf{C}} are ratios, and the returned bilcomoms element by this function holds matrices for the marginal means, marginal L-scales and L-coscales, and then the ratio L-comoments.

Similarly, the \delta^{[21]}_k are computed by switching u \rightarrow v in the polynomials within the above integrals multiplied to the copula in the system of equations with u. In general, \delta^{[12]}_k \not= \delta^{[21]}_k for k > 1 unless in the case of permutation symmetric (isCOP.permsym) copulas. By theory, \delta^{[12]}_1 = \delta^{[21]}_1 = \rho_\mathbf{C}/6 where \rho_\mathbf{C} is a Spearman Rho rhoCOP.

The integral for \delta^{[12]}_{4;\mathbf{C}} does not appear in Brahimi et al. (2015) but this and the other forms are verified in the Examples and discussion in Note. The four k \in [1,2,3,4] for U wrt V and V wrt U comprise a full spectrum of system of seven (not eight) equations. One equation is lost because \delta^{[12]}_1 = \delta^{[21]}_1.

Usage

bilmoms(cop=NULL, para=NULL, only.bilmoms=FALSE, n=1E5,
                  sobol=TRUE, scrambling=0, ...)

Arguments

Value

An R list of the bivariate L-moments is returned.

Note

The mapping of the bivariate L-moments to their L-comoment matrix counterparts is simple but nuances should be discussed and the meaning of the error.rho needs further description. The extra effort to form L-comoment matrices (Serfling and Xiao, 2007; Asquith, 2011) is made so that output matches the structure of the sample L-comoment matrices from the lcomoms2() function of the lmomco package.

Concerning the triangular or tent-shaped copula of Nelsen (2006, exer. 3.7, pp. 64–65) for demonstration, simulate from the triangular copula a sample of size m = 20{,}000 and compute some sample L-comoments using the following CPU intensive code. The function asCOP completes the vectorization needed for non-Monte Carlo integration for rhoCOP.

  "trianglecop" <- function(u,v, para=NULL, ...) {
    # If para is set, then the triangle is rotated 90d clockwise.
    if(! is.null(para) && para == 1) { t <- u; u <- v; v <- t }
    if(length(u) > 1 | length(v) > 1) stop("only scalars for this function")
    v2<-v/2; if(0   <= u    & u    <= v2 & v2 <= 1/2) { return(u    )
    } else   if(0   <=   v2 &   v2 <  u  &  u < 1-v2) { return(v2   )
    } else   if(1/2 <= 1-v2 & 1-v2 <= u  &  u <= 1  ) { return(u+v-1)
    } else { stop("should not be here in logic") }
  }
  "TriCop" <- function(u,v, ...) { asCOP(u,v, f=trianglecop, ...) }
  m=20000; SampleUV <- simCOP(n=m, cop=TriCop, graphics=FALSE)
  samLC  <- lcomoms2(SampleUV, nmom=5)
  theoLC <- bilmoms(cop=TriCop)

The Error in Rho Computation—The \rho_\mathbf{C} of the copula by numerical integration is computed internally to bilmoms as

  rhoC <- rhoCOP(cop=TriCop) # -1.733858e-17

and used to compute the error.rho for bilmoms (see next code snippet). The \rho_\mathbf{C} is obviously zero for this copula. Therefore, the bivariate association of TriCop is zero and thus is an example of a perfectly dependent situation yet of zero correlation. The bivariate L-moments and L-comoments of this copula are computed as

  mean(replicate(20, bilmoms(cop=TriCop)$error.rho)) # 7.650723e-06

where the error.rho is repeated trials appears firmly <1e-5, which is near zero (\epsilon_\rho \approx 0). The error.rho term is defined by taking the first bivariate L-moment and numerically integrated \rho_\mathbf{C} through rhoCOP and computing the terms

\epsilon^{[12]}_\rho = |\delta^{[12]}_{1;\mathbf{C}} - (\rho_\mathbf{C}/6)|\mbox{,}

\epsilon^{[21]}_\rho = |\delta^{[21]}_{1;\mathbf{C}} - (\rho_\mathbf{C}/6)|\mbox{, and}

\epsilon_\rho = \frac{\epsilon^{[12]}_\rho + \epsilon^{[21]}_\rho}{2}\mbox{,}

where the error.rho = \epsilon_\rho, and values near zero are obviously favorable because this indicates that the Monte Carlo integration sample size n argument is sufficiently large to effectively canvas the \mathcal{I}^2 domain. For the situation here, the theoretical \rho_\mathbf{C} = 0, but for n = n = 100, the error.rho \approx 0.006 (e.g. bilmoms(n=100, cop=TriCop)$error.rho) through a 20-unit replication, which is a hint that 100 samples are not large enough and that should be obvious.

The reasoning behind using the error.rho between conventional numerical integration and the Monte Carlo integration (error.rho) is that \rho_\mathbf{C} is symmetrical. This choice of “convergence” assessment reduces somewhat the sample size needed for Monte Carlo integration into single number representing error.

Discussion of Theoretical L-comoments—The theoretical L-comoments in the format structure of the sample L-comoments by the lcomoms2() function of the lmomco package are formed by the bilmoms function, and the theoretical values are shown below in sequence with details listed by L-comoment. Now we extract the L-comoment matrices and show the first L-comoment matrix (the matrix of the means):

  theoLClcm <- theoLC$bilcomoms
  print(theoLClcm$L1)
            [,1]      [,2]
  [1,] 0.4999939        NA
  [2,]        NA 0.5000032

where the diagonal should be filled with 1/2, if the n is suitably large, because 1/2 is the mean of the marginal uniform random variables. By definition the secondary diagonal has NAs. The values shown above are extremely close supporting the idea that default n is large enough. The matrix of means is otherwise uninformative.

The second L-comoment matrix (L-scales and L-coscales) is

  print(theoLClcm$L2)
                [,1]          [,2]
  [1,]  1.666677e-01 -3.466202e-06
  [2,] -3.466209e-06  1.666674e-01

where the diagonal should be filled with 1/6, if the n is suitably large, because 1/6 is the univariate L-scale of the marginal uniform random variables. These values further support that default n is large enough. The diagonal is computed from the univariate L-moments of the margins of the Monte Carlo-generated edges and is otherwise uninformative. The secondary diagonal is a rescaling of the \delta^{[\ldots]}_1 by the univariate L-moments of the margins to form L-coscales (nonratios). The copula is perfectly dependent but uncorrelated; so the secondary diagonal has near zeros.

The second L-comoment ratio matrix (coefficient of L-variations and L-correlations) is

  print(theoLClcm$T2)
                [,1]          [,2]
  [1,]  1.000000e+00 -2.079712e-05
  [2,] -2.079712e-05  1.000000e+00

where the diagonal by definition has unities (correlation is unity for a variable on itself) but the secondary diagonal for the L-correlations has near zeros because again the copula is uncorrelated, and the secondary diagonal is computed from the \delta^{[\ldots]}_1. These L-correlations are the Spearman Rho values computed external to the algorithms within rhoCOP.

The third L-comoment ratio matrix (L-skews and L-coskews) is

  print(theoLClcm$T3)
                [,1]          [,2]
  [1,]  3.021969e-06 -2.829783e-05
  [2,] -7.501135e-01  4.518901e-06

where the diagonal by definition should have nero zeros because the univariate L-skew of a uniform variable is zero. These values further support that default n is large enough. The secondary diagonal holds L-coskews. The copula has L-coskew of U wrt V of numerically near zero (symmetry) but measurable asymmetry of L-coskew of V wrt U of \tau^{[21]}_3 \approx -0.75.

The fourth L-comoment ratio matrix (L-kurtosises and L-cokurtosises) is

  print(theoLClcm$T4)
                [,1]          [,2]
  [1,] -2.623665e-06 -3.325177e-05
  [2,] -2.162954e-04 -2.811630e-06

where the diagonal by definition should have nero zeros because the univariate L-kurtosis of a uniform variable is zero—it has no peakedness. These values further support that default n is large enough. The secondary diagonal holds L-cokurtosises and are near zero for this particular copula.

The fifth L-comoment ratio matrix (unnamed) is

  print(theoLClcm$T5)
               [,1]          [,2]
  [1,] 1.813344e-06 -1.296025e-04
  [2,] 1.246436e-01  1.475012e-06

where the diagonal by definition should have nero zeros because the univariate L-kurtosis of a uniform variable is zero—such a random variable has no asymmetry. These values further support that default n is large enough. The secondary diagonal holds the fifth L-comoment ratios. The copula has \tau^{[12]}_5 = 0 of U wrt V of numerically near zero (symmetry) but measurable fifth-order L-comoment asymmetry of V wrt U of \tau^{[21]}_5 \approx 0.125.

Comparison of Sample and Theoretical L-comoments—The previous section shows theoretical values computed as \tau^{[21]}_3 \approx -0.75 and \tau^{[21]}_5 \approx 0.125 for the two L-comoments substantially away from zero. As sample L-comoments these values are samLC$T3[2,1] = \hat\tau^{[21]}_3 \approx -0.751 and samLC$T5[2,1] = \hat\tau^{[21]}_5 \approx 0.123. CONCLUSION: The sample L-comoment algorithms in the lmomco package are validated.

Author(s)

W.H. Asquith

References

Asquith, W.H., 2011, Distributional analysis with L-moment statistics using the R environment for statistical computing: Createspace Independent Publishing Platform, ISBN 978–146350841–8.

Brahimi, B., Chebana, F., and Necir, A., 2015, Copula representation of bivariate L-moments—A new estimation method for multiparameter two-dimensional copula models: Statistics, v. 49, no. 3, pp. 497–521.

Nelsen, R.B., 2006, An introduction to copulas: New York, Springer, 269 p.

Serfling, R., and Xiao, P., 2007, A contribution to multivariate L-moments—L-comoment matrices: Journal of Multivariate Analysis, v. 98, pp. 1765–1781.

See Also

lcomCOP, uvlmoms

Examples

## Not run: 
bilmoms(cop=PSP, n=10000, para=NULL, sobol=TRUE)$bilcomoms$T3
# results: Tau3[12]=-0.132, Tau3[21]=-0.132 (Monte Carlo)
lcomCOP(cop=PSP, para=NULL, orders=3)
# results: Tau3[12]=-0.129, Tau3[21]=-0.129 (direct integration)
## End(Not run)

## Not run: 
# This stopped running sometime before June 2023. IS THIS IN COP()?
para <- list(alpha=0.5, beta=0.93, para1=4.5, cop1=GLcop, cop2=PSP)
bilmoms(cop=composite2COP, n=10000, para=para, sobol=TRUE)$bilcomoms$T3
# results: Tau3[12]=0.154, Tau3[21]=-0.0691 (Monte Carlo)
lcomCOP(cop=composite2COP, para=para, orders=3)
# results: Tau3[12]=0.156, Tau3[21]=-0.0668 (direct integration)
## End(Not run)

## Not run: 
UVsim <- simCOP(n=20000, cop=composite2COP, para=para, graphics=FALSE)
samLcom <- lmomco::lcomoms2(UVsim, nmom=5) # sample algorithm
# results: Tau3[12]=0.1489, Tau3[21]=-0.0679 (simulation)
## End(Not run)

The Blomqvist Beta of a Copula

Description

Compute the Blomqvist Beta \beta_\mathbf{C} of a copula (Nelsen, 2006, p. 182), which is defined at the middle or center of \mathcal{I}^2 as

\beta_\mathbf{C} = 4\times\mathbf{C}\biggl(\frac{1}{2},\frac{1}{2}\biggr) - 1\mbox{,}

where the u = v = 1/2 and thus shows that \beta_\mathbf{C} is based on the median joint probability. The Blomqvist Beta is also called the medial correlation coefficient. Nelsen also reports that “although, the Blomqvist Beta depends only on the copula only through its value at the center of \mathcal{I}^2, but that [\beta_\mathbf{C}] nevertheless often provides an accurate approximation to both Spearman Rho rhoCOP and Kendall Tau tauCOP.” Kendall Tau \tau_\mathbf{C}, Gini Gamma \gamma_\mathbf{C}, and Spearman Rho \rho_\mathbf{C} in relation to \beta_\mathbf{C} satisfy the following inequalities (Nelsen, 2006, exer. 5.17, p. 185):

\frac{1}{4}(1 + \beta_\mathbf{C})^2 - 1 \le \tau_\mathbf{C} \le 1 - \frac{1}{4}(1 - \beta_\mathbf{C})^2\mbox{,}

\frac{3}{16}(1 + \beta_\mathbf{C})^3 - 1 \le \rho_\mathbf{C} \le 1 - \frac{3}{16}(1 - \beta_\mathbf{C})^3\mbox{, and}

\frac{3}{8}(1 + \beta_\mathbf{C})^2 - 1 \le \tau_\mathbf{C} \le 1 - \frac{3}{8}(1 - \beta_\mathbf{C})^2\mbox{.}

A curious aside (Joe, 2014, p. 164) about the Gaussian copula is that Blomqvist Beta is equal to Kendall Tau (tauCOP): \beta_\mathbf{C} = \tau_\mathbf{C} (see Note in med.regressCOP for a demonstration). Finally, a version of Blomqvist Beta defined outside the median is provided by blomCOPss.

Usage

blomCOP(cop=NULL, para=NULL, as.sample=FALSE,
                  ctype=c("joe", "weibull", "hazen", "1/n",
                                 "bernstein", "checkerboard"), ...)

Arguments

Value

The value for \beta_\mathbf{C} or sample \hat\beta_n is returned.

Note

The sample \hat\beta_n is most efficiently computed (Joe, 2014, p. 57) by

\hat\beta_n = \frac{2}{n} \sum_{i=1}^{n} \mathbf{1}\biggl([r_{i1} - (1 + n)/2]\times [r_{i2} - (1 + n)/2] \ge 0\biggr) - 1\mbox{,}

where r_{i1}, r_{i2} are the ranks of the data for i = 1, \ldots n, and \mathbf{1}(.) is an indicator function scoring 1 if condition is true otherwise zero. However, the Joe sample estimator is not fully consistent (or vice versa) with the various versions of the empirical copula, \mathbf{C}_n, (EMPIRcop) (see the last example in Examples). Also, the nature of even and odd sample sizes controls how the median is computed and the issue of samples lying on the median lines in U and V (Genest et al., 2013). The argument ctype supports triggers to the \mathbf{C}_n in lieu of the Joe sample estimator shown in this documentation.

Author(s)

W.H. Asquith

References

Genest, C., Carabarín-Aguirre, A., and Harvey, F., 2013, Copula parameter estimation using
Blomqvist's beta: Journal de la Société Française de Statistique, v. 154, no. 1, pp. 5–24.

Joe, H., 2014, Dependence modeling with copulas: Boca Raton, CRC Press, 462 p.

Nelsen, R.B., 2006, An introduction to copulas: New York, Springer, 269 p.

See Also

blomCOPss, blomatrixCOPdec, blomatrixCOPiqr, footCOP, giniCOP, hoefCOP, rhoCOP, tauCOP, wolfCOP, joeskewCOP, uvlmoms

Examples

blomCOP(cop=PSP) # 1/3 precisely

## Not run: 
# Nelsen (2006, exer. 5.17, p. 185) : All if(...) are TRUE
B <- blomCOP(cop=N4212cop, para=2.2); Bp1 <- 1 + B; Bm1 <- 1 - B
G <- giniCOP(cop=N4212cop, para=2.2); a <- 1/4; b <- 3/16; c <- 3/8
R <-  rhoCOP(cop=N4212cop, para=2.2)
K <-  tauCOP(cop=N4212cop, para=2.2, brute=TRUE) # numerical issues without brute
if( a*Bp1^2 - 1 <= K & K <= 1 - a*Bm1^2 ) print("TRUE") #
if( b*Bp1^3 - 1 <= R & R <= 1 - b*Bm1^3 ) print("TRUE") #
if( c*Bp1^2 - 1 <= G & G <= 1 - c*Bm1^2 ) print("TRUE") #
## End(Not run)

## Not run: 
# A demonstration of a special feature of blomCOP for sample data.
# Joe (2014, p. 60; table 60) has 0.749 for GHcop(tau=0.5); n*var(hatB) as n-->infinity
set.seed(1)
theta <- GHcop(tau=0.5)$para; B <- blomCOP(cop=GHcop, para=theta); n <- 1000
H <- sapply(1:1000, function(i) { # Let us test that with pretty large sample size:
	                blomCOP(para=rCOP(n=n, cop=GHcop, para=theta), as.sample=TRUE) })
print(n*var(B-H)) # For 1,000 sims of size n : 0.789, nearly matches Joe's result 
## End(Not run)

## Not run: 
# Joe (2014, p. 57) says that sqrt(n)(B-HatBeta) is Norm(0, 1 - B^2)
set.seed(1)
n <- 10000; B <- blomCOP(cop=PSP) # Beta = 1/3
H <- sapply(1:100, function(i) { message(i,"-", appendLF=FALSE)
	               blomCOP(para=rCOP(n=n, cop=PSP), as.sample=TRUE) })
lmomco::parnor(lmomco::lmoms(sqrt(n)*(H-B))) # mu = -0.038; sigma = 0.970
# Joe (2014) : sqrt(1-B^2) == standard deviation (sigma) : (1-(1/3)^2) approx 0.973 
## End(Not run)

## Not run: 
nn <- 200; set.seed(1)
UV <- simCOP(n=nn+1, cop=PSP, graphics=FALSE)
for(n in nn:(nn+1)) {
  if(as.logical(n %% 2)) { # in source \ percent \ percent for latex
    message("Blomquist Betas for an odd  sample size n=", n)
    uv <- UV
  } else {
    message("Blomquist Betas for an even sample size n=", n)
    uv <- UV[-(nn+1), ] # remove the last and 'odd' indexed value to make even
  }
  message(c(" Joe2014: ", blomCOP(as.sample=TRUE, para=uv, ctype="joe"         )))
  message(c(" Weibull: ", blomCOP(as.sample=TRUE, para=uv, ctype="weibull"     )))
  message(c(" Hazen:   ", blomCOP(as.sample=TRUE, para=uv, ctype="hazen"       )))
  message(c(" 1/n:     ", blomCOP(as.sample=TRUE, para=uv, ctype="1/n"         )))
  message(c(" Bernstn: ", blomCOP(as.sample=TRUE, para=uv, ctype="bernstein"   )))
  message(c(" ChckBrd: ", blomCOP(as.sample=TRUE, para=uv, ctype="checkerboard")))
}
# Blomquist Betas for an even sample size n=200
#  Joe2014: 0.32
#  Weibull: 0.32
#  Hazen:   0.32
#  1/n:     0.32
#  Bernstn: 0.323671819423416
#  ChckBrd: 0.32
# Blomquist Betas for an odd  sample size n=201
#  Joe2014: 0.323383084577114
#  Weibull: 0.333333333333333
#  Hazen:   0.333333333333333
#  1/n:     0.293532338308458
#  Bernstn: 0.327747577290946
#  ChckBrd: 0.313432835820896 #
## End(Not run)

Blomqvist (Schmid–Schmidt) Betas of a Copula

Description

Compute the Blomqvist (Schmid–Schmidt) Betas \beta^\diamond_\mathbf{C} (Schmid and Schmidt, 2007) defined for arbitrary dimension d of a copula \mathbf{C}_(u_1, \cdots, u_d; \Theta) (COP) for parameters \Theta. The copula survival function is \overline{\mathbf{C}}(u_1, \cdots, u_d; \Theta) (surfuncCOP). The Beta, though the copBasic package is built around bivariate copula only, is defined as

\beta^\diamond_\mathbf{C} = h_d(\mathbf{u}, \mathbf{v})\bigl[ \bigl(\mathbf{C}(\mathbf{u}) + \overline{\mathbf{C}}(\mathbf{v})\bigr) - g_d(\mathbf{u}, \mathbf{v}) \bigr]\mbox{,}

where h_d and g_d are norming constants defined below. The superscript \diamond (diamond) is chosen for copBasic because of the alliteration to “dimension.” The bold face font for \mathbf{u} and \mathbf{v} shows these arguments as vectors of length d reflecting “cutting points” on nonexceedance probabilities in each of the dimensions. The \mathbf{u} functions as the arguments (u,v) pair used in copula of this package and represents the first cutting point for a \mathrm{Pr}[U \le u, V \le v] = \mathbf{C}(u,v), and \mathbf{v} functions as the arguments u,v pair for this package and represents the second cutting point for a \mathrm{Pr}[U > u, V > v] = 1 - u - v + \mathbf{C}(u,v) = \overline{\mathbf{C}}(u,v). This notation of vectored (bold face) and nonvectored “u” and “v” is a little obtuse but as the properties of \beta^\diamond_\mathbf{C} are summarized clarity for the reader is anticipated. In short, the \mathbf{u} will reference the coordinate pairs in the lower right quadrant and the \mathbf{v} will reference the coordinate pairs in the upper right quadrant.

The norming constant h_d is defined as

h_d(\mathbf{u}, \mathbf{v}) = \frac{1}{\bigl( \mathrm{min}(u_1, \cdots, u_d) + \mathrm{min}(1-v_1, \cdots, 1-v_d) - g_d(\mathbf{u}, \mathbf{v})\bigr)}\mbox{,}

and g_d is defined as

g_d(\mathbf{u}, \mathbf{v}) = \prod^d_{i=1}u_i + \prod^d_{i=1}(1-v_i)\mbox{,}

where the cutting points \mathbf{u} and \mathbf{v} are in a domain D : \{(\mathbf{u}, \mathbf{v})\} \in [0,1]^{2d} given \mathbf{u} \le \mathbf{v} and \mathbf{u} > 0 or \mathbf{v} < \mathbf{1}. The reader must careful remember that these \mathbf{u} and \mathbf{v} are vectors of probabilities.

The norming constants provide for -1 \le \beta^\diamond_\mathbf{C} \le +1. Using the function argument defaults for d=2 dimensions \mathbf{u} = (1,1)/2 for uu and \mathbf{v} = (1,1)/2 for vv, results in (1) \beta^\diamond_\mathbf{C} = 1 if \mathbf{C} = \mathbf{M} comonotonicity copula (M) (blomCOPss(cop=M) == 1), (2) \beta^\diamond_\mathbf{C} = 0 if \mathbf{C} = \mathbf{P} independence copula (P) (blomCOPss(cop=P) == 0), and (3) if \mathbf{C} = \mathbf{W} countermonotonicity copula (W)\beta^\diamond_\mathbf{C} = 1 (blomCOPss(cop=W) == -1).

Schmid and Schmidt (2007) list three important cases extending the \mathbf{M} and \mathbf{P} examples. First, \beta^\diamond_\mathbf{C}(\mathbf{1/2}, \mathbf{1/2}) = \beta_\mathbf{C}(1/2, 1/2), which is Blomqvist Beta (\beta_\mathbf{C}(1/2, 1/2)) (blomCOP) and measures overall dependence.

Second, \beta^\diamond_\mathbf{C}(\mathbf{u}, \mathbf{v}) with \mathbf{u} < 1/2 < \mathbf{v}, which measures dependence in the tail regions. (Note, the author of copBasic thinks “regions” as a plural is need in the previous sentence; Schmid and Schmidt (2007) use the singular “region.” This is potentially important as seemingly simultaneous tail dependency in the lower and upper perspectives would be provided. More discussion is provided in Examples.)

Third and presumably very important in practical applications, \mathrm{lim}_{p\downarrow 0}\, \beta^\diamond_\mathbf{C}(\mathbf{p}, \mathbf{1}) = \lambda^L_{\beta^\diamond_\mathbf{C}} for \mathbf{p} = \mathbf{u} = (p,\cdots,p) measures lower-tail dependence. This measure is equal to the lower-tail dependence parameter \lambda^L_\mathbf{C} = \lambda^L_{\beta^\diamond_\mathbf{C}} without some of the computational nuances required as \lambda^L_\mathbf{C} is defined at taildepCOP.

Schmid and Schmidt (2007) do not list how the upper-tail dependence parameter \lambda^U_\mathbf{C} could be computed in terms of \beta^\diamond_\mathbf{C}. The expression for study of the upper-tail dependency is \lambda^U_{\beta^\diamond_\mathbf{C}} = \beta^\diamond_\mathbf{C}(\mathbf{0}, \mathbf{p}) for \mathbf{p} = \mathbf{v} = (p,\cdots,p) as p \rightarrow 0^+, and \lambda^U_\mathbf{C} = \lambda^U_{\beta^\diamond_\mathbf{C}} without some of the computational nuances required as \lambda^U_\mathbf{C} is defined at taildepCOP. These tail dependencies are computed and compared in the Examples and confirmation of this function being used to estimate both tail-dependency parameters is confirmed.

Usage

blomCOPss(cop=NULL, para=NULL, uu=rep(0.5, 2), vv=rep(0.5, 2), trap.nan=TRUE,
          as.sample=FALSE, ctype=c("weibull", "hazen", "1/n",
                                   "bernstein", "checkerboard"), ...)

Arguments

Value

The \beta^\diamond_\mathbf{C} is returned.

Note

Sample estimation of the \beta^\diamond_\mathbf{C} is possible. The as.sample triggers internally a call to the empirical copula (\mathbf{C}_n) (EMPIRcop) for the ctype for the copula and its survival function form. Expansive more details are provided by taildepCOP (section Note::DEMONSTRATION (Tail Dependence)). A comparison of the \hat\lambda^U_{\beta^\diamond_\mathbf{C}} and \hat\lambda^U_{\beta^\diamond_\mathbf{C}} is made.

Author(s)

W.H. Asquith

References

Schmid, Friedrich, and Schmidt, Rafael, 2007, Nonparametric inference on multivariate versions of Blomqvist's beta and related measures of tail dependence: Metrika, v. 66, pp. 323–354, doi:10.1007/s00184-006-0114-3.

See Also

blomCOP, blomatrixCOP, taildepCOP

Examples

blomCOP(  cop=PSP) # [1] 0.3333333
blomCOPss(cop=PSP) # [1] 0.3333333

## Not run: 
# The calls below for blomCOPss() are technically the same for sample versions.
UV <- simCOP(1000, cop=PSP, graphics=FALSE)  # HatBeta(0.1,0.9) = 0.277___
blomCOPss(para=UV, cop=EMPIRcop,   uu=c(0.1,0.1), vv=c(0.90,0.90))
blomCOPss(para=UV, as.sample=TRUE, uu=c(0.1,0.1), vv=c(0.90,0.90)) #
## End(Not run)

## Not run: 
set.seed(1)
para <- c(3, 6) # define parameters of two-parameter GHcop
UV <- simCOP(1000, cop=GHcop, para=para) # simulate to show general structure

# compute the tail dependencies from havling into the limits
taildepCOP(cop=GHcop, para=para, plot=TRUE)
# lower tail dependency = 0.96222
# upper tail dependency = 0.74008
# The two parameters influence how strongly the tail dependencies are.

# Schmid and Schmidt (2007, eq. 24) define the lower-tail dependency in terms of
# the Beta and p-->0 Beta(c(p,p), c(1,1)). Lets compute these and produce content
# suitable to show on the tail-dependency plot that the assertion for the lower
# dependency by Beta() is correct, which it is and then extend to the upper-tail
# dependency parameter that the authors seem to not have defined.
usr <- par()$usr[1:2]         # grab horizontal edges of the plot, and set up the
uuLO <- rep(pnorm(usr[1]), 2) # the uu for the lower tail and the vv for the upper
vvUP <- rep(pnorm(usr[2]), 2) # tail and then plot both with overplotting symbols
# lower-tail estimate and see how it plots along the value from taildepCOP()
SchmidsL <- blomCOPss(cop=GHcop, para=para, uu=uuLO, vv=c(1,1))
points(usr[1], SchmidsL, col="darkgreen", cex=2, pch=1, lwd=2)
points(usr[1], SchmidsL, col="darkgreen", cex=2, pch=3, lwd=2)
points(usr[1], SchmidsL, col="darkgreen", cex=2, pch=4, lwd=2)
# upper-tail estimate and see how it plots along the value from taildepCOP()
SchmidsU <- blomCOPss(cop=GHcop, para=para, uu=c(0,0), vv=vvUP)
points(usr[2], SchmidsU, col="darkgreen", cex=2, pch=1, lwd=2)
points(usr[2], SchmidsU, col="darkgreen", cex=2, pch=3, lwd=2)
points(usr[2], SchmidsU, col="darkgreen", cex=2, pch=4, lwd=2)
# SchmidsL lower tail dependency = 0.962224
# SchmidsU upper tail dependency = 0.740079
# The author has an expectation that the SchmidsL and SchmidsU values are
# more reliable than those stemming from taildepCOP() because of the limiting
# behavior (or its implementation therein) compared to direct computation by
# blomCOPss().

# Mow for sake of curiosity, let us see how the trajectory of the Blomqvist
# (Schmid--Schmidt) Betas at arriving at the tail dependencies as p-->0|1.
# It is very informative that the trajectories of blomCOPss() and taildepCOP()
# as each hones towards the two dependency parameters are different and this
# highlights the fact that the computational underpinnings are different.
psl <- pnorm(seq(0, usr[1], by=-diff(range(c(0, usr[1]))) / 1000))
lines(qnorm(psl), sapply(psl, function(p) {
              blomCOPss(cop=GHcop, para=para, uu=rep(p, 2), vv=c(1,1)) }),
      col="darkgreen", lty=2, lwd=2)
psu <- pnorm(seq(0, usr[2], by= diff(range(c(0, usr[2]))) / 1000))
lines(qnorm(psu), sapply(psu, function(p) {
              blomCOPss(cop=GHcop, para=para, uu=c(0,0), vv=rep(p, 2)) }),
      col="darkgreen", lty=2, lwd=2) #
## End(Not run)

A Matrix of Blomqvist-like Betas of a Copula

Description

Compute the Blomqvist-like Betas matrix \beta^\circ_\mathbf{C}-matrix of a copula, which is defined at presumably strategic points within \mathcal{I}^2, as (for as.blomCOPss=FALSE argument)

\beta^\circ_\mathbf{C} = \frac{\mathbf{C}(u^\circ,v^\circ)}{\mathbf{\Pi}(1/2, 1/2)} - 1\mbox{,}

where the u^\circ and v^\circ are of two types of gridded locations in \mathcal{I}^2 space and if u^\circ = 1/2 and v^\circ = 1/2, then central location of the matrix is Blomqvist Beta (blomCOP). The definition of \beta^\circ_\mathbf{C} is such that the matrix is entirely zero for the independence copula (\mathbf{\Pi}(u,v)) (P) when \mathbf{C}(u^\circ,v^\circ) = \mathbf{\Pi}(u,v) at the medial location u,v=1/2. Also, the definition here might be unique to the copBasic package. The decile version (blomatrixCOPdec) of this function uses u^\circ \in (1, 5, 9) / 10 and v^\circ \in (1, 5, 9) / 10. Whereas, the quartile version (blomatrixCOPiqr) of this function uses u^\circ \in (25, 50, 75) / 100 and v^\circ \in (25, 50, 75)/100. If as.blomCOPss=TRUE argument is set (default operation), then the coordinate locations in the matrix become the \beta^\diamond_\mathbf{C} of blomCOPss. As a rule \beta^\circ_\mathbf{C} \ne \beta^\diamond_\mathbf{C}.

Usage

blomatrixCOPdec(cop=NULL, para=NULL, as.sample=FALSE, as.blomCOPss=TRUE,
                  ctype=c("weibull", "hazen", "1/n",
                          "bernstein", "checkerboard"), ...)
blomatrixCOPiqr(cop=NULL, para=NULL, as.sample=FALSE, as.blomCOPss=TRUE,
                  ctype=c("weibull", "hazen", "1/n",
                          "bernstein", "checkerboard"), ...)

Arguments

Value

The matrix for \beta^\circ_\mathbf{C} is returned depending on whether the decile or quartile version has been called.

Author(s)

W.H. Asquith

See Also

blomCOP, blomCOPss

Examples

round(blomatrixCOPdec(cop=P), digits=8);     round(blomatrixCOPiqr(cop=P), digits=8)
#          U|V=0.10 U|V=0.50 U|V=0.90        #          U|V=0.25 U|V=0.50 U|V=0.75
# U|V=0.90        0        0        0        # U|V=0.75        0        0        0
# U|V=0.50        0        0        0        # U|V=0.50        0        0        0
# U|V=0.10        0        0        0        # U|V=0.25        0        0        0

round(blomatrixCOPdec(cop=PSP, as.blomCOPss=TRUE), digits=8)
#           U|V=0.10   U|V=0.50   U|V=0.90
# U|V=0.90 0.4736842  0.8181818  0.5153268
# U|V=0.50 0.8181818  0.3333333  0.6459330
# U|V=0.10 0.8901099  0.4736842  0.1708292

round(blomatrixCOPdec(cop=PSP, as.blomCOPss=FALSE), digits=8)
#            U|V=0.10   U|V=0.50  U|V=0.90
# U|V=0.90 0.09890110 0.81818182 4.2631579
# U|V=0.50 0.05263158 0.33333333 0.8181818
# U|V=0.10 0.01010101 0.05263158 0.0989011

## Not run: 
set.seed(1)
td <- c(0.10, 0.50, 0.90)
UVn <- simCOP(n=5000, cop=glueCOP, col=8,
          para=list(glue=0.4, cop1 =PLcop,           cop2=PLcop,
                             para1=PLpar(rho=-0.5), para2=PLpar(rho=+0.5)))
points(td, rep(td[3], 3), cex=2, lwd=2, pch=3, col="red")
points(td, rep(td[2], 3), cex=2, lwd=2, pch=3, col="red")
points(td, rep(td[1], 3), cex=2, lwd=2, pch=3, col="red")

print(blomatrixCOPdec(as.sample=TRUE, para=UVn, ctype="weibull"))
#             U|V=0.10 U|V=0.50 U|V=0.90
# U|V=0.90 -0.08222222   -0.580   -0.190
# U|V=0.50  0.30800000    0.112    0.264
# U|V=0.10  0.84000000    0.620    0.262

BMdn <- blomatrixCOPdec(cop=glueCOP,
          para=list(glue=0.4,  cop1=PLcop,            cop2=PLcop,
                              para1=PLpar(rho=-0.5), para2=PLpar(rho=+0.5)))
print(round(BMdn, digits=8))
#             U|V=0.10   U|V=0.50   U|V=0.90
# U|V=0.90 -0.08110464 -0.5569028 -0.2053772
# U|V=0.50  0.33449815  0.1202744  0.2424668
# U|V=0.10  0.75217766  0.6013719  0.2424668 
## End(Not run)


## Not run: 
set.seed(1); nsim <- 2000
para.pop <- list( cop1=GHcop,             cop2=PLcop,  alpha=0.359,
                 para1=c(4.003, 1.099),  para2=0.882,   beta=0.292)
UVs <- simCOP(nsim, cop=composite2COP, para=para.pop)
mtext("GIVEN THIS SAMPLE")
Rho <- rhoCOP(as.sample=TRUE, para=UVs) # Spearman Rho
BMn <- blomatrixCOPdec(as.sample=TRUE, para=UVs, ctype="weibull")

parafn <- function(k) {
  c(exp(k[1])+1, exp(k[2]), exp(k[3]), pnorm(k[4]), pnorm(k[5]))
}
parafn_list <- function(k) {
  k <- parafn(k)
  list(cop1=GHcop, para1=c(k[1], k[2]), alpha=k[4],
       cop2=PLcop, para2=k[4],          beta=k[5])
}
BLOM_ofun <- function(para, statmat=NULL, parafn=NULL, rho=NA) {
   para <- parafn(para)
   new.para <- list(cop1=GHcop, para1=para[1:2], alpha=para[4],
                    cop2=PLcop, para2=para[3],    beta=para[5])
   bm <- blomatrixCOPdec(cop=composite2COP, para=new.para)
   err <- sum((statmat - bm)^2) + (rhoCOP(cop=composite2COP, para=new.para) - rho)^2
   #print(c(para, err))
   return(err)
}

run1 <- function(graphics=TRUE, nsim=0) {
  par.init <- c(log(1), log(1), log(1), qnorm(0.5), qnorm(0.5))
  rt       <- optim(par.init, BLOM_ofun, statmat=BMn, parafn=parafn, rho=Rho)
  para     <- parafn(rt$par)
  para.fit <- list(  cop1=GHcop,      cop2=PLcop,   alpha=para[4],
                    para1=para[1:2], para2=para[3],  beta=para[5])
  uv <- simCOP(nsim, cop=composite2COP, para=para.fit, graphics=graphics, col=2)
  rmse <- round(rmseCOP(uv[,1], uv[,2], ctype="weibull",
                        cop=composite2COP, para=para.fit), digits=8)
  if(graphics) mtext(paste0("RMSE(run1)=", rmse))
  return(list(rmse=rmse, para=para.fit))
}
system.time(RUN1 <- run1(nsim=nsim))
par.init <- c(log(RUN1$para$para1[1]), log(RUN1$para$para1[2]),
              log(RUN1$para$para2), qnorm(RUN1$para$alpha), qnorm(RUN1$para$beta))

RMSE_ofun <- function(para, parafn=NULL) {
   para <- parafn(para)
   new.para <- list(cop1=GHcop, para1=para[1:2], alpha=para[4],
                    cop2=PLcop, para2=para[3],    beta=para[5])
   new.rmse <- rmseCOP(UVs[,1], UVs[,2], cop=composite2COP, para=new.para)
   #print(c(para, new.rmse))
   return(new.rmse)
}
run2 <- function(graphics=TRUE, nsim=0, par.init=NULL) {
  if(is.null(par.init)) {
    par.init <- c(log(1), log(1), log(1), qnorm(0.5), qnorm(0.5))
  }
  rt       <- optim(par.init, RMSE_ofun, parafn=parafn)
  para     <- parafn(rt$par)
  para.fit <- list(  cop1=GHcop,      cop2=PLcop,   alpha=para[4],
                    para1=para[1:2], para2=para[3],  beta=para[5])
  uv <- simCOP(nsim, cop=composite2COP, para=para.fit, graphics=graphics, col=4)
  rmse <- round(rmseCOP(uv[,1], uv[,2], ctype="weibull",
                        cop=composite2COP, para=para.fit), digits=8)
  if(graphics) mtext(paste0("RMSE(run2)=", rmse))
  return(list(rmse=rmse, para=para.fit))
}
system.time(RUN2.1 <- run2(nsim=nsim, par.init=par.init))
system.time(RUN2.2 <- run2(nsim=nsim, par.init=NULL    ))

GIVN <- c(para.pop$alpha, para.pop$para1, para.pop$beta, para.pop$para2)
FIT1   <- c(RUN1$para$alpha, RUN1$para$para1, RUN1$para$beta, RUN1$para$para2)
FIT1   <- round(FIT1, digits=3)
FIT2.1 <- c(RUN2.1$para$alpha, RUN2.1$para$para1, RUN2.1$para$beta, RUN2.1$para$para2)
FIT2.1 <- round(FIT2.1, digits=3)
FIT2.2 <- c(RUN2.2$para$alpha, RUN2.2$para$para1, RUN2.2$para$beta, RUN2.2$para$para2)
FIT2.2 <- round(FIT2.2, digits=3)
nms    <- c("what", "alpha", "para1_1", "para1_2", "beta", "para2")
GIVN   <- c("given",   GIVN);  FIT2.1 <- c("by_Blom1", FIT2.1)
FIT1   <- c("by_RMSE", FIT1);  FIT2.2 <- c("by_Blom2", FIT2.2)
names(GIVN)   <- nms; names(FIT1)   <- nms
names(FIT2.1) <- nms; names(FIT2.2) <- nms
RESL <- cbind(data.frame(GIVN), data.frame(FIT1), data.frame(FIT2.1), data.frame(FIT2.2))
print(RESL) #
## End(Not run)

Add Asymmetry to a Copula

Description

Adding permutation asymmetry (Chang and Joe, 2020, p. 1596) (isCOP.permsym) is simple for a bivariate copula family. Let \mathbf{C} be a copula with respective vectors of parameters \Theta_\mathbf{C}, then the permutation asymmetry is added through an asymmetry parameter \beta \in (-1, +1) by

\breve{\mathbf{C}}_{\beta;\Theta}(u,v) = v^{-\beta}\cdot\mathbf{C}(u, v^{(1+\beta)};\Theta)\mbox{, and}

for 0 \le \beta \le +1 by

\breve{\mathbf{C}}_{\beta;\Theta}(u,v) = u^{+\beta}\cdot\mathbf{C}(u^{(1-\beta)}, v;\Theta)\mbox{.}

The parameter \beta clashes in name and symbology with a parameter used by functions composite1COP, composite2COP, and composite3COP. As a result, support for alternative naming is provided for compatibility.

Usage

breveCOP(u,v, para, breve=NULL, ...)

Arguments

Value

Value(s) for the copula are returned.

Note

The following descriptions list in detail the structure and content of the para argument where cop1 and cop and para1 and para are respectively synonymous to have some structural similarity to the various copula constructors (compositors) of the copBasic package:

beta

— The \beta asymmetry parameter;

breve

— The \beta asymmetry parameter and presence of breve will not cause the non-use of beta; this feature is present so that beta remains accessible to the compositors that use beta (see Examples);

cop

— Function of the copula \mathbf{C};

cop1

— Alternative naming of the function of the coupla \mathbf{C};

para

— Vector of parameters \Theta_\mathbf{C} for \mathbf{C}; and

para1

— Alternative naming of the vector of parameters \Theta_\mathbf{C} for \mathbf{C}.

The function silently restricts the \beta to its interval as defined, but parameter transform might be useful in some numerical optimization schemes. The following recipes might be useful for transform from a parameter in numerical optimization to the asymmetry parameter:

   #    transform into space for optimization
   BREVEtfunc <- function(p) { return(   qnorm((p[1] + 1) / 2) ) } # [-Inf, +Inf]
   # re-transform back into space for the copula
   BREVErfunc <- function(p) { return(2 * pnorm(p[1]) - 1)       } # [-1  , +1  ]

Author(s)

W.H. Asquith

References

Chang, B., and Joe, H., 2020, Copula diagnostics for asymmetries and conditional dependence: Journal of Applied Statistics, v. 47, no. 9, pp. 1587–1615, doi:10.1080/02664763.2019.1685080.

See Also

COP, convex2COP, convexCOP, composite1COP, composite2COP, composite3COP, FRECHETcop, glueCOP

Examples

para <- list(breve=0.24, cop1=FRECHETcop, para1=c(0.4, 0.56))
breveCOP(0.87, 0.35, para=para) # 0.282743

betas <- seq(-1,1, by=0.01)
bloms <- sapply(betas, function(b) {
             breveCOP(0.15, 0.25, para=list(cop=GLPMcop, para=c(2, 2), beta=b))
         } )
plot(betas, bloms, type="l", main="GLPMcop(u,v; 2,2) by breveCOP(beta)")

## Not run: 
  # Notice the argument cop and para name adjustments to show that
  # translation exists inside the function to have use flexibility.
  para <- list(beta=+0.44, cop1=FRECHETcop, para1=c(0.2, 0.56))
  UV   <- simCOP(1000, cop=breveCOP, para=para)
  para <- list(beta=-0.44, cop= FRECHETcop, para= c(0.2, 0.56))
  UV   <- simCOP(1000, cop=breveCOP, para=para) # 
## End(Not run)

## Not run: 
  # Testing on a comprehensive copula (Plackett)
  betas <- rhos <- thetas <- brhos <- NULL
  for(beta  in seq(-1, 1, by=0.1 )) {
    for(rho in seq(-1, 1, by=0.01))   {
       theta  <- PLACKETTpar(rho=rho, byrho=TRUE)
       thetas <- c(thetas, theta)
       para   <- list(  cop=PLcop,    para=theta, beta=beta)
       brho   <- rhoCOP(cop=breveCOP, para=para)
       betas  <- c(betas, beta); rhos <- c(rhos, rho)
       brhos  <- c(brhos, brho)
    }
  }
  df <- data.frame(beta=betas, theta=thetas, rho=rhos, brho=brhos)
  plot(df$theta, df$brho, log="x", pch=16, cex=0.9, col="seagreen",
       xlab="Plackett parameter", ylab="Spearman Rho")
  lines(df$theta[df$beta == 0], df$brho[df$beta == 0], col="red", lwd=2)
  # Red line is the Plackett in its permutation symmetric definition. #
## End(Not run)

## Not run: 
  # Here is an example for a test using mleCOP() to estimate a 5-parameter asymmetric
  # copula model to "some data" on transition from yesterday to today data for a very
  # large daily time series. The purpose of example here is to demonstrate interfacing
  # to the breveCOP() for it to add asymmetry to composition of two copula.
  myASYMCOP <- function(u,v, para, ...) {
    subpara <- list(alpha=para$alpha, beta=para$beta, cop1=GHcop, para1=para$para1,
                                                      cop2=PLcop, para2=para$para2)
    breveCOP(u,v, cop=convex2COP, para=subpara)
  }
  para <- list(alpha=+0.16934027, cop1=GHcop, para1=c(1.11144148, 10.32292673),
                beta=-0.01923808, cop2=PLcop, para2=3721.82966727)
  UV <- simCOP(30000, cop=myASYMCOP, para=para, pch=16, col=grey(0, 0.1))
  abline(0,1, lwd=3, col="red") #
## End(Not run)

## Not run: 
  # Here is a demonstration of the permutations of the passing of the
  # asymmetry parameter into the function and then by
  UV <- simCOP(1E3, cop=breveCOP, para=list(cop=HRcop, para=5), breve=+0.5)
  UV <- simCOP(1E3, cop=breveCOP, para=list(cop=HRcop, para=5), breve=-0.5)
  UV <- simCOP(1E3, cop=breveCOP, para=list(cop=HRcop, para=5,  beta =+0.5))
  UV <- simCOP(1E3, cop=breveCOP, para=list(cop=HRcop, para=5,  breve=+0.5))
  UV <- simCOP(1E3, cop=breveCOP, para=list(cop=HRcop, para=5,  beta=-0.4, breve=+0.5))

  para <- list(cop1=HRcop, para1=6, cop2=PSP, para2=NULL, alpha=1, beta=0.7)
  myCOP <- function(u,v, para, ...) breveCOP(u,v, cop=composite2COP, para=para)
  para$breve <- "here I am"
  UV <- simCOP(1E3, cop=composite2COP, para=para, seed=1) # breve is not used
  para$breve <- -0.16
  UV <- simCOP(1E3, cop=myCOP,         para=para, seed=1)
  para$breve <- +0.16
  UV <- simCOP(1E3, cop=myCOP,         para=para, seed=1) # 
## End(Not run)

The Co-Copula Function

Description

Compute the co-copula (function) from a copula (Nelsen, 2006, pp. 33–34), which is defined as

\mathrm{Pr}[U > u \mathrm{\ or\ } V > v] = \mathbf{C}^{\star}(u',v') = 1 - \mathbf{C}(u',v')\mbox{,}

where \mathbf{C}^{\star}(u',v') is the co-copula and u' and v' are exceedance probabilities and are equivalent to 1-u and 1-v respectively. The co-copula is the expression for the probability that either U > u or V > v when the arguments to \mathbf{C}^{\star}(u',v') are exceedance probabilities, which is unlike the dual of a copula (function) (see duCOP) that provides \mathrm{Pr}[U \le u \mathrm{\ or\ } V \le v].

The co-copula is a function and not in itself a copula. Some rules of copulas mean that \mathbf{C}(u,v) + \mathbf{C}^{\star}(u',v') \equiv 1 or in copBasic syntax that the functions COP(u,v) + coCOP(u,v) equal unity if the exceedance argument to coCOP is set to FALSE.

The function coCOP gives “risk” against failure if failure is defined as either hazard source U or V occuring by themselves or if both occurred at the same time. Expressing this in terms of an annual probability of occurrence (q), one has

q = 1 - \mathrm{Pr}[U > u \mathrm{\ or\ } V > v] = \mathbf{C}^{\star}(u',v') \mbox{\ or}

in R code q <- coCOP(u,v, exceedance=FALSE, ...). So, in yet other words and as a mnemonic: A co-copula is the probabililty of exceedance if the hazard sources collaborate or cooperate to cause failure. Also, q can be computed by q <- coCOP(1 - u, 1 - v, exceedance=TRUE, ...).

Usage

coCOP(u, v, cop=NULL, para=NULL, exceedance=TRUE, ...)

Arguments

Value

The value(s) for the co-copula are returned.

Note

The author (Asquith) finds the use of exceedance probabilities delicate in regards to Nelsen's notation. The coCOP function and surCOP have the exceedance argument to serve as a reminder that the co-copula as defined in the literature uses exceedance probabilities as its arguments, although the arguments as code u and v do not mimic the overline nomenclature (\,\overline{\cdots}\,) of the exceedance (survival) probabilities.

Author(s)

W.H. Asquith

References

Nelsen, R.B., 2006, An introduction to copulas: New York, Springer, 269 p.

See Also

COP, surCOP, duCOP

Examples

u <- 1 - runif(1); v <- 1 - runif(1) # as exceedance, in order to reinforce the
# change to exceedance instead of nonexceedance that otherwise dominates this package
message("Exceedance probabilities u' and v' are ", u, " and ", v)
coCOP(u,v,cop=PLACKETTcop, para=10) # Positive association Plackett

# computation using  manual  manipulation to nonexceedance probability
1 - COP(cop=PSP,(1-u),(1-v))
# computation using internal manipulation to nonexceedance probability
  coCOP(cop=PSP,   u,    v)

# Next demonstrate COP + coCOP = unity.
"MOcop.formula" <- function(u,v, para=para, ...) { # Marshall-Olkin copula
   alpha <- para[1]; beta <- para[2]; return(min(v*u^(1-alpha), u*v^(1-beta)))
}
"MOcop" <- function(u,v, ...) { asCOP( u,  v, f=MOcop.formula, ...) }
u <- 0.2; v <- 0.75; ab <- c(1.5, 0.3)
COP(u,v, cop=MOcop, para=ab) + coCOP(1-u,1-v, cop=MOcop, para=ab) # UNITY

Composition of a Single Symmetric Copula with Two Compositing Parameters (Khoudraji Device with Pi Independence)

Description

The composition of a single copula (Salvadori et al., 2006, p. 266, prop. C.3) is created by the following result related to “composition of copulas” in that reference. This construction technique is named the Khoudraji device within the copula package (see khoudrajiCopula therein) (Hofert et al., 2018, pp. 120–121). Suppose \mathbf{C}(u,v) is a symmetric copula (see COP) with parameters \Theta and \mathbf{C} \ne \mathbf{\Pi} (for \mathbf{\Pi} see P), then a family of generally asymmetric copulas \mathbf{C}_{\alpha,\beta; \Theta} with two compositing parameters 0 < \alpha,\beta < 1, and \alpha \ne \beta, which also includes just the copula \mathbf{C}(u,v) as a limiting case for \alpha = \beta = 0 and is given by