[Vinecopula-commits] r85 - in pkg: . R man
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Di Mär 24 22:44:01 CET 2015
Author: tnagler
Date: 2015-03-24 22:44:00 +0100 (Tue, 24 Mar 2015)
New Revision: 85
Added:
pkg/R/BiCop.R
pkg/R/plot.BiCop.R
pkg/man/BiCop.Rd
pkg/man/plot.BiCop.Rd
Modified:
pkg/DESCRIPTION
pkg/NAMESPACE
pkg/R/BiCopCDF.r
pkg/R/BiCopDeriv.r
pkg/R/BiCopDeriv2.r
pkg/R/BiCopEst.r
pkg/R/BiCopGofTest.r
pkg/R/BiCopHfunc.r
pkg/R/BiCopHfuncDeriv.r
pkg/R/BiCopHfuncDeriv2.r
pkg/R/BiCopLambda.r
pkg/R/BiCopMetaContour.r
pkg/R/BiCopPDF.r
pkg/R/BiCopPar2Beta.r
pkg/R/BiCopPar2TailDep.r
pkg/R/BiCopPar2Tau.r
pkg/R/BiCopSelect.r
pkg/R/BiCopSim.R
pkg/R/RVinePartialcorr.R
pkg/man/BiCopCDF.Rd
pkg/man/BiCopDeriv.Rd
pkg/man/BiCopDeriv2.Rd
pkg/man/BiCopEst.Rd
pkg/man/BiCopGofTest.Rd
pkg/man/BiCopHfunc.Rd
pkg/man/BiCopHfuncDeriv.Rd
pkg/man/BiCopHfuncDeriv2.Rd
pkg/man/BiCopLambda.Rd
pkg/man/BiCopMetaContour.Rd
pkg/man/BiCopPDF.Rd
pkg/man/BiCopPar2Beta.Rd
pkg/man/BiCopPar2TailDep.Rd
pkg/man/BiCopPar2Tau.Rd
pkg/man/BiCopSelect.Rd
pkg/man/BiCopSim.Rd
Log:
introducing 'BiCop' objects for bivariate copulas:
- add constructor 'BiCop' and plotting generic 'plot.BiCop'
- define results of 'BiCopEst'/'BiCopSelect' as 'BiCop' objects
- add compatibility with other BiCopXyz functions (BiCopPDF, BiCopPar2Tau, etc.)
- add/adjust manual pages and examples
Modified: pkg/DESCRIPTION
===================================================================
--- pkg/DESCRIPTION 2015-03-19 15:56:40 UTC (rev 84)
+++ pkg/DESCRIPTION 2015-03-24 21:44:00 UTC (rev 85)
@@ -6,7 +6,7 @@
Author: Ulf Schepsmeier, Jakob Stoeber, Eike Christian Brechmann, Benedikt Graeler
Maintainer: Tobias Erhardt <tobias.erhardt at tum.de>
Depends: R (>= 2.11.0)
-Imports: MASS, mvtnorm, igraph, methods, copula, ADGofTest
+Imports: MASS, mvtnorm, igraph, methods, copula, ADGofTest, lattice
Suggests: CDVine, TSP
Description: Tools for bivariate exploratory data analysis, bivariate copula selection and (vine) tree construction are provided. Vine copula models can be estimated either sequentially or by joint maximum likelihood estimation. Sampling algorithms and plotting methods are included. Data is assumed to lie in the unit hypercube (so-called copula data). For C- and D-vines links to the package CDVine are provided.
License: GPL (>= 2)
Modified: pkg/NAMESPACE
===================================================================
--- pkg/NAMESPACE 2015-03-19 15:56:40 UTC (rev 84)
+++ pkg/NAMESPACE 2015-03-24 21:44:00 UTC (rev 85)
@@ -3,11 +3,13 @@
import(igraph)
import(copula)
import(methods)
+import(lattice)
importFrom(ADGofTest, ad.test)
export(pobs)
+export(BiCop)
export(BiCopEst)
export(BiCopMetaContour)
export(BiCopChiPlot)
@@ -98,5 +100,6 @@
S3method(as.copuladata, matrix)
S3method(as.copuladata, list)
S3method(pairs, copuladata)
+S3method(plot, BiCop)
useDynLib("VineCopula")
\ No newline at end of file
Added: pkg/R/BiCop.R
===================================================================
--- pkg/R/BiCop.R (rev 0)
+++ pkg/R/BiCop.R 2015-03-24 21:44:00 UTC (rev 85)
@@ -0,0 +1,92 @@
+BiCop <- function(family, par, par2 = 0) {
+ ## family/parameter consistency checks
+ if (!(family %in% c(0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10,
+ 13, 14, 16, 17, 18, 19, 20,
+ 23, 24, 26, 27, 28, 29, 30,
+ 33, 34, 36, 37, 38, 39, 40,
+ 41, 51, 61, 71,
+ 104, 114, 124, 134,
+ 204, 214, 224, 234)))
+ stop("Copula family not implemented.")
+ if (family %in% c(2, 7, 8, 9, 10,
+ 17, 18, 19, 20,
+ 27, 28, 29, 30,
+ 37, 38, 39, 40,
+ 104, 114, 124, 134,
+ 204, 214, 224, 234) && par2 == 0)
+ stop("For t-, BB1, BB6, BB7, BB8 and Tawn copulas, 'par2' must be set.")
+ if (family %in% c(1, 3, 4, 5, 6,
+ 13, 14, 16,
+ 23, 24, 26,
+ 33, 34, 36,
+ 41, 51, 61, 71) && length(par) < 1)
+ stop("'par' not set.")
+
+ if ((family == 1 || family == 2) && abs(par[1]) >= 1)
+ stop("The parameter of the Gaussian and t-copula has to be in the interval (-1,1).")
+ if (family == 2 && par2 <= 2)
+ stop("The degrees of freedom parameter of the t-copula has to be larger than 2.")
+ if ((family == 3 || family == 13) && par <= 0)
+ stop("The parameter of the Clayton copula has to be positive.")
+ if ((family == 4 || family == 14) && par < 1)
+ stop("The parameter of the Gumbel copula has to be in the interval [1,oo).")
+ if ((family == 6 || family == 16) && par <= 1)
+ stop("The parameter of the Joe copula has to be in the interval (1,oo).")
+ if (family == 5 && par == 0)
+ stop("The parameter of the Frank copula has to be unequal to 0.")
+ if ((family == 7 || family == 17) && par <= 0)
+ stop("The first parameter of the BB1 copula has to be positive.")
+ if ((family == 7 || family == 17) && par2 < 1)
+ stop("The second parameter of the BB1 copula has to be in the interval [1,oo).")
+ if ((family == 8 || family == 18) && par <= 0)
+ stop("The first parameter of the BB6 copula has to be in the interval [1,oo).")
+ if ((family == 8 || family == 18) && par2 < 1)
+ stop("The second parameter of the BB6 copula has to be in the interval [1,oo).")
+ if ((family == 9 || family == 19) && par < 1)
+ stop("The first parameter of the BB7 copula has to be in the interval [1,oo).")
+ if ((family == 9 || family == 19) && par2 <= 0)
+ stop("The second parameter of the BB7 copula has to be positive.")
+ if ((family == 10 || family == 20) && par < 1)
+ stop("The first parameter of the BB8 copula has to be in the interval [1,oo).")
+ if ((family == 10 || family == 20) && (par2 <= 0 || par2 > 1))
+ stop("The second parameter of the BB8 copula has to be in the interval (0,1].")
+ if ((family == 23 || family == 33) && par >= 0)
+ stop("The parameter of the rotated Clayton copula has to be negative.")
+ if ((family == 24 || family == 34) && par > -1)
+ stop("The parameter of the rotated Gumbel copula has to be in the interval (-oo,-1].")
+ if ((family == 26 || family == 36) && par >= -1)
+ stop("The parameter of the rotated Joe copula has to be in the interval (-oo,-1).")
+ if ((family == 27 || family == 37) && par >= 0)
+ stop("The first parameter of the rotated BB1 copula has to be negative.")
+ if ((family == 27 || family == 37) && par2 > -1)
+ stop("The second parameter of the rotated BB1 copula has to be in the interval (-oo,-1].")
+ if ((family == 28 || family == 38) && par >= 0)
+ stop("The first parameter of the rotated BB6 copula has to be in the interval (-oo,-1].")
+ if ((family == 28 || family == 38) && par2 > -1)
+ stop("The second parameter of the rotated BB6 copula has to be in the interval (-oo,-1].")
+ if ((family == 29 || family == 39) && par > -1)
+ stop("The first parameter of the rotated BB7 copula has to be in the interval (-oo,-1].")
+ if ((family == 29 || family == 39) && par2 >= 0)
+ stop("The second parameter of the rotated BB7 copula has to be negative.")
+ if ((family == 30 || family == 40) && par > -1)
+ stop("The first parameter of the rotated BB8 copula has to be in the interval (-oo,-1].")
+ if ((family == 30 || family == 40) && (par2 >= 0 || par2 < (-1)))
+ stop("The second parameter of the rotated BB8 copula has to be in the interval [-1,0).")
+ if ((family == 41 || family == 51) && par <= 0)
+ stop("The parameter of the reflection asymmetric copula has to be positive.")
+ if ((family == 61 || family == 71) && par >= 0)
+ stop("The parameter of the rotated reflection asymmetric copula has to be negative.")
+ if ((family == 104 || family == 114 || family == 204 || family == 214) && par < 1)
+ stop("Please choose 'par' of the Tawn copula in [1,oo).")
+ if ((family == 104 || family == 114 || family == 204 || family == 214) && (par2 < 0 || par2 > 1))
+ stop("Please choose 'par2' of the Tawn copula in [0,1].")
+ if ((family == 124 || family == 134 || family == 224 || family == 234) && par > -1)
+ stop("Please choose 'par' of the Tawn copula in (-oo,-1].")
+ if ((family == 124 || family == 134 || family == 224 || family == 234) && (par2 < 0 || par2 > 1))
+ stop("Please choose 'par2' of the Tawn copula in [0,1].")
+
+ ## return BiCop object
+ out <- list(family = family, par = par, par2 = par2)
+ class(out) <- "BiCop"
+ out
+}
\ No newline at end of file
Modified: pkg/R/BiCopCDF.r
===================================================================
--- pkg/R/BiCopCDF.r 2015-03-19 15:56:40 UTC (rev 84)
+++ pkg/R/BiCopCDF.r 2015-03-24 21:44:00 UTC (rev 85)
@@ -1,6 +1,5 @@
-BiCopCDF <- function(u1, u2, family, par, par2 = 0) {
-
- ## sanity checks
+BiCopCDF <- function(u1, u2, family, par, par2 = 0, obj = NULL) {
+ ## sanity checks for u1, u2
if (is.null(u1) == TRUE || is.null(u2) == TRUE)
stop("u1 and/or u2 are not set or have length zero.")
if (any(u1 > 1) || any(u1 < 0))
@@ -9,6 +8,29 @@
stop("Data has be in the interval [0,1].")
if (length(u1) != length(u2))
stop("Lengths of 'u1' and 'u2' do not match.")
+
+ ## extract family and parameters if BiCop object is provided
+ if (missing(family))
+ family <- NA
+ if (missing(par))
+ par <- NA
+ if (!is.null(obj)) {
+ stopifnot(class(obj) == "BiCop")
+ family <- obj$family
+ par <- obj$par
+ par2 <- obj$par2
+ }
+ if (class(family) == "BiCop") {
+ # for short hand usage extract from family
+ obj <- family
+ family <- obj$family
+ par <- obj$par
+ par2 <- obj$par2
+ }
+
+ ## sanity checks for family and parameters
+ if (is.na(family) | is.na(par))
+ stop("Provide either 'family' and 'par' or 'obj'")
if (family == 2)
stop("The CDF of the t-copula is not implemented.")
if (!(family %in% c(0, 1, 3, 4, 5, 6, 7, 8, 9, 10, 13, 14, 16, 17, 18, 19, 20,
@@ -181,5 +203,6 @@
}
}
- return(res)
+ ## return results
+ res
}
Modified: pkg/R/BiCopDeriv.r
===================================================================
--- pkg/R/BiCopDeriv.r 2015-03-19 15:56:40 UTC (rev 84)
+++ pkg/R/BiCopDeriv.r 2015-03-24 21:44:00 UTC (rev 85)
@@ -1,4 +1,5 @@
-BiCopDeriv <- function(u1, u2, family, par, par2 = 0, deriv = "par", log = FALSE) {
+BiCopDeriv <- function(u1, u2, family, par, par2 = 0, deriv = "par", log = FALSE, obj = NULL) {
+ ## sanity checks for u1, u2
if (is.null(u1) == TRUE || is.null(u2) == TRUE)
stop("u1 and/or u2 are not set or have length zero.")
if (length(u1) != length(u2))
@@ -7,13 +8,37 @@
stop("Data has be in the interval [0,1].")
if (any(u2 > 1) || any(u2 < 0))
stop("Data has be in the interval [0,1].")
+
+ ## extract family and parameters if BiCop object is provided
+ if (missing(family))
+ family <- NA
+ if (missing(par))
+ par <- NA
+ if (!is.null(obj)) {
+ stopifnot(class(obj) == "BiCop")
+ family <- obj$family
+ par <- obj$par
+ par2 <- obj$par2
+ }
+ if (class(family) == "BiCop") {
+ # for short hand usage extract from family
+ if (class(par) == "character")
+ deriv <- par
+ obj <- family
+ family <- obj$family
+ par <- obj$par
+ par2 <- obj$par2
+ }
+
+ ## sanity checks for family and parameters
+ if (is.na(family) | is.na(par))
+ stop("Provide either 'family' and 'par' or 'obj'")
if (!(family %in% c(0, 1, 2, 3, 4, 5, 6, 13, 14, 16, 23, 24, 26, 33, 34, 36)))
stop("Copula family not implemented.")
if (family == 2 && par2 == 0)
stop("For t-copulas, 'par2' must be set.")
if (family %in% c(1, 3, 4, 5, 6, 13, 14, 16, 23, 24, 26, 33, 34, 36) && length(par) < 1)
stop("'par' not set.")
-
if ((family == 1 || family == 2) && abs(par[1]) >= 1)
stop("The parameter of the Gaussian and t-copula has to be in the interval (-1,1).")
if (family == 2 && par2 <= 2)
@@ -38,10 +63,8 @@
if (log == TRUE && (deriv %in% c("u1", "u2")))
stop("The derivative with respect to one of the arguments are not available in the log case.")
- # Unterscheidung in die verschiedenen Ableitungen
-
+ ## call C routines for specified 'deriv' case
n <- length(u1)
-
if (log == TRUE) {
if (deriv == "par") {
if (family == 2) {
@@ -125,5 +148,6 @@
}
}
- return(out)
+ ## return result
+ out
}
Modified: pkg/R/BiCopDeriv2.r
===================================================================
--- pkg/R/BiCopDeriv2.r 2015-03-19 15:56:40 UTC (rev 84)
+++ pkg/R/BiCopDeriv2.r 2015-03-24 21:44:00 UTC (rev 85)
@@ -1,4 +1,5 @@
-BiCopDeriv2 <- function(u1, u2, family, par, par2 = 0, deriv = "par") {
+BiCopDeriv2 <- function(u1, u2, family, par, par2 = 0, deriv = "par", obj = NULL) {
+ ## sanity checks for u1, u2
if (is.null(u1) == TRUE || is.null(u2) == TRUE)
stop("u1 and/or u2 are not set or have length zero.")
if (length(u1) != length(u2))
@@ -7,6 +8,31 @@
stop("Data has be in the interval [0,1].")
if (any(u2 > 1) || any(u2 < 0))
stop("Data has be in the interval [0,1].")
+
+ ## extract family and parameters if BiCop object is provided
+ if (missing(family))
+ family <- NA
+ if (missing(par))
+ par <- NA
+ if (!is.null(obj)) {
+ stopifnot(class(obj) == "BiCop")
+ family <- obj$family
+ par <- obj$par
+ par2 <- obj$par2
+ }
+ if (class(family) == "BiCop") {
+ # for short hand usage extract from family
+ if (class(par) == "character")
+ deriv <- par
+ obj <- family
+ family <- obj$family
+ par <- obj$par
+ par2 <- obj$par2
+ }
+
+ ## sanity checks for family and parameters
+ if (is.na(family) | is.na(par))
+ stop("Provide either 'family' and 'par' or 'obj'")
if (!(family %in% c(0, 1, 2, 3, 4, 5, 6, 13, 14, 16, 23, 24, 26, 33, 34, 36)))
stop("Copula family not implemented.")
if (family == 2 && par2 == 0)
Modified: pkg/R/BiCopEst.r
===================================================================
--- pkg/R/BiCopEst.r 2015-03-19 15:56:40 UTC (rev 84)
+++ pkg/R/BiCopEst.r 2015-03-24 21:44:00 UTC (rev 85)
@@ -332,7 +332,7 @@
}
## store estimated parameters
- out2 <- list()
+ out2 <- list(family = family)
if (length(theta) == 2) {
out2$par <- theta[1]
out2$par2 <- theta[2]
@@ -353,6 +353,7 @@
}
## return results
+ class(out2) <- "BiCop"
out2
}
Modified: pkg/R/BiCopGofTest.r
===================================================================
--- pkg/R/BiCopGofTest.r 2015-03-19 15:56:40 UTC (rev 84)
+++ pkg/R/BiCopGofTest.r 2015-03-24 21:44:00 UTC (rev 85)
@@ -1,10 +1,11 @@
BiCopGofTest <- function(u1, u2, family, par = 0, par2 = 0, method = "white", max.df = 30,
- B = 100) {
+ B = 100, obj = NULL) {
if (method == "White")
method <- "white"
if (method == "Kendall")
method <- "kendall"
+ ## sanity checks for u1, u2
if (is.null(u1) == TRUE || is.null(u2) == TRUE)
stop("u1 and/or u2 are not set or have length zero.")
if (length(u1) != length(u2))
@@ -13,6 +14,27 @@
stop("Data has be in the interval [0,1].")
if (any(u2 > 1) || any(u2 < 0))
stop("Data has be in the interval [0,1].")
+
+ ## extract family and parameters if BiCop object is provided
+ if (missing(family))
+ family <- NA
+ if (!is.null(obj)) {
+ stopifnot(class(obj) == "BiCop")
+ family <- obj$family
+ par <- obj$par
+ par2 <- obj$par2
+ }
+ if (class(family) == "BiCop") {
+ # for short hand usage extract from family
+ obj <- family
+ family <- obj$family
+ par <- obj$par
+ par2 <- obj$par2
+ }
+
+ ## sanity checks for family and parameters
+ if (is.na(family))
+ stop("Provide either 'family' and 'par' or 'obj'")
if (!(family %in% c(0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 13, 14, 16, 17, 18, 19,
20, 23, 24, 26, 27, 28, 29, 30, 33, 34, 36, 37, 38, 39, 40, 43, 44)))
stop("Copula family not implemented.")
Modified: pkg/R/BiCopHfunc.r
===================================================================
--- pkg/R/BiCopHfunc.r 2015-03-19 15:56:40 UTC (rev 84)
+++ pkg/R/BiCopHfunc.r 2015-03-24 21:44:00 UTC (rev 85)
@@ -1,8 +1,16 @@
-######################################### BiCopHfunc # # Input: # u1,u2 copula data # family copula family # par copula
-######################################### parameter # par2 copula parameter 2 # # Output: # hfunc1 h-function h(u1,u2) #
-######################################### hfunc2 h-function h(u2,u1) #
+###### BiCopHfunc
+# Input:
+# u1,u2 copula data
+# family copula family
+# par copula parameter
+# par2 copula parameter 2
+#
+# Output:
+# hfunc1 h-function h(u1,u2)
+# hfunc2 h-function h(u2,u1)
-BiCopHfunc <- function(u1, u2, family, par, par2 = 0) {
+BiCopHfunc <- function(u1, u2, family, par, par2 = 0, obj = NULL) {
+ ## sanity checks for u1, u2
if (is.null(u1) == TRUE || is.null(u2) == TRUE)
stop("u1 and/or u2 are not set or have length zero.")
if (length(u1) != length(u2))
@@ -11,6 +19,29 @@
stop("Data has be in the interval [0,1].")
if (any(u2 > 1) || any(u2 < 0))
stop("Data has be in the interval [0,1].")
+
+ ## extract family and parameters if BiCop object is provided
+ if (missing(family))
+ family <- NA
+ if (missing(par))
+ par <- NA
+ if (!is.null(obj)) {
+ stopifnot(class(obj) == "BiCop")
+ family <- obj$family
+ par <- obj$par
+ par2 <- obj$par2
+ }
+ if (class(family) == "BiCop") {
+ # for short hand usage extract from family
+ obj <- family
+ family <- obj$family
+ par <- obj$par
+ par2 <- obj$par2
+ }
+
+ ## sanity checks for family and parameters
+ if (is.na(family) | is.na(par))
+ stop("Provide either 'family' and 'par' or 'obj'")
if (!(family %in% c(0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 13, 14, 16, 17, 18, 19,
20, 23, 24, 26, 27, 28, 29, 30, 33, 34, 36, 37, 38, 39,
40, 41, 42, 51, 52, 61, 62, 71, 72,
@@ -88,6 +119,7 @@
n <- length(u1)
+ ## h(u2 | u1)
hfunc1 <- .C("Hfunc1",
as.integer(family),
as.integer(n),
@@ -97,7 +129,7 @@
as.double(par2),
as.double(rep(0, n)),
PACKAGE = "VineCopula")[[7]]
-
+ ## h(u1|u2)
hfunc2 <- .C("Hfunc2",
as.integer(family),
as.integer(n),
@@ -108,7 +140,6 @@
as.double(rep(0, n)),
PACKAGE = "VineCopula")[[7]]
-
- hfunc <- list(hfunc1 = hfunc1, hfunc2 = hfunc2)
- return(hfunc)
+ ## return results
+ list(hfunc1 = hfunc1, hfunc2 = hfunc2)
}
Modified: pkg/R/BiCopHfuncDeriv.r
===================================================================
--- pkg/R/BiCopHfuncDeriv.r 2015-03-19 15:56:40 UTC (rev 84)
+++ pkg/R/BiCopHfuncDeriv.r 2015-03-24 21:44:00 UTC (rev 85)
@@ -1,4 +1,5 @@
-BiCopHfuncDeriv <- function(u1, u2, family, par, par2 = 0, deriv = "par") {
+BiCopHfuncDeriv <- function(u1, u2, family, par, par2 = 0, deriv = "par", obj = NULL) {
+ ## sanity checks for u1, u2
if (is.null(u1) == TRUE || is.null(u2) == TRUE)
stop("u1 and/or u2 are not set or have length zero.")
if (length(u1) != length(u2))
@@ -7,6 +8,31 @@
stop("Data has be in the interval [0,1].")
if (any(u2 > 1) || any(u2 < 0))
stop("Data has be in the interval [0,1].")
+
+ ## extract family and parameters if BiCop object is provided
+ if (missing(family))
+ family <- NA
+ if (missing(par))
+ par <- NA
+ if (!is.null(obj)) {
+ stopifnot(class(obj) == "BiCop")
+ family <- obj$family
+ par <- obj$par
+ par2 <- obj$par2
+ }
+ if (class(family) == "BiCop") {
+ # for short hand usage extract from family
+ if (class(par) == "character")
+ deriv <- par
+ obj <- family
+ family <- obj$family
+ par <- obj$par
+ par2 <- obj$par2
+ }
+
+ ## sanity checks for family and parameters
+ if (is.na(family) | is.na(par))
+ stop("Provide either 'family' and 'par' or 'obj'")
if (!(family %in% c(0, 1, 2, 3, 4, 5, 6, 13, 14, 16, 23, 24, 26, 33, 34, 36)))
stop("Copula family not implemented.")
if (family == 2 && par2 == 0)
Modified: pkg/R/BiCopHfuncDeriv2.r
===================================================================
--- pkg/R/BiCopHfuncDeriv2.r 2015-03-19 15:56:40 UTC (rev 84)
+++ pkg/R/BiCopHfuncDeriv2.r 2015-03-24 21:44:00 UTC (rev 85)
@@ -1,4 +1,5 @@
-BiCopHfuncDeriv2 <- function(u1, u2, family, par, par2 = 0, deriv = "par") {
+BiCopHfuncDeriv2 <- function(u1, u2, family, par, par2 = 0, deriv = "par", obj = NULL) {
+ ## sanity checks for u1, u2
if (is.null(u1) == TRUE || is.null(u2) == TRUE)
stop("u1 and/or u2 are not set or have length zero.")
if (length(u1) != length(u2))
@@ -7,6 +8,31 @@
stop("Data has be in the interval [0,1].")
if (any(u2 > 1) || any(u2 < 0))
stop("Data has be in the interval [0,1].")
+
+ ## extract family and parameters if BiCop object is provided
+ if (missing(family))
+ family <- NA
+ if (missing(par))
+ par <- NA
+ if (!is.null(obj)) {
+ stopifnot(class(obj) == "BiCop")
+ family <- obj$family
+ par <- obj$par
+ par2 <- obj$par2
+ }
+ if (class(family) == "BiCop") {
+ # for short hand usage extract from family
+ if (class(par) == "character")
+ deriv <- par
+ obj <- family
+ family <- obj$family
+ par <- obj$par
+ par2 <- obj$par2
+ }
+
+ ## sanity checks for family and parameters
+ if (is.na(family) | is.na(par))
+ stop("Provide either 'family' and 'par' or 'obj'")
if (!(family %in% c(0, 1, 2, 3, 4, 5, 6, 13, 14, 16, 23, 24, 26, 33, 34, 36)))
stop("Copula family not implemented.")
if (family == 2 && par2 == 0)
Modified: pkg/R/BiCopLambda.r
===================================================================
--- pkg/R/BiCopLambda.r 2015-03-19 15:56:40 UTC (rev 84)
+++ pkg/R/BiCopLambda.r 2015-03-24 21:44:00 UTC (rev 85)
@@ -1,9 +1,26 @@
-
-######################################################### plot of the theoretical and empirical lambda-function #
-
-BiCopLambda <- function(u1 = NULL, u2 = NULL, family = "emp", par = 0, par2 = 0, PLOT = TRUE, ...) {
+############ plot of the theoretical and empirical lambda-function
+BiCopLambda <- function(u1 = NULL, u2 = NULL, family = "emp", par = 0, par2 = 0, PLOT = TRUE, obj = NULL, ...) {
+ ## extract family and parameters if BiCop object is provided
+ if (!is.null(obj)) {
+ stopifnot(class(obj) == "BiCop")
+ family <- obj$family
+ par <- obj$par
+ par2 <- obj$par2
+ }
+ if (class(u1) == "BiCop") {
+ # for short hand usage extract from u1
+ if (class(u2) == "logical")
+ PLOT <- u2
+ obj <- u1
+ family <- obj$family
+ par <- obj$par
+ par2 <- obj$par2
+ u1 <- NULL
+ }
+
if (is.null(u1) == TRUE && is.null(u2) == TRUE && (family == 0 || par == 0))
- stop("Either 'u1' and 'u2' have to be set for the emp. lambda-function or 'family' and 'par' for the theo. lambda-function.")
+ stop("Either 'u1' and 'u2' have to be set for the emp.
+ lambda-function or 'family' and 'par' for the theo. lambda-function.")
if (length(u1) != length(u2))
stop("Lengths of 'u1' and 'u2' do not match.")
if (!(family %in% c(1, 2, 3, 4, 5, 6, 7, 8, 9, 10, "emp")))
@@ -20,7 +37,7 @@
if (PLOT != TRUE && PLOT != FALSE)
stop("The parameter 'PLOT' has to be set to 'TRUE' or 'FALSE'.")
- # Parameterbereiche abfragen
+ ## check for parameter consistency
if ((family == 1 || family == 2) && abs(par) >= 1)
stop("The parameter of the Gaussian and t-copula has to be in the interval (-1,1).")
if (family == 2 && par2 <= 2)
@@ -227,10 +244,14 @@
}
-################################################# lambda-function for Gaussian- and t-copula # # Input: # copula Copula family
-################################################# (1='N',2='t') # param Parameter # Output: # lambda lambda-function #
+###### lambda-function for Gaussian- and t-copula #
+# Input:
+# copula Copula family (1='N',2='t')
+# param Parameter
+# Output:
+# lambda lambda-function #
-gtLambda <- function(copula, param, len = 1000) {
+gtLambda <- function(copula, param, len = 10000) {
v <- seq(0.001, 1, length.out = len)
v1 <- v
n <- length(v)
Modified: pkg/R/BiCopMetaContour.r
===================================================================
--- pkg/R/BiCopMetaContour.r 2015-03-19 15:56:40 UTC (rev 84)
+++ pkg/R/BiCopMetaContour.r 2015-03-24 21:44:00 UTC (rev 85)
@@ -496,7 +496,27 @@
BiCopMetaContour <- function(u1 = NULL, u2 = NULL, bw = 1, size = 100,
levels = c(0.01, 0.05, 0.1, 0.15, 0.2), family = "emp",
- par = 0, par2 = 0, PLOT = TRUE, margins = "norm", margins.par = 0, xylim = NA, ...) {
+ par = 0, par2 = 0, PLOT = TRUE, margins = "norm",
+ margins.par = 0, xylim = NA, obj = NULL,...) {
+ ## extract family and parameters if BiCop object is provided
+ if (!is.null(obj)) {
+ stopifnot(class(obj) == "BiCop")
+ family <- obj$family
+ par <- obj$par
+ par2 <- obj$par2
+ }
+ if (class(u1) == "BiCop") {
+ # for short hand usage extract from family
+ obj <- u1
+ family <- obj$family
+ par <- obj$par
+ par2 <- obj$par2
+ u1 <- NULL
+ }
+
+ ## sanity checks for family and parameters
+ if (is.na(family) | is.na(par))
+ stop("Provide either 'family' and 'par' or 'obj'")
## sanity checks
if ((is.null(u1) == TRUE || is.null(u2) == TRUE) && family == "emp")
stop("'u1' and/or 'u2' not set or of length zero.")
Modified: pkg/R/BiCopPDF.r
===================================================================
--- pkg/R/BiCopPDF.r 2015-03-19 15:56:40 UTC (rev 84)
+++ pkg/R/BiCopPDF.r 2015-03-24 21:44:00 UTC (rev 85)
@@ -1,4 +1,5 @@
-BiCopPDF <- function(u1, u2, family, par, par2 = 0) {
+BiCopPDF <- function(u1, u2, family, par, par2 = 0, obj = NULL) {
+ ## sanity checks for u1, u2
if (is.null(u1) == TRUE || is.null(u2) == TRUE)
stop("u1 and/or u2 are not set or have length zero.")
if (length(u1) != length(u2))
@@ -7,6 +8,29 @@
stop("Data has be in the interval [0,1].")
if (any(u2 > 1) || any(u2 < 0))
stop("Data has be in the interval [0,1].")
+
+ ## extract family and parameters if BiCop object is provided
+ if (missing(family))
+ family <- NA
+ if (missing(par))
+ par <- NA
+ if (!is.null(obj)) {
+ stopifnot(class(obj) == "BiCop")
+ family <- obj$family
+ par <- obj$par
+ par2 <- obj$par2
+ }
+ if (class(family) == "BiCop") {
+ # for short hand usage extract from family
+ obj <- family
+ family <- obj$family
+ par <- obj$par
+ par2 <- obj$par2
+ }
+
+ ## sanity checks for family and parameters
+ if (is.na(family) || is.na(par))
+ stop("Provide either 'family' and 'par' or 'obj'")
if (!(family %in% c(0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10,
13, 14, 16, 17, 18, 19, 20,
23, 24, 26, 27, 28, 29, 30,
@@ -92,6 +116,7 @@
if ((family == 124 || family == 134 || family == 224 || family == 234) && (par2 < 0 || par2 > 1))
stop("Please choose 'par2' of the Tawn copula in [0,1].")
+ ## evaluate log-density
coplik <- .C("LL_mod_seperate",
as.integer(family),
as.integer(length(u1)),
@@ -102,5 +127,6 @@
as.double(rep(0, length(u1))),
PACKAGE = "VineCopula")[[7]]
- return(exp(coplik))
+ ## return density
+ exp(coplik)
}
Modified: pkg/R/BiCopPar2Beta.r
===================================================================
--- pkg/R/BiCopPar2Beta.r 2015-03-19 15:56:40 UTC (rev 84)
+++ pkg/R/BiCopPar2Beta.r 2015-03-24 21:44:00 UTC (rev 85)
@@ -1,3 +1,102 @@
-BiCopPar2Beta <- function(family, par, par2 = 0) {
+BiCopPar2Beta <- function(family, par, par2 = 0, obj = NULL) {
+ ## extract family and parameters if BiCop object is provided
+ if (missing(family))
+ family <- NA
+ if (missing(par))
+ par <- NA
+ if (!is.null(obj)) {
+ stopifnot(class(obj) == "BiCop")
+ family <- obj$family
+ par <- obj$par
+ par2 <- obj$par2
+ }
+ if (class(family) == "BiCop") {
+ # for short hand usage extract from family
+ obj <- family
+ family <- obj$family
+ par <- obj$par
+ par2 <- obj$par2
+ }
+
+ ## sanity checks for family and parameters
+ if (is.na(family) || is.na(par))
+ stop("Provide either 'family' and 'par' or 'obj'")
+ if (family == 2)
+ stop("The CDF of the t-copula is not implemented.")
+ if (!(family %in% c(0, 1, 3, 4, 5, 6, 7, 8, 9, 10, 13, 14, 16, 17, 18, 19, 20,
+ 23, 24, 26, 27, 28, 29, 30, 33, 34, 36, 37, 38, 39, 40, 41,
+ 51, 61, 71, 104, 114, 124, 134, 204, 214, 224, 234)))
+ stop("Copula family not implemented.")
+ if (family %in% c(7, 8, 9, 10, 17, 18, 19, 20, 27, 28, 29, 30, 37, 38, 39, 40,
+ 104, 114, 124, 134, 204, 214, 224, 234) && par2 == 0)
+ stop("For BB1, BB6, BB7, BB8 and Tawn copulas, 'par2' must be set.")
+ if (family %in% c(1, 3, 4, 5, 6, 13, 14, 16, 23, 24, 26, 33, 34, 36, 41, 51,
+ 61, 71) && length(par) < 1)
+ stop("'par' not set.")
+
+ if ((family == 1) && abs(par[1]) >= 1)
+ stop("The parameter of the Gaussian has to be in the interval (-1,1).")
+ # if(family==2 && par2<=2) stop('The degrees of freedom parameter of the t-copula
+ # has to be larger than 2.')
+ if ((family == 3 || family == 13) && par <= 0)
+ stop("The parameter of the Clayton copula has to be positive.")
+ if ((family == 4 || family == 14) && par < 1)
+ stop("The parameter of the Gumbel copula has to be in the interval [1,oo).")
+ if ((family == 6 || family == 16) && par <= 1)
+ stop("The parameter of the Joe copula has to be in the interval (1,oo).")
+ if (family == 5 && par == 0)
+ stop("The parameter of the Frank copula has to be unequal to 0.")
+ if ((family == 7 || family == 17) && par <= 0)
+ stop("The first parameter of the BB1 copula has to be positive.")
+ if ((family == 7 || family == 17) && par2 < 1)
+ stop("The second parameter of the BB1 copula has to be in the interval [1,oo).")
+ if ((family == 8 || family == 18) && par <= 0)
+ stop("The first parameter of the BB6 copula has to be in the interval [1,oo).")
+ if ((family == 8 || family == 18) && par2 < 1)
+ stop("The second parameter of the BB6 copula has to be in the interval [1,oo).")
+ if ((family == 9 || family == 19) && par < 1)
+ stop("The first parameter of the BB7 copula has to be in the interval [1,oo).")
+ if ((family == 9 || family == 19) && par2 <= 0)
+ stop("The second parameter of the BB7 copula has to be positive.")
+ if ((family == 10 || family == 20) && par < 1)
+ stop("The first parameter of the BB8 copula has to be in the interval [1,oo).")
+ if ((family == 10 || family == 20) && (par2 <= 0 || par2 > 1))
+ stop("The second parameter of the BB8 copula has to be in the interval (0,1].")
+ if ((family == 23 || family == 33) && par >= 0)
+ stop("The parameter of the rotated Clayton copula has to be negative.")
+ if ((family == 24 || family == 34) && par > -1)
+ stop("The parameter of the rotated Gumbel copula has to be in the interval (-oo,-1].")
+ if ((family == 26 || family == 36) && par >= -1)
+ stop("The parameter of the rotated Joe copula has to be in the interval (-oo,-1).")
+ if ((family == 27 || family == 37) && par >= 0)
+ stop("The first parameter of the rotated BB1 copula has to be negative.")
+ if ((family == 27 || family == 37) && par2 > -1)
+ stop("The second parameter of the rotated BB1 copula has to be in the interval (-oo,-1].")
+ if ((family == 28 || family == 38) && par >= 0)
+ stop("The first parameter of the rotated BB6 copula has to be in the interval (-oo,-1].")
+ if ((family == 28 || family == 38) && par2 > -1)
+ stop("The second parameter of the rotated BB6 copula has to be in the interval (-oo,-1].")
+ if ((family == 29 || family == 39) && par > -1)
+ stop("The first parameter of the rotated BB7 copula has to be in the interval (-oo,-1].")
+ if ((family == 29 || family == 39) && par2 >= 0)
+ stop("The second parameter of the rotated BB7 copula has to be negative.")
+ if ((family == 30 || family == 40) && par > -1)
+ stop("The first parameter of the rotated BB8 copula has to be in the interval (-oo,-1].")
+ if ((family == 30 || family == 40) && (par2 >= 0 || par2 < (-1)))
+ stop("The second parameter of the rotated BB8 copula has to be in the interval [-1,0).")
+ if ((family == 41 || family == 51) && par <= 0)
+ stop("The parameter of the reflection asymmetric copula has to be positive.")
+ if ((family == 61 || family == 71) && par >= 0)
+ stop("The parameter of the rotated reflection asymmetric copula has to be negative.")
[TRUNCATED]
To get the complete diff run:
svnlook diff /svnroot/vinecopula -r 85
Mehr Informationen über die Mailingliste Vinecopula-commits