From noreply at r-forge.r-project.org Thu Mar 19 16:56:41 2015 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Thu, 19 Mar 2015 16:56:41 +0100 (CET) Subject: [Vinecopula-commits] r84 - in pkg: R man Message-ID: <20150319155641.771951878DE@r-forge.r-project.org> Author: tnagler Date: 2015-03-19 16:56:40 +0100 (Thu, 19 Mar 2015) New Revision: 84 Modified: pkg/R/RVinePartialcorr.R pkg/man/RVineCor2pcor.Rd Log: - include normalization step in RVineCor2pcor for a more intuitive behavior - adjust documentation and examples Modified: pkg/R/RVinePartialcorr.R =================================================================== --- pkg/R/RVinePartialcorr.R 2015-02-24 12:00:28 UTC (rev 83) +++ pkg/R/RVinePartialcorr.R 2015-03-19 15:56:40 UTC (rev 84) @@ -102,6 +102,7 @@ stopifnot(is(RVM, "RVineMatrix")) stopifnot(all(RVM$family %in% c(0, 1, 2))) + RVM <- RVineMatrixNormalize(RVM) oldRVM <- RVM oldOrder <- diag(RVM$Matrix) if (any(oldOrder != length(oldOrder):1)) { @@ -177,34 +178,34 @@ } -# ####################################### -# # for immeddeate testing run as well ## -# ####################################### +####################################### +# for immeddeate testing run as well ## +####################################### + +normalizeRVineMatrix = function(RVM){ + + oldOrder = diag(RVM$Matrix) + Matrix = reorderRVineMatrix(RVM$Matrix) + + names <- RVM$names + if(is.null(names)) + names <- paste("V",1:nrow(RVM$Matrix),sep="") + + return(RVineMatrix(Matrix, RVM$family, RVM$par, RVM$par2, names = rev(names[oldOrder]))) +} + +reorderRVineMatrix = function(Matrix){ + oldOrder = diag(Matrix) + + O = apply(t(1:nrow(Matrix)),2,"==", Matrix) + + for(i in 1:nrow(Matrix)){ + Matrix[O[,oldOrder[i]]] = nrow(Matrix)-i+1 + } + + return(Matrix) +} # -# normalizeRVineMatrix = function(RVM){ -# -# oldOrder = diag(RVM$Matrix) -# Matrix = reorderRVineMatrix(RVM$Matrix) -# -# names <- RVM$names -# if(is.null(names)) -# names <- paste("V",1:nrow(RVM$Matrix),sep="") -# -# return(RVineMatrix(Matrix, RVM$family, RVM$par, RVM$par2, names = rev(names[oldOrder]))) -# } -# -# reorderRVineMatrix = function(Matrix){ -# oldOrder = diag(Matrix) -# -# O = apply(t(1:nrow(Matrix)),2,"==", Matrix) -# -# for(i in 1:nrow(Matrix)){ -# Matrix[O[,oldOrder[i]]] = nrow(Matrix)-i+1 -# } -# -# return(Matrix) -# } -# # # examples/test cases # ###################### # Modified: pkg/man/RVineCor2pcor.Rd =================================================================== --- pkg/man/RVineCor2pcor.Rd 2015-02-24 12:00:28 UTC (rev 83) +++ pkg/man/RVineCor2pcor.Rd 2015-03-19 15:56:40 UTC (rev 84) @@ -6,7 +6,7 @@ \title{(Partial) Correlations for R-Vine Copula Models} \description{ Correlations to partial correlations and vice versa for R-vines -(C vine, D vine or general R vine) . +with independence, Gaussian and t-copulas. } \usage{ @@ -14,78 +14,42 @@ RVinePcor2cor(RVM) } \arguments{ - \item{RVM}{\code{\link{RVineMatrix}} defining only the R-vine structure for \code{cor2pcor} and providing as well the partial correlations for \code{pcor2cor}.} + \item{RVM}{\code{\link{RVineMatrix}} defining only the R-vine structure for \code{Cor2pcor} and providing as well the partial correlations for \code{Pcor2cor}.} \item{corMat}{correlation matrix} } \value{ - \item{RVM}{RVineMatrix with transformed partial correlations} - \item{cor}{correlation matrix} + \item{RVM}{RVineMatrix with transformed partial correlations (for \code{Cor2pcor})} + \item{cor}{correlation matrix (for \code{Pcor2cor})} } +\note{ +The behavior of \code{RVineCor2pcor} differs from older versions (<= 1.4). The RVM object is now +normalized such that the order of the returned correlation matrix conforms with the correlation matrix of the data. +} \examples{ -corMat <- matrix(c(1.00, 0.17, 0.15, 0.14, 0.13, - 0.17, 1.00, 0.30, 0.28, 0.05, - 0.15, 0.30, 1.00, 0.17, 0.05, - 0.14, 0.28, 0.17, 1.00, 0.04, - 0.13, 0.05, 0.05, 0.04, 1.00), 5, 5) - -Matrix <- matrix(c(5, 2, 3, 1, 4, - 0, 2, 3, 4, 1, - 0, 0, 3, 4, 1, - 0, 0, 0, 4, 1, - 0, 0, 0, 0, 1), 5, 5) -family <- matrix(1, 5, 5) - -par <- matrix(c(0, 0.2, 0.9, 0.5, 0.8, - 0, 0, 0.1, 0.6, 0.9, - 0, 0, 0, 0.7, 0.5, - 0, 0, 0, 0, 0.8, - 0, 0, 0, 0, 0), 5, 5) - -# define RVineMatrix object +## create RVineMatrix-object for Gaussian vine +Matrix <- matrix(c(1, 3, 4, 2, + 0, 3, 4, 2, + 0, 0, 4, 2, + 0, 0, 0, 2), 4, 4) +family <- matrix(c(0, 1, 1, 1, + 0, 0, 1, 1, + 0, 0, 0, 1, + 0, 0, 0, 0), 4, 4) +par <- matrix(c(0, 0.2, 0, 0.6, + 0, 0, 0.2, 0.6, + 0, 0, 0, 0.6, + 0, 0, 0, 0), 4, 4) RVM <- RVineMatrix(Matrix, family, par) -# adjust the un-ordered RVine -newRVM <- RVineCor2pcor(RVM, corMat) -round(cor(qnorm(RVineSim(1000, newRVM)))-corMat, 2) +## calculate correlation matrix corresponding to the R-Vine model +newcor <- RVinePcor2cor(RVM) -# normalise the RVine -normRVM <- RVineMatrixNormalize(RVM) +## transform back to partial correlations +RVineCor2pcor(RVM, newcor)$par -# adjust the normalised RVine -newNormRVM <- RVineCor2pcor(normRVM, corMat) - -# newRVM and newNormRVM are the same vines using different names -newNormRVM$par - newRVM$par - -# the variables have a different order in the correlation matrix -newNormCor <- cor(qnorm(RVineSim(1000, newNormRVM))) -round(newNormCor,2) - -# permuted, they meet the initial correlation matrix up to +/- 0.01 -perm <- c(1,4,3,2,5) -round(newNormCor[perm,perm]-corMat, 2) - -# re-order names of the normalised RVine generating a new RVine -normRVM2 <- normRVM -normRVM2$names <- c("V1", "V2", "V3", "V4", "V5") - -# adjust the normalised RVine -newNormRVM2 <- RVineCor2pcor(normRVM2, corMat) -# check whether the parameters are different beyond permutation -# (that's why permutation does not work) -newNormRVM2$par -newRVM$par - -# adjust the normalised RVine -newNormRVM2 <- RVineCor2pcor(normRVM2, corMat[perm,perm]) -# check whether the parameters are now identical -round(newNormRVM2$par - newRVM$par, 2) - -# back and forth -RVinePcor2cor(RVineCor2pcor(RVM, corMat))-corMat -RVinePcor2cor(RVineCor2pcor(normRVM, corMat))-corMat -RVinePcor2cor(RVineCor2pcor(normRVM2, corMat))-corMat +## check if they are equal +all.equal(RVM$par, RVineCor2pcor(RVM, newcor)$par) } \keyword{vine} From noreply at r-forge.r-project.org Tue Mar 24 22:44:01 2015 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Tue, 24 Mar 2015 22:44:01 +0100 (CET) Subject: [Vinecopula-commits] r85 - in pkg: . R man Message-ID: <20150324214401.64FCB183D37@r-forge.r-project.org> 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 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 From noreply at r-forge.r-project.org Wed Mar 25 10:56:28 2015 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Wed, 25 Mar 2015 10:56:28 +0100 (CET) Subject: [Vinecopula-commits] r86 - / pkg/R Message-ID: <20150325095628.974B9187881@r-forge.r-project.org> Author: tnagler Date: 2015-03-25 10:56:28 +0100 (Wed, 25 Mar 2015) New Revision: 86 Modified: / pkg/R/BiCopPar2TailDep.r Log: fix typo in BiCopPar2TailDep Property changes on: ___________________________________________________________________ Modified: svn:ignore - .Rproj.user .Rhistory .RData VineCopula.Rproj + .Rproj.user .Rhistory .RData VineCopula.Rproj BiCop vignette Modified: pkg/R/BiCopPar2TailDep.r =================================================================== --- pkg/R/BiCopPar2TailDep.r 2015-03-24 21:44:00 UTC (rev 85) +++ pkg/R/BiCopPar2TailDep.r 2015-03-25 09:56:28 UTC (rev 86) @@ -1,170 +1,170 @@ -BiCopPar2TailDep <- 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) ||u 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, - 104, 114, 124, 134, 204, 214, 224, 234))) - stop("Copula family not implemented.") - if (c(2, 7, 8, 9, 10, - 17, 18, 19, 20, - 27, 28, 29, 30, - 37, 38, 39, 40, - 42, 52, 62, 72, - 104, 114, 124, 134, - 204, 214, 224, 234) %in% family && par2 == 0) - stop("For t-, BB1, BB6, BB7, BB8 and Tawn copulas, 'par2' must be set.") - if (c(1, 3, 4, 5, 6, 11, 13, 14, 16, 23, 24, 26, 33, 34, 36, 41, 51, 61, 71) %in% - family && 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 == 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].") - - if (family == 0 | family == 1 | family == 5 | family %in% c(23, 24, 26, 27, 28, 29, - 30, 33, 34, 36, 37, 38, 39, - 40, 124, 134, 224, 234)) { - lower <- 0 - upper <- 0 - } else if (family == 2) { - lower <- 2 * pt((-sqrt(par2 + 1) * sqrt((1 - par)/(1 + par))), df = par2 + - 1) - upper <- lower - } else if (family == 3) { - lower <- 2^(-1/par) - upper <- 0 - } else if (family == 4 | family == 6) { - lower <- 0 - upper <- 2 - 2^(1/par) - } else if (family == 7) { - lower <- 2^(-1/(par * par2)) - upper <- 2 - 2^(1/par2) - } else if (family == 8) { - lower <- 0 - upper <- 2 - 2^(1/(par * par2)) - } else if (family == 9) { - lower <- 2^(-1/par2) - upper <- 2 - 2^(1/par) - } else if (family == 10) { - lower <- 0 - if (par2 == 1) - upper <- 2 - 2^(1/par) else upper <- 0 - } else if (family == 13) { - lower <- 0 - upper <- 2^(-1/par) - } else if (family == 14 | family == 16) { - lower <- 2 - 2^(1/par) - upper <- 0 - } else if (family == 17) { - lower <- 2 - 2^(1/par2) - upper <- 2^(-1/par * par2) - } else if (family == 18) { - lower <- 2 - 2^(1/(par * par2)) - upper <- 0 - } else if (family == 19) { - lower <- 2 - 2^(1/par) - upper <- 2^(-1/par2) - } else if (family == 20) { - if (par2 == 1) - lower <- 2 - 2^(1/par) else lower <- 0 - - upper <- 0 - } else if (family == 104) { - par3 <- 1 - upper <- par2 + par3 - 2 * ((0.5 * par2)^par + (0.5 * par3)^par)^(1/par) - lower <- 0 - } else if (family == 114) { - par3 <- 1 - lower <- par2 + par3 - 2 * ((0.5 * par2)^par + (0.5 * par3)^par)^(1/par) - upper <- 0 - } else if (family == 204) { - par3 <- par2 - par2 <- 1 - upper <- par2 + par3 - 2 * ((0.5 * par2)^par + (0.5 * par3)^par)^(1/par) - lower <- 0 - } else if (family == 214) { - par3 <- par2 - par2 <- 1 - lower <- par2 + par3 - 2 * ((0.5 * par2)^par + (0.5 * par3)^par)^(1/par) - upper <- 0 - } - - return(list(lower = lower, upper = upper)) +BiCopPar2TailDep <- 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 %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, + 104, 114, 124, 134, 204, 214, 224, 234))) + stop("Copula family not implemented.") + if (c(2, 7, 8, 9, 10, + 17, 18, 19, 20, + 27, 28, 29, 30, + 37, 38, 39, 40, + 42, 52, 62, 72, + 104, 114, 124, 134, + 204, 214, 224, 234) %in% family && par2 == 0) + stop("For t-, BB1, BB6, BB7, BB8 and Tawn copulas, 'par2' must be set.") + if (c(1, 3, 4, 5, 6, 11, 13, 14, 16, 23, 24, 26, 33, 34, 36, 41, 51, 61, 71) %in% + family && 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 == 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].") + + if (family == 0 | family == 1 | family == 5 | family %in% c(23, 24, 26, 27, 28, 29, + 30, 33, 34, 36, 37, 38, 39, + 40, 124, 134, 224, 234)) { + lower <- 0 + upper <- 0 + } else if (family == 2) { + lower <- 2 * pt((-sqrt(par2 + 1) * sqrt((1 - par)/(1 + par))), df = par2 + + 1) + upper <- lower + } else if (family == 3) { + lower <- 2^(-1/par) + upper <- 0 + } else if (family == 4 | family == 6) { + lower <- 0 + upper <- 2 - 2^(1/par) + } else if (family == 7) { + lower <- 2^(-1/(par * par2)) + upper <- 2 - 2^(1/par2) + } else if (family == 8) { + lower <- 0 + upper <- 2 - 2^(1/(par * par2)) + } else if (family == 9) { + lower <- 2^(-1/par2) + upper <- 2 - 2^(1/par) + } else if (family == 10) { + lower <- 0 + if (par2 == 1) + upper <- 2 - 2^(1/par) else upper <- 0 + } else if (family == 13) { + lower <- 0 + upper <- 2^(-1/par) + } else if (family == 14 | family == 16) { + lower <- 2 - 2^(1/par) + upper <- 0 + } else if (family == 17) { + lower <- 2 - 2^(1/par2) + upper <- 2^(-1/par * par2) + } else if (family == 18) { + lower <- 2 - 2^(1/(par * par2)) + upper <- 0 + } else if (family == 19) { + lower <- 2 - 2^(1/par) + upper <- 2^(-1/par2) + } else if (family == 20) { + if (par2 == 1) + lower <- 2 - 2^(1/par) else lower <- 0 + + upper <- 0 + } else if (family == 104) { + par3 <- 1 + upper <- par2 + par3 - 2 * ((0.5 * par2)^par + (0.5 * par3)^par)^(1/par) + lower <- 0 + } else if (family == 114) { + par3 <- 1 + lower <- par2 + par3 - 2 * ((0.5 * par2)^par + (0.5 * par3)^par)^(1/par) + upper <- 0 + } else if (family == 204) { + par3 <- par2 + par2 <- 1 + upper <- par2 + par3 - 2 * ((0.5 * par2)^par + (0.5 * par3)^par)^(1/par) + lower <- 0 + } else if (family == 214) { + par3 <- par2 + par2 <- 1 + lower <- par2 + par3 - 2 * ((0.5 * par2)^par + (0.5 * par3)^par)^(1/par) + upper <- 0 + } + + return(list(lower = lower, upper = upper)) } \ No newline at end of file From noreply at r-forge.r-project.org Sat Mar 28 14:07:23 2015 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Sat, 28 Mar 2015 14:07:23 +0100 (CET) Subject: [Vinecopula-commits] r87 - in pkg: R man Message-ID: <20150328130723.C4AEA1833AE@r-forge.r-project.org> Author: tnagler Date: 2015-03-28 14:07:23 +0100 (Sat, 28 Mar 2015) New Revision: 87 Modified: pkg/R/RVinePartialcorr.R pkg/man/RVineCor2pcor.Rd Log: fixed more issues in RVinePcor2cor: - allow d=3 - if RVM$names are non-default, a warning message is printed and the rows and columns of the correlation matrix are annotated with the approriate variable names Modified: pkg/R/RVinePartialcorr.R =================================================================== --- pkg/R/RVinePartialcorr.R 2015-03-25 09:56:28 UTC (rev 86) +++ pkg/R/RVinePartialcorr.R 2015-03-28 13:07:23 UTC (rev 87) @@ -98,21 +98,27 @@ RVinePcor2cor <- function(RVM) { d <- nrow(RVM$Matrix) - + ## sanity checks stopifnot(is(RVM, "RVineMatrix")) stopifnot(all(RVM$family %in% c(0, 1, 2))) - RVM <- RVineMatrixNormalize(RVM) + ## store variable names and set to V1:5 if any non-default name occurs + oldNames <- RVM$names + if (!all(oldNames %in% paste("V", 1:d, sep = ""))) + RVM$names <- paste("V", 1:d, sep = "") + + ## normalize RVM object to make the algorithm work properly + RVM <- normalizeRVineMatrix(RVM) + + ## store normalized object and extract order oldRVM <- RVM oldOrder <- diag(RVM$Matrix) - if (any(oldOrder != length(oldOrder):1)) { - RVM <- normalizeRVineMatrix(RVM) - } - # rotate towards notation in Kurowicka and Joe (2011), p. 9 + ## rotate towards notation in Kurowicka and Joe (2011), p. 9 A <- RVM$Matrix[d:1, d:1] pc <- RVM$par[d:1, d:1] + ## if d=2 there is nothing to compute if (d <= 2) { iorder <- diag(RVM$Matrix) corMat <- matrix(c(1, @@ -122,6 +128,7 @@ return(corMat) } + ## initialize correlation matrix with correlation parameters of the model corMat <- matrix(0, d, d) diag(corMat) <- 1 for (j in 2:d) { @@ -130,7 +137,7 @@ corMat[j, a1] <- pc[1, j] } - # tree 2 + ## calculations for second tree for (j in 3:d) { a1 <- A[1, j] a2 <- A[2, j] @@ -138,43 +145,47 @@ corMat[a2, j] <- corMat[j, a2] } - # remaining trees - for (ell in 3:(d - 1)) { - for (j in (ell + 1):d) { - given <- A[1:(ell - 1), j] - S11 <- corMat[given, given] - anew <- A[ell, j] - jk <- c(anew, j) - S12 <- corMat[given, jk] - S21 <- corMat[jk, given] - S22 <- corMat[jk, jk] - tem <- solve(S11, S12) - Om212 <- S21 %*% tem - om11 <- 1 - Om212[1, 1] - om22 <- 1 - Om212[2, 2] - tem12 <- pc[ell, j] * sqrt(om11 * om22) - corMat[anew, j] <- tem12 + Om212[1, 2] - corMat[j, anew] <- corMat[anew, j] + ## remaining trees + if (d > 3) { + for (ell in 3:(d - 1)) { + for (j in (ell + 1):d) { + given <- A[1:(ell - 1), j] + S11 <- corMat[given, given] + anew <- A[ell, j] + jk <- c(anew, j) + S12 <- corMat[given, jk] + S21 <- corMat[jk, given] + S22 <- corMat[jk, jk] + tem <- solve(S11, S12) + Om212 <- S21 %*% tem + om11 <- 1 - Om212[1, 1] + om22 <- 1 - Om212[2, 2] + tem12 <- pc[ell, j] * sqrt(om11 * om22) + corMat[anew, j] <- tem12 + Om212[1, 2] + corMat[j, anew] <- corMat[anew, j] + } } } + ## revert matrix to appropriate order corMat <- corMat[rev(oldOrder), rev(oldOrder)] + nameOrder <- order(oldRVM$names) + corMat <- corMat[nameOrder, nameOrder] - nameOrder <- NULL - if (!is.null(oldRVM$names)) { - if (any(!(oldRVM$names %in% paste("V", 1:d, sep = "")))) { - warning("RVM$names are not default and cannot be checked. Make sure - to interpret the correlation matrix in the same ordering of - variables as given in the RVineMatrix.") + + ## warn about matrix ordering if non-default names were provided + if (!is.null(oldNames)) { + if (any(!(oldNames %in% paste("V", 1:d, sep = "")))) { + warning("Some RVM$names are not default (such as ''V5'') and their order cannot be checked. +Make sure to interpret the correlation matrix as indicated by the row and column names.") + rownames(corMat) <- colnames(corMat) <- oldNames } else { - nameOrder <- order(oldRVM$names) - if (any(nameOrder != 1:length(oldRVM$names))) { - corMat <- corMat[nameOrder, nameOrder] - } + rownames(corMat) <- colnames(corMat) <- paste("V", 1:d, sep = "") } } - return(corMat) + ## return results + corMat } Modified: pkg/man/RVineCor2pcor.Rd =================================================================== --- pkg/man/RVineCor2pcor.Rd 2015-03-25 09:56:28 UTC (rev 86) +++ pkg/man/RVineCor2pcor.Rd 2015-03-28 13:07:23 UTC (rev 87) @@ -22,8 +22,8 @@ \item{cor}{correlation matrix (for \code{Pcor2cor})} } \note{ -The behavior of \code{RVineCor2pcor} differs from older versions (<= 1.4). The RVM object is now -normalized such that the order of the returned correlation matrix conforms with the correlation matrix of the data. +The behavior of \code{RVinePcor2ccor} differs from older versions (<= 1.4). The RVM object is now +normalized such that the order of the returned correlation matrix conforms with the correlation matrix of the data. If \code{RVM$names} are non-default, the initial ordering of the variables cannot be traced back and the matrix has to be interpreted as inidicated by the row- and column names. } \examples{ From noreply at r-forge.r-project.org Sat Mar 28 14:29:19 2015 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Sat, 28 Mar 2015 14:29:19 +0100 (CET) Subject: [Vinecopula-commits] r88 - pkg/R Message-ID: <20150328132919.1B44918111F@r-forge.r-project.org> Author: tnagler Date: 2015-03-28 14:29:18 +0100 (Sat, 28 Mar 2015) New Revision: 88 Modified: pkg/R/RVinePartialcorr.R Log: fix issues with CRAN-check Modified: pkg/R/RVinePartialcorr.R =================================================================== --- pkg/R/RVinePartialcorr.R 2015-03-28 13:07:23 UTC (rev 87) +++ pkg/R/RVinePartialcorr.R 2015-03-28 13:29:18 UTC (rev 88) @@ -39,9 +39,8 @@ if (d <= 2) return(corMat) - pp <- matrix(0, d, d) - + oldRVM <- RVM oldOrder <- diag(RVM$Matrix) if (any(oldOrder != length(oldOrder):1)) { @@ -101,7 +100,9 @@ ## sanity checks stopifnot(is(RVM, "RVineMatrix")) stopifnot(all(RVM$family %in% c(0, 1, 2))) - + if (is.null(RVM$names)) + RVM$names <- paste("V", 1:d, sep = "") + ## store variable names and set to V1:5 if any non-default name occurs oldNames <- RVM$names if (!all(oldNames %in% paste("V", 1:d, sep = ""))) From noreply at r-forge.r-project.org Sun Mar 29 18:07:38 2015 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Sun, 29 Mar 2015 18:07:38 +0200 (CEST) Subject: [Vinecopula-commits] r89 - pkg/src Message-ID: <20150329160738.E515A187905@r-forge.r-project.org> Author: ulf Date: 2015-03-29 18:07:38 +0200 (Sun, 29 Mar 2015) New Revision: 89 Modified: pkg/src/cdvine.c pkg/src/deriv.c Log: I started to comment my C-functions Modified: pkg/src/cdvine.c =================================================================== --- pkg/src/cdvine.c 2015-03-28 13:29:18 UTC (rev 88) +++ pkg/src/cdvine.c 2015-03-29 16:07:38 UTC (rev 89) @@ -10,12 +10,14 @@ ** */ -#include "include/vine.h" -#include "include/memoryhandling.h" -#include "include/likelihood.h" -#include "include/cdvine.h" -#include "include/hfunc.h" +// Include all the head files +#include "include/vine.h" // general one +#include "include/memoryhandling.h" // for creating two and three dimensional arrays +#include "include/likelihood.h" // formally main functionality; log-likelihood with help functions; bivariate densities +#include "include/cdvine.h" // Header file for this C-file +#include "include/hfunc.h" // h-functions, i.e. conditional densities; also inverse h-functions + #define UMAX 1-1e-10 #define UMIN 1e-10 @@ -24,13 +26,17 @@ ////////////////////////////////////////////////////////////// -// Function to simulate from a pair-copula construction (vine) +// Function to simulate from a C- or D-vine // Input: // n sample size // d dimension (>= 2) // type vine type (1=Canonical vine, 2=D-vine) -// family copula family (1=gaussian, 2=student, 3=clayton, 4=gumbel, 5=frank, 6=joe, 7=BB1) +// family copula family (see help pages which families are now included) // par parameter values (at least d*(d-1)/2 parameters) +// nu second parameter for t-copula, BB-copulas and Tawn +// +// Output: +// out two dimensional array of simulated data //////////////////////////////////////////////////////////////// void pcc(int* n, int* d, int* family, int* type, double* par, double* nu, double* out) @@ -38,7 +44,7 @@ int i, j, in=1, k, **fam; double *w, **v, t, **theta, **x, **ny; - GetRNGstate(); + GetRNGstate(); //Init random number generator //Allocate memory: w = Calloc((*d+1),double); @@ -48,6 +54,9 @@ ny = create_matrix(*d,*d); fam = create_intmatrix(*d,*d); //Initialize dependency parameters + + // The function arguments are one-dimensional vectors; for better understanding the transform them back to matrices (see theory) + // This step may be updated in the future to optimize the algorithms k = 0; for(i=1;i<=*d-1;i++) { @@ -59,14 +68,14 @@ k ++; } } - //Simulate: + //Simulate: (it follows the theoretical algorithm) if(*type==1) //Canonical vine { - for(j=1;j<=*n;j++) + for(j=1;j<=*n;j++) // run over all observations (rows) { for(i=1;i<=*d;i++) w[i] = runif(0,1); x[j][1] = w[1]; - for(i=2;i<=*d;i++) + for(i=2;i<=*d;i++) // run over all dimensions (cols) { t = w[i]; for(k=i-1;k>=1;k--) @@ -134,7 +143,7 @@ k ++; } } - PutRNGstate(); + PutRNGstate(); // Function for the random number generator //Free memory: Free(w); free_matrix(v,*d+1); free_matrix(theta,*d); free_matrix(ny,*d); free_intmatrix(fam,*d); free_matrix(x,*n+1); } @@ -143,16 +152,16 @@ ////////////////////////////////////////////////////////////// -// Function to compute -log-likelihood for the pair-copula construction (vine) +// Function to compute -log-likelihood for C- and D-vine // Input: // n sample size // d dimension (>=2) // type vine type (1=canonical vine, 2=d-vine) -// family copula families: only student // (1=gaussian, 2=student, 3=clayton, 4=gumbel, 5=frank, 7=BB1, 8=BB7) -// par parameter values (at least d*(d-1)/2 parameters +// family copula families +// par parameter values (at least d*(d-1)/2 parameters ) The second parameter is added at the end of par // data data set for which to compute log-likelihood // Output: -// out Loglikelihood +// out Log-likelihood // ll array with the contribution to LL (for each copula) // vv array for the transformation operated (Hfunc) ///////////////////////////////////////////////////////////// @@ -184,7 +193,7 @@ { for (t=0;t<=*T-1;t++ ) { - x[i][t] = data[k]; + x[i][t] = data[k]; //transform the data back into a 2-dim array k++; } } @@ -195,7 +204,7 @@ { theta[i][j] = par[k]; fam[i][j] = family[k]; - nu[i][j] = par[*d*(*d-1)/2+k]; + nu[i][j] = par[*d*(*d-1)/2+k]; // the second parameter is added at the end of par (not the best solution but was practise at the beginning) k++; } } @@ -207,9 +216,10 @@ //Compute likelihood at level 1: for(i=1;i<*d;i++) { - LL_mod2(&fam[1][i],T,x[1],x[i+1],&theta[1][i],&nu[1][i],&loglik); - sumloglik += loglik; - ll[kk] = loglik; + LL_mod2(&fam[1][i],T,x[1],x[i+1],&theta[1][i],&nu[1][i],&loglik); // call the bivariate log-likelihood function + //(with the correct rotation for 90, 180 and 270 degrees) + sumloglik += loglik; // sum up + ll[kk] = loglik; // store all bivariate log-likelihoods too ++kk; if(*d>2) { @@ -297,7 +307,7 @@ for(i=1;i<=(*d-k);i++) for(t=0;t<*T;t++) { - vv[kk] = v[k][i][t]; + vv[kk] = v[k][i][t]; // transformation from a 3-dim array to a vector ++kk; } } @@ -324,18 +334,19 @@ } ////////////////////////////////////////////////////////////// -// Function to compute -log-likelihood for the pair-copula construction (vine) +// Function to compute an update of the log-likelihood for C- and D-vine // Input: // n sample size // d dimension (>=2) // type vine type (1=canonical vine, 2=d-vine) -// family copula families: only student // (1=gaussian, 2=student, 3=clayton, 4=gumbel, 5=frank) +// family copula families // par parameter values (at least d*(d-1)/2 parameters // mpar index of modified parameter (related to previous computation) // data data set for which to compute log-likelihood // ll array with the stored contribution of the likelihood in a previous computation // vv 3d array array with the stored transformations in a previous computation // Output: +// out log-likelihood (updated) // ll array with the contribution to LL (for each copula) // vv array for the transformation operated (Hfunc) ///////////////////////////////////////////////////////////// Modified: pkg/src/deriv.c =================================================================== --- pkg/src/deriv.c 2015-03-28 13:29:18 UTC (rev 88) +++ pkg/src/deriv.c 2015-03-29 16:07:38 UTC (rev 89) @@ -23,11 +23,21 @@ ///////////////////////////////////////////////////////////// // // Ableitung der Copula nach dem Parameter +// Derivative of bivariate copulas with respect to the (first) parameter // +// Input: +// u,v copula arguments (data vectors) +// n length of u,v +// param parameter vector (par,par2) +// copula copula family +// +// Output: +// out derivative ///////////////////////////////////////////////////////////// void diffPDF_mod(double* u, double* v, int* n, double* param, int* copula, double* out) { + // for the rotated copulas we need some help variables double* negv; double* negu; double* nparam; @@ -39,12 +49,12 @@ nparam[1]=-param[1]; int i; -if((*copula)==43) +if((*copula)==43) // special copula; all rotations of Clayton are combined in one copula; the correct rotation is derived automatically { ncopula=3; if(param[0] > 0){ nparam[0]=2*(param[0])/(1-param[0]); - diffPDF(u, v, n, nparam, &ncopula, out); + diffPDF(u, v, n, nparam, &ncopula, out); // derivative function for(i=0;i<*n;i++){out[i]=out[i]*2/pow(1-param[0],2);} }else{ nparam[0]=-2*(param[0])/(1+param[0]); @@ -66,22 +76,22 @@ for(i=0;i<*n;i++){out[i]=-out[i]/pow(1+param[0],2); } } }else{ - - if(((*copula==23) | (*copula==24) | (*copula==26) | (*copula==27) | (*copula==28) | (*copula==29) | (*copula==30))) // 90? rotated copulas +// for the rotation see the master thesis of Jakob Stoeber + if(((*copula==23) | (*copula==24) | (*copula==26) | (*copula==27) | (*copula==28) | (*copula==29) | (*copula==30))) // 90 rotated copulas { ncopula = (*copula)-20; for (i = 0; i < *n; ++i) {negv[i] = 1 - v[i];} diffPDF(u, negv, n, nparam, &ncopula, out); for(i=0;i<*n;i++){out[i]=-out[i];} } - else if(((*copula==33) | (*copula==34) | (*copula==36) | (*copula==37) | (*copula==38) | (*copula==39) | (*copula==40))) // 270? rotated copulas + else if(((*copula==33) | (*copula==34) | (*copula==36) | (*copula==37) | (*copula==38) | (*copula==39) | (*copula==40))) // 270 rotated copulas { ncopula = (*copula)-30; for (i = 0; i < *n; ++i) {negu[i] = 1 - u[i];} diffPDF(negu, v, n, nparam, &ncopula, out); for(i=0;i<*n;i++){out[i]=-out[i];} } - else if(((*copula==13) | (*copula==14) | (*copula==16) | (*copula==17) | (*copula==18) | (*copula==19) | (*copula==20))) // 180? rotated copulas + else if(((*copula==13) | (*copula==14) | (*copula==16) | (*copula==17) | (*copula==18) | (*copula==19) | (*copula==20))) // 180 rotated copulas { ncopula = (*copula)-10; for (i = 0; i < *n; ++i) @@ -93,7 +103,7 @@ } else { - diffPDF(u, v, n, param, copula, out); + diffPDF(u, v, n, param, copula, out); // eigentliche Ableitungsfunktion } } free(negv); @@ -104,6 +114,21 @@ +////////////////////////////////////////////////// +// Derivative of bivariate copulas with respect to the parameter (standard copula form without rotations, see above) +// +// Input: +// u,v copula arguments (data vectors) +// n length of u,v +// param parameter vector (par,par2) +// copula copula family (1,3,4,5,6) +// +// Output: +// out derivative +// +// Reference: Schepsmeier and Stoeber (2012, 2013) +///////////////////////////////////////////////////////////// + void diffPDF(double* u, double* v, int* n, double* param, int* copula, double* out) { int j; @@ -116,11 +141,11 @@ for(j=0;j<*n;j++) { - if(*copula==0) + if(*copula==0) // independence copulas { out[j]=0; } - else if(*copula==1) + else if(*copula==1) // gauss { t1 = qnorm(u[j],0.0,1.0,1,0); t2 = qnorm(v[j],0.0,1.0,1,0); @@ -135,6 +160,7 @@ t24 = sqrt(t8); out[j] = (-2.0*(theta*t3-t1*t2)*t9-t15/(t8*t8)*theta)*t22/t24+t22/t24/t8*theta; } + // t-copula is separate; very complicated else if(*copula==3) { t1 = u[j]*v[j]; @@ -240,7 +266,16 @@ //////////////////////////////////////////////////////////////////// // // 1. Ableitung von c nach u +// First derivative of the bivariate copula density with respect to u (first argument) +// Input: +// u,v copula arguments (data vectors) +// n length of u,v +// param parameter vector (par,par2) +// copula copula family // +// Output: +// out derivative +// //////////////////////////////////////////////////////////////////// void diffPDF_u_mod(double* u, double* v, int* n, double* param, int* copula, double* out) @@ -316,6 +351,22 @@ free(nparam); } + +//////////////////////////////////////////////////////////////////// +// +// 1. Ableitung von c nach u (eigentliche Funktion ohne die Rotationen) +// First derivative of the bivariate copula density with respect to u (first argument) +// Input: +// u,v copula arguments (data vectors) +// n length of u,v +// param parameter vector (par,par2) +// copula copula family (1,2,3,4,5,6) +// +// Output: +// out derivative +// +//////////////////////////////////////////////////////////////////// + void diffPDF_u(double* u, double* v, int* n, double* param, int* copula, double* out) { int j, k=1; @@ -350,7 +401,7 @@ } else if(*copula==2) { - diffPDF_u_tCopula_new(&u[j], &v[j], &k, param, copula, &out[j]); + diffPDF_u_tCopula_new(&u[j], &v[j], &k, param, copula, &out[j]); // special function for t-copula } else if(*copula==3) { @@ -436,7 +487,16 @@ //////////////////////////////////////////////////////////////////// // // 1. Ableitung von c nach v +// First derivative of the bivariate copula density with respect to v (second argument) +// Input: +// u,v copula arguments (data vectors) +// n length of u,v +// param parameter vector (par,par2) +// copula copula family (1,2,3,4,5,6) // +// Output: +// out derivative +// //////////////////////////////////////////////////////////////////// void diffPDF_v_mod(double* u, double* v, int* n, double* param, int* copula, double* out) @@ -480,7 +540,7 @@ { ncopula = (*copula)-20; for (i = 0; i < *n; ++i) {negv[i] = 1 - v[i];} - diffPDF_u(negv, u, n, nparam, &ncopula, out); + diffPDF_u(negv, u, n, nparam, &ncopula, out); // we can use again the function for the derivative of c wrt u but change the arguments for(i=0;i<*n;i++){out[i]=-out[i];} } else if(((*copula==33) | (*copula==34) | (*copula==36) | (*copula==37) | (*copula==38) | (*copula==39) | (*copula==40))) // 270? rotated copulas From noreply at r-forge.r-project.org Sun Mar 29 19:29:19 2015 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Sun, 29 Mar 2015 19:29:19 +0200 (CEST) Subject: [Vinecopula-commits] r90 - pkg/src Message-ID: <20150329172919.594C018791A@r-forge.r-project.org> Author: ulf Date: 2015-03-29 19:29:18 +0200 (Sun, 29 Mar 2015) New Revision: 90 Modified: pkg/src/deriv.c pkg/src/deriv2.c pkg/src/evCopula.c Log: some more comments of C-functions Modified: pkg/src/deriv.c =================================================================== --- pkg/src/deriv.c 2015-03-29 16:07:38 UTC (rev 89) +++ pkg/src/deriv.c 2015-03-29 17:29:18 UTC (rev 90) @@ -129,6 +129,10 @@ // Reference: Schepsmeier and Stoeber (2012, 2013) ///////////////////////////////////////////////////////////// +// the stepwise calculation is due to performance and numerical stability reasons (t1,t2,...) +// for Gauss some of the step can be found in the reference +// for the archimedean copulas one gets this optimization with Maple + void diffPDF(double* u, double* v, int* n, double* param, int* copula, double* out) { int j; @@ -145,7 +149,7 @@ { out[j]=0; } - else if(*copula==1) // gauss + else if(*copula==1) // gauss, formula see reference { t1 = qnorm(u[j],0.0,1.0,1,0); t2 = qnorm(v[j],0.0,1.0,1,0); @@ -161,7 +165,7 @@ out[j] = (-2.0*(theta*t3-t1*t2)*t9-t15/(t8*t8)*theta)*t22/t24+t22/t24/t8*theta; } // t-copula is separate; very complicated - else if(*copula==3) + else if(*copula==3) // the archimedean copula derivatives are derived by Maple { t1 = u[j]*v[j]; t2 = -theta-1.0; Modified: pkg/src/deriv2.c =================================================================== --- pkg/src/deriv2.c 2015-03-29 16:07:38 UTC (rev 89) +++ pkg/src/deriv2.c 2015-03-29 17:29:18 UTC (rev 90) @@ -24,7 +24,16 @@ //////////////////////////////////////////////////////////////////// // // 2. Ableitung von c nach dem Parameter +// Second derivative of the bivariate copula density with respect to the parameter // +// u,v copula arguments (data vectors) +// n length of u,v +// param parameter vector (par,par2) +// copula copula family (1,2,3,4,5,6) +// +// Output: +// out derivative +// //////////////////////////////////////////////////////////////////// void diff2PDF_mod(double* u, double* v, int* n, double* param, int* copula, double* out) @@ -108,6 +117,25 @@ } +//////////////////////////////////////////////////////////////////// +// +// 2. Ableitung von c nach dem Parameter +// Second derivative of the bivariate copula density with respect to the parameter (main function) +// +// u,v copula arguments (data vectors) +// n length of u,v +// param parameter vector (par,par2) +// copula copula family (1,2,3,4,5,6) +// +// Output: +// out derivative +// +// Reference: Schepsmeier and Stoeber (2012, 2013) +//////////////////////////////////////////////////////////////////// + +// the structure is the same as for the first derivative +// see also the comments for the first derivatives + void diff2PDF(double* u, double* v, int* n, double* param, int* copula, double* out) { int j; @@ -325,6 +353,7 @@ /////////////////////////////////////////////////////////////////// // // 2. Ableitung von c nach u (2mal) +// second derivative with respect to u (two times) // //////////////////////////////////////////////////////////////////// @@ -400,8 +429,10 @@ free(nparam); } - +////////////////////////////////////////// // Ableitung von c nach v (2 mal) +// Second derivative with respect to v (two times) +////////////////////////////////////////// void diff2PDF_v_mod(double* u, double* v, int* n, double* param, int* copula, double* out) { @@ -477,6 +508,11 @@ +//////////////////////////////// +// Main function to calculate the derivative with respect to u +//////////////////////////////// + + void diff2PDF_u(double* u, double* v, int* n, double* param, int* copula, double* out) { int j; @@ -498,9 +534,9 @@ double nu=0, c=0, diffc=0; int k=1; - LL(copula, &k, &u[j], &v[j], &theta, &nu, &c); + LL(copula, &k, &u[j], &v[j], &theta, &nu, &c); // one needs the density c=exp(c); - diffPDF_u_mod(&u[j],&v[j],&k,param,copula,&diffc); + diffPDF_u_mod(&u[j],&v[j],&k,param,copula,&diffc); // and also the derivative with respect to u (first derivative) t1=qnorm(u[j],0.0,1.0,1,0); t2=qnorm(v[j],0.0,1.0,1,0); @@ -515,7 +551,7 @@ else if(*copula==2) { int k=1; - diff2PDF_u_tCopula_new(&u[j], &v[j], &k, param, copula, &out[j]); + diff2PDF_u_tCopula_new(&u[j], &v[j], &k, param, copula, &out[j]); // special function for t-copula } else if(*copula==3) { @@ -682,6 +718,7 @@ /////////////////////////////////////////////////////////////////// // // 2. Ableitung von c nach u und v +// Second derivative with respect to u and v (first and second argument) // //////////////////////////////////////////////////////////////////// @@ -957,7 +994,8 @@ /////////////////////////////////////////////////////////////////// // -// 2. Ableitung von c nach par und u +// 2. Ableitung von c nach par und u +// Second derivative with respect to the parameter and the first argument // //////////////////////////////////////////////////////////////////// @@ -1266,6 +1304,9 @@ } + +// The same with respect to the parameter and v (second argument) + void diff2PDF_par_v_mod(double* u, double* v, int* n, double* param, int* copula, double* out) { double* negv; Modified: pkg/src/evCopula.c =================================================================== --- pkg/src/evCopula.c 2015-03-29 16:07:38 UTC (rev 89) +++ pkg/src/evCopula.c 2015-03-29 17:29:18 UTC (rev 90) @@ -9,9 +9,28 @@ #define XEPS 1e-4 // Some function for the Tawn copula +// (theory based on the extreme value copulas) +// Reference: See help (some master thesis) +// for the calculation of the density as well as for the h-function we need some help functions +// the naming of the functions is due to the notation of the master thesis (and also references therein) + // CDF -void ta(double* t, int* n, double* par, double* par2, double* par3, double* out) //für CDF + +/////////////////////////////////// +// +// Input: +// t t-vector +// n number of observations +// par first parameter +// par2 second parameter +// par3 third parameter +// +// Output: +// out ta +////////////////////////////// + +void ta(double* t, int* n, double* par, double* par2, double* par3, double* out) //for CDF { int i=0; double t1,t2; @@ -25,7 +44,19 @@ //ta<-function(t,par,par2,par3) {(par2*t)^par+(par3*(1-t))^par} -// Pickands A +//////////////////////////////////////////////// +// Pickands A for the Tawn copula +// Input: +// t t-vector +// n number of observations +// par first parameter +// par2 second parameter +// par3 third parameter +// +// Output: +// out Pickands A for the Tawn copula +////////////////////////////// + void Tawn(double* t, int* n, double* par, double* par2, double* par3, double* out) //für CDF { int i=0, T=1; @@ -42,15 +73,29 @@ //Tawn<-function(t,par,par2,par3) {(1-par3)*(1-t)+(1-par2)*t+ta(t,par,par2,par3)^(1/par)} +//////////////////////////////////////////////////// +// CDF of Tawn +// Input: +// t t-vector +// n number of observations +// par first parameter +// par2 second parameter +// par3 third parameter +// +// Output: +// out CDF +///////////////////////////////////////////////////// + + void TawnCDF(double* u, double* v, int* n, double* par, double* par2, double* par3, double* out) // CDF-function { int i=0, T=1; double w, A; for(i=0; i<*n;i++) { - w=log(v[i])/log(u[i]*v[i]); - Tawn(&w, &T, par, par2, par3, &A); //!!! - out[i]=pow(u[i]*v[i],A); + w=log(v[i])/log(u[i]*v[i]); // w vector + Tawn(&w, &T, par, par2, par3, &A); //Pickands A + out[i]=pow(u[i]*v[i],A); // CDF } } @@ -58,6 +103,9 @@ ////////////////////////////////////////////////////////////////// // PDF +// some more help function for the PDF +// see reference for details + void ta2(double* t, int* n, double* par, double* par2, double* par3, double* out) //für PDF { int i=0; @@ -70,6 +118,8 @@ } } +// something like the first derivative of the ta function + void d1ta(double* t, int* n, double* par, double* par2, double* par3, double* out) //für PDF { int i=0; @@ -98,7 +148,7 @@ //d2ta<-function(t,par,par2,par3) {par*(par-1)*(par3^2*(par3*t)^(par-2)+par2^2*(par2*(1-t))^(par-2))} - +// I guess this was some kind of derivative of A (I don't remember, see master thesis) void Tawn2(double* t, int* n, double* par, double* par2, double* par3, double* out) //für PDF { int i=0, T=1; @@ -145,6 +195,8 @@ //d2Tawn<-function(t,par,par2,par3) {1/par*((1/par-1)*ta(t,par,par2,par3)^(1/par-2)*d1ta(t,par,par2,par3)^2+ta(t,par,par2,par3)^(1/par-1)*d2ta(t,par,par2,par3))} // Ableitung von A nach u +// derivative of A with respect to u (first argument) +// needed for the derivative of c with respect to u void dA_du(double* u, double* v, int* n, double* par, double* par2, double* par3, double* out) { int i=0, T=1; @@ -160,6 +212,8 @@ //dA_du<-function(u,v,par,par2,par3) {evcBiCopAfuncDeriv(w(u,v),fam,par,par2,par3)*dw_du(u,v)} +// derivative of A with respect to v + void dA_dv(double* u, double* v, int* n, double* par, double* par2, double* par3, double* out) { int i=0, T=1; @@ -173,6 +227,8 @@ } } +// second derivative with respect to u and v + void dA_dudv(double* u, double* v, int* n, double* par, double* par2, double* par3, double* out) { int i=0, T=1; @@ -205,6 +261,7 @@ } // Ableitung von C nach u +// derivative of PDF with respect to u void dC_du(double* u, double* v, int* n, double* par, double* par2, double* par3, double* out) { int i=0, T=1; @@ -250,6 +307,7 @@ // Ableitung von C nach v (fuer h-function) +// derivative of PDF with respect to v (for h-func) void dC_dv(double* u, double* v, int* n, double* par, double* par2, double* par3, double* out) { int i=0, T=1; From noreply at r-forge.r-project.org Mon Mar 30 20:36:33 2015 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Mon, 30 Mar 2015 20:36:33 +0200 (CEST) Subject: [Vinecopula-commits] r91 - pkg/src Message-ID: <20150330183633.F3A6618784C@r-forge.r-project.org> Author: ulf Date: 2015-03-30 20:36:33 +0200 (Mon, 30 Mar 2015) New Revision: 91 Modified: pkg/src/gof.c Log: comments for the goodness-of-fit functionality in C Modified: pkg/src/gof.c =================================================================== --- pkg/src/gof.c 2015-03-29 17:29:18 UTC (rev 90) +++ pkg/src/gof.c 2015-03-30 18:36:33 UTC (rev 91) @@ -174,8 +174,8 @@ { for(j=i;j<(dd+tt);j++) { - Dprime[kk] = hess[(j+1)+((dd+tt)*i)-1] + der[(j+1)+((dd+tt)*i)-1]; - D[kk] = D[kk] + (Dprime[kk]/(double)(*T)); + Dprime[kk] = hess[(j+1)+((dd+tt)*i)-1] + der[(j+1)+((dd+tt)*i)-1]; // D = H+C + D[kk] = D[kk] + (Dprime[kk]/(double)(*T)); // Schaetzer, deswegen durch die Anzahl der Beobachtungen teilen kk++; } } @@ -189,7 +189,7 @@ } } - // Nicht fertig, da hier das Problem D%*%solve(V)%*%t(D) zu l?sen ist + // Nicht fertig, da hier das Problem D%*%solve(V)%*%t(D) zu loesen ist // Free memory //free(D); @@ -245,6 +245,20 @@ else return 1; } +//////////////////////////////////////// +// Calculation of the B_j in Berg and Bakken +// Input: +// T, d dimensions +// family,... RVM objects +// data observed data +// vv vv2 side products of log-likelihood calculation (h-function) +// calcupdate which h-functions have to be calculated +// method numeric value (1=Breymann, 2=Berg, 3=Berg2; see my paper) +// alpha power for the Berg function +// +// Output: +// out sum of transformed data (PIT) (one step for the Breymann, Berg and Berg2 GOF) +////////////////////////////////////////// void Bj(int *T, int* d, int* family, int* maxmat, int* matrix, int* condirect, int* conindirect, double* par, double* par2, double* data, double* out, double* vv, double* vv2, int* calcupdate, int* method, int *alpha) @@ -268,7 +282,7 @@ ii += 1; } qsort(u[j],*d,sizeof(double),(void *)comp_nums); - ZStar(u[j],d,tmp[j]); //Transformation von Berg and Bakken (2007) + ZStar(u[j],d,tmp[j]); //Transformation von Berg and Bakken (2007); ordered PIT } else // Im Fall von Breymann ist es besser keine Transformation zu machen { @@ -284,11 +298,11 @@ { for(i=0;i<*d;i++) { - if(*method==1) + if(*method==1) //Breymann has the standard norma quantile function squared as transformation function tmp[t][i]=pow(qnorm(tmp[t][i],0.0,1.0,1,0),2); - else if(*method==2) + else if(*method==2) // Berg: absolute value of u-0.5 tmp[t][i]=fabs(tmp[t][i]-0.5); - else if(*method==3) + else if(*method==3) // Berg2: (u-0.5)^alpha tmp[t][i]=pow(tmp[t][i]-0.5,*alpha); out[t]+=tmp[t][i]; @@ -301,6 +315,18 @@ } +///////////////////////// +// For bootstrap simulate B_j +// +// Input: +// S test statistic +// B number of bootstrap samples +// T,d dimensions +// method numeric value (1=Breymann, 2=Berg, 3=Berg2; see my paper) +// alpha power for the Berg function +// +// p p-value + void SimulateBj(double* S, int *T, int* d, int* B, int* method, int *alpha, double* p) { int i=0, t=0, m=0; @@ -308,7 +334,7 @@ tmp = malloc(*d*sizeof(double)); ustar = malloc(*d*sizeof(double)); - GetRNGstate(); + GetRNGstate(); // random number generator for(t=0;t<*T;t++) { @@ -350,6 +376,21 @@ } +//////////////////////////////// +// PIT based GOF tests +// Breymann, Berg, Berg2 +// +// Input: +// data with its dimensions +// some help variables like vv and vv2 +// method numeric value (1=Breymann, 2=Berg, 3=Berg2; see my paper) +// alpha power for the Berg function +// statisticName numeric value (1=Anderson-Darling, 2=Kolmogorov-Smirnov, 3=Cramer-von Mises) +// +// Output: +// statistic test statistic +///////////////////////////////// + void gofPIT_AD(int *T, int* d, int* family, int* maxmat, int* matrix, int* condirect, int* conindirect, double* par, double* par2, double* data, double* statistic, double* vv, double* vv2, int* calcupdate, int* method, int *alpha, int* B, int *statisticName) { @@ -369,17 +410,17 @@ Bj(T, d, family, maxmat, matrix, condirect, conindirect, par, par2, data, S, vv, vv2, calcupdate, method, alpha); // Statistic berechnen - if(*B==0) + if(*B==0) // if an asymptotic based test statistic should be returned { if(*method==1) { for(t=0;t<*T;t++) { - Bhat[t]=pchisq(S[t],*d,1.0,0.0); + Bhat[t]=pchisq(S[t],*d,1.0,0.0); // for Breymann the asymptotic is known (although it is shown that it is not that correct) } } else - CumDist(S, T, T, Bhat); + CumDist(S, T, T, Bhat); // for the other two we need the empirical distribution function if(*statisticName==1) //Anderson-Darling ADtest(Bhat, T, statistic); @@ -411,6 +452,14 @@ } +/////////////////////////// +// p-value estimation for the PIT based GOF tests +// +// Input: see above +// +// Output: +// pvalue bootstrapped p-value + void gofPIT_AD_pvalue(int* T, int* d, int* family, int* maxmat, int* matrix, int* condirect, int* conindirect, double* par, double* par2, double* data, double* statistic, double* vv, double* vv2, int* calcupdate, int* method, int* alpha, int* B, double* pvalue, int *statisticName) { @@ -423,15 +472,15 @@ bvv = malloc(*d*(*d)*(*T)*sizeof(double)); bvv2 = malloc(*d*(*d)*(*T)*sizeof(double)); - for(m=0;m<*B;m++) + for(m=0;m<*B;m++) // B bootstrap steps { - MySample(T, T, f); + MySample(T, T, f); // get a sample from my data for(t=0;t<*T;t++) { for(i=0;i<*d;i++) { bdata[(t+1)+(*T*i)-1]=data[(f[t])+(*T*i)-1]; - // Forget to change vv annd vv2, too + // Forget to change vv and vv2, too for(j=0; j<*d; j++) { bvv[(i+1)+(*d)*j+(*d)*(*d)*t-1] = vv[(i+1)+(*d)*j+(*d)*(*d)*(f[t]-1)-1]; // f[t]-1 because C starts to count at 0 @@ -454,8 +503,15 @@ } - +///////////////////////////////////////////// /* Equal probability sampling; with-replacement case */ +// Input: +// k how many samples +// n max value of sample +// +// output: +// y vector of length k returning the samples +/////////////////////////////////////// void MySample(int *k, int *n, int *y) { @@ -471,9 +527,18 @@ //////////////////////////////////////////////////////////////// +// GOF test based on empirical copula process +// +// Input: +// data data +// t,d dimensions +// family,... RVM object +// statisticName numerical value (2=Kolmogorov-Smirnov, 3=Cramer-von Mises) +// +// Output: +// statistic test statistic +//////////////////////////////////////////// -// gof-test based on empirical copula process - void gofECP(int* T, int* d, int* family, int* maxmat, int* matrix, int* conindirect, double* par, double* par2, double* data, double* statistic, int* statisticName) { double *znull, *Chat1, *Chat2, U=0; @@ -493,7 +558,7 @@ SimulateRVine(&T2, d, family, maxmat, matrix, conindirect, par, par2, znull, &U, &takeU); - ChatZj(data, data, T, d, T, Chat1); + ChatZj(data, data, T, d, T, Chat1); // empirical copula distribution ChatZj(znull, data, T, d, &T2, Chat2); *statistic=0; @@ -519,6 +584,10 @@ } +/////////////////////////// +// estimate p-value for ECP based GOF tests +////////////////////////////// + void gofECP_pvalue(int* T, int* d, int* family, int* maxmat, int* matrix, int* conindirect, double* par, double* par2, double* data, double* statistic, int* statisticName, double* pvalue, int* B) { int i=0, m=0, t=0, *f; @@ -548,10 +617,15 @@ free(bdata); } - +//////////////////////////// +// Empirical copula distribution +// +// Input: // n = dim(u)[1] // m = dim(data)[1] -// Chat vector of length n +// +// Output: +// Chat empirical copula distribution void ChatZj(double* data, double* u, int* n, int* d, int* m, double* Chat) { @@ -579,6 +653,11 @@ free(helpvar); } + +/////////////////////////// +// Copula distribution of the independence copula +//////////////////////////// + void C_ind(double* data, int* n, int* d, double* C) { int t=0, i=0; @@ -598,6 +677,11 @@ +//////////////////////////// +// GOF test based on ECP and PIT (ECP2) +// rest see above +////////////////////// + void gofECP2(int* T, int* d, int* family, int* maxmat, int* matrix, int* condirect, int* conindirect, double* par, double* par2, double* data, double* vv, double* vv2, int* calcupdate, double* statistic, int* statisticName) { @@ -647,6 +731,11 @@ free(Chat2); } + +/////////////////////////// +// p-value for ECP2 +/////////////////////////// + void gofECP2_pvalue(int* T, int* d, int* family, int* maxmat, int* matrix, int* condirect, int* conindirect, double* par, double* par2, double* data, double* vv, double* vv2, int* calcupdate, double* statistic, double* pvalue, int* statisticName, int* B) { From noreply at r-forge.r-project.org Tue Mar 31 14:15:11 2015 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Tue, 31 Mar 2015 14:15:11 +0200 (CEST) Subject: [Vinecopula-commits] r92 - pkg/R Message-ID: <20150331121511.CDA6318541D@r-forge.r-project.org> Author: tnagler Date: 2015-03-31 14:15:11 +0200 (Tue, 31 Mar 2015) New Revision: 92 Modified: pkg/R/BiCopEst.r pkg/R/BiCopSelect.r Log: fixed issue in MLE_intern where optim returns an error ('non-finite value supplied'); set lower bound of likelihood to -10^250 instead of -10^300 Modified: pkg/R/BiCopEst.r =================================================================== --- pkg/R/BiCopEst.r 2015-03-30 18:36:33 UTC (rev 91) +++ pkg/R/BiCopEst.r 2015-03-31 12:15:11 UTC (rev 92) @@ -473,8 +473,8 @@ PACKAGE = "VineCopula")[[7]] %*% weights } - if (is.infinite(ll) || is.na(ll) || ll < -10^300) - ll <- -10^300 + if (is.infinite(ll) || is.na(ll) || ll < -10^250) + ll <- -10^250 return(ll) } @@ -643,10 +643,10 @@ as.double(rep(0, n)), PACKAGE = "VineCopula")[[7]] %*% weights } + + if (is.infinite(ll) || is.na(ll) || ll < -10^250) + ll <- -10^250 - if (is.infinite(ll) || is.na(ll) || ll < -10^300) - ll <- -10^300 - return(ll) } @@ -712,8 +712,8 @@ as.double(rep(0, n)), PACKAGE = "VineCopula")[[7]] %*% weights } - if (is.infinite(ll) || is.na(ll) || ll < -10^300) - ll <- -10^300 + if (is.infinite(ll) || is.na(ll) || ll < -10^250) + ll <- -10^250 return(ll) } Modified: pkg/R/BiCopSelect.r =================================================================== --- pkg/R/BiCopSelect.r 2015-03-30 18:36:33 UTC (rev 91) +++ pkg/R/BiCopSelect.r 2015-03-31 12:15:11 UTC (rev 92) @@ -1,5 +1,4 @@ BiCopSelect <- function(u1, u2, familyset = NA, selectioncrit = "AIC", indeptest = FALSE, level = 0.05, weights = NA, rotations = TRUE) { - ## sanity checks if (is.null(u1) == TRUE || is.null(u2) == TRUE) stop("u1 and/or u2 are not set or have length zero.") @@ -31,9 +30,9 @@ data2 <- u2 ## adjust familyset if rotations = TRUE - if (rotations) familyset <- with_rotations(familyset) + if (rotations) + familyset <- with_rotations(familyset) - if (!is.na(familyset[1]) & any(familyset == 0)) { # select independence if allowed out$p.value.indeptest <- NA