From noreply at r-forge.r-project.org Fri Feb 20 12:46:27 2015 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Fri, 20 Feb 2015 12:46:27 +0100 (CET) Subject: [Vinecopula-commits] r81 - pkg/R Message-ID: <20150220114627.D2173186F35@r-forge.r-project.org> Author: tnagler Date: 2015-02-20 12:46:26 +0100 (Fri, 20 Feb 2015) New Revision: 81 Modified: pkg/R/0_prep_object.R pkg/R/AD.R pkg/R/BetaMatrix.r pkg/R/BiCopCDF.r pkg/R/BiCopChiPlot.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/BiCopIndTest.r pkg/R/BiCopLambda.r pkg/R/BiCopMetaContour.r pkg/R/BiCopName.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/BiCopTau2Par.r pkg/R/BiCopVuongClarke.r pkg/R/C2RVine.r pkg/R/ChatZj.R pkg/R/CvM.R pkg/R/D2RVine.r pkg/R/Fhat.R pkg/R/KS.R pkg/R/RVineAIC.r pkg/R/RVineClarkeTest.R pkg/R/RVineCopSelect.r pkg/R/RVineGofTest3.r pkg/R/RVineGrad.r pkg/R/RVineHessian.r pkg/R/RVineLogLik.r pkg/R/RVineMLE.R pkg/R/RVineMatrix.R pkg/R/RVinePIT.r pkg/R/RVinePar2Beta.r pkg/R/RVinePar2Tau.r pkg/R/RVinePartialcorr.R pkg/R/RVineSeqEst.R pkg/R/RVineSim.R pkg/R/RVineStdError.r pkg/R/RVineStructureSelect.r pkg/R/RVineTreePlot.r pkg/R/RVineVuongTest.R pkg/R/TauMatrix.r pkg/R/as.copuladata.R pkg/R/gof_ECP.r pkg/R/gof_PIT.r pkg/R/gof_White.r pkg/R/pairs.R Log: prettier code (with formatR package) Modified: pkg/R/0_prep_object.R =================================================================== --- pkg/R/0_prep_object.R 2015-01-28 09:34:49 UTC (rev 80) +++ pkg/R/0_prep_object.R 2015-02-20 11:46:26 UTC (rev 81) @@ -1,204 +1,237 @@ -copulaFromFamilyIndex <- function(family, par, par2=0) { - constr <- switch(paste("fam",family,sep=""), - fam0 = function(par) indepCopula(), - fam1 = function(par) normalCopula(par[1]), - fam2 = function(par) tCopula(par[1],df=par[2]), - fam3 = function(par) claytonCopula(par[1]), - fam4 = function(par) gumbelCopula(par[1]), - fam5 = function(par) frankCopula(par[1]), - fam6 = function(par) joeBiCopula(par[1]), - fam7 = BB1Copula, - fam8 = BB6Copula, - fam9 = BB7Copula, - fam10 = BB8Copula, - fam13 = function(par) surClaytonCopula(par[1]), - fam14 = function(par) surGumbelCopula(par[1]), - fam16 = function(par) surJoeBiCopula(par[1]), - fam17 = surBB1Copula, - fam18 = surBB6Copula, - fam19 = surBB7Copula, - fam20 = surBB8Copula, - fam23 = function(par) r90ClaytonCopula(par[1]), - fam24 = function(par) r90GumbelCopula(par[1]), - fam26 = function(par) r90JoeBiCopula(par[1]), - fam27 = r90BB1Copula, - fam28 = r90BB6Copula, - fam29 = r90BB7Copula, - fam30 = r90BB8Copula, - fam33 = function(par) r270ClaytonCopula(par[1]), - fam34 = function(par) r270GumbelCopula(par[1]), - fam36 = function(par) r270JoeBiCopula(par[1]), - fam37 = r270BB1Copula, - fam38 = r270BB6Copula, - fam39 = r270BB7Copula, - fam40 = r270BB8Copula, - fam104 = tawnT1Copula, - fam114 = surTawnT1Copula, - fam124 = r90TawnT1Copula, - fam134 = r270TawnT1Copula, - fam204 = tawnT2Copula, - fam214 = surTawnT2Copula, - fam224 = r90TawnT2Copula, - fam234 = r270TawnT2Copula) - constr(c(par,par2)) +copulaFromFamilyIndex <- function(family, par, par2 = 0) { + constr <- switch(paste("fam", family, sep = ""), + fam0 = function(par) indepCopula(), + fam1 = function(par) normalCopula(par[1]), + fam2 = function(par) tCopula(par[1], df = par[2]), + fam3 = function(par) claytonCopula(par[1]), + fam4 = function(par) gumbelCopula(par[1]), + fam5 = function(par) frankCopula(par[1]), + fam6 = function(par) joeBiCopula(par[1]), + fam7 = BB1Copula, + fam8 = BB6Copula, + fam9 = BB7Copula, + fam10 = BB8Copula, + fam13 = function(par) surClaytonCopula(par[1]), + fam14 = function(par) surGumbelCopula(par[1]), + fam16 = function(par) surJoeBiCopula(par[1]), + fam17 = surBB1Copula, + fam18 = surBB6Copula, + fam19 = surBB7Copula, + fam20 = surBB8Copula, + fam23 = function(par) r90ClaytonCopula(par[1]), + fam24 = function(par) r90GumbelCopula(par[1]), + fam26 = function(par) r90JoeBiCopula(par[1]), + fam27 = r90BB1Copula, + fam28 = r90BB6Copula, + fam29 = r90BB7Copula, + fam30 = r90BB8Copula, + fam33 = function(par) r270ClaytonCopula(par[1]), + fam34 = function(par) r270GumbelCopula(par[1]), + fam36 = function(par) r270JoeBiCopula(par[1]), + fam37 = r270BB1Copula, + fam38 = r270BB6Copula, + fam39 = r270BB7Copula, + fam40 = r270BB8Copula, + fam104 = tawnT1Copula, + fam114 = surTawnT1Copula, + fam124 = r90TawnT1Copula, + fam134 = r270TawnT1Copula, + fam204 = tawnT2Copula, + fam214 = surTawnT2Copula, + fam224 = r90TawnT2Copula, + fam234 = r270TawnT2Copula) + constr(c(par, par2)) } -# generic fitting -## make fitCopula from copula generic +# generic fitting make fitCopula from copula generic setGeneric("fitCopula", fitCopula) -######################################################### -## generic wrapper functions to the VineCopula package ## -######################################################### +####################### generic wrapper functions to the VineCopula package ## # density from BiCopPDF -linkVineCop.PDF <- function (u, copula, log=FALSE) { - param <- copula at parameters - - if(length(param)==1) - param <- c(param,0) - n <- nrow(u) - fam <- copula at family - -# coplik = RLL_mod_separate(fam, n, u, param)[[7]] - coplik = .C("LL_mod_seperate", as.integer(fam), as.integer(n), as.double(u[,1]), - as.double(u[,2]), as.double(param[1]), as.double(param[2]), - as.double(rep(0, n)), PACKAGE = "VineCopula")[[7]] - if(log) - return(coplik) - else - return(exp(coplik)) +linkVineCop.PDF <- function(u, copula, log = FALSE) { + param <- copula at parameters + + if (length(param) == 1) + param <- c(param, 0) + n <- nrow(u) + fam <- copula at family + + # coplik = RLL_mod_separate(fam, n, u, param)[[7]] + coplik <- .C("LL_mod_seperate", + as.integer(fam), + as.integer(n), + as.double(u[, 1]), + as.double(u[, 2]), + as.double(param[1]), + as.double(param[2]), + as.double(rep(0, n)), + PACKAGE = "VineCopula")[[7]] + if (log) return(coplik) else return(exp(coplik)) } # cdf from BiCopCDF -# for "standard" copulas: family %in% c(3:10) -linkVineCop.CDF <- function (u, copula) { - param <- copula at parameters - if (!is.matrix(u)) u <- matrix(u, ncol = 2) - n <- nrow(u) - fam <- copula at family - - res <- .C("archCDF", as.double(u[,1]), as.double(u[,2]), as.integer(n), as.double(param), - as.integer(fam), as.double(rep(0, n)), PACKAGE = "VineCopula")[[6]] - return(res) +# for 'standard' copulas: family %in% c(3:10) +linkVineCop.CDF <- function(u, copula) { + param <- copula at parameters + if (!is.matrix(u)) u <- matrix(u, ncol = 2) + n <- nrow(u) + fam <- copula at family + + res <- .C("archCDF", + as.double(u[, 1]), + as.double(u[, 2]), + as.integer(n), + as.double(param), + as.integer(fam), + as.double(rep(0, n)), + PACKAGE = "VineCopula")[[6]] + return(res) } # for survival copulas: family %in% c(13, 14, 16:20) -linkVineCop.surCDF <- function (u, copula) { - param <- copula at parameters - if (!is.matrix(u)) u <- matrix(u, ncol = 2) - u1 <- u[,1] - u2 <- u[,2] - n <- nrow(u) - fam <- copula at family - - res <- u1 + u2 - 1 + .C("archCDF", as.double(1 - u1), as.double(1 - u2), as.integer(n), - as.double(param), as.integer(fam - 10), as.double(rep(0, n)), - PACKAGE = "VineCopula")[[6]] - return(res) +linkVineCop.surCDF <- function(u, copula) { + param <- copula at parameters + if (!is.matrix(u)) u <- matrix(u, ncol = 2) + u1 <- u[, 1] + u2 <- u[, 2] + n <- nrow(u) + fam <- copula at family + + res <- u1 + u2 - 1 + .C("archCDF", + as.double(1 - u1), + as.double(1 - u2), + as.integer(n), + as.double(param), + as.integer(fam - 10), + as.double(rep(0, n)), + PACKAGE = "VineCopula")[[6]] + return(res) } # for 90 deg rotated copulas: family %in% c(23, 24, 26:30) -linkVineCop.r90CDF <- function (u, copula) { - param <- copula at parameters - if (!is.matrix(u)) u <- matrix(u, ncol = 2) - u1 <- u[,1] - u2 <- u[,2] - n <- nrow(u) - fam <- copula at family - - u2 - .C("archCDF", as.double(1 - u1), as.double(u2), as.integer(n), - as.double(-param), as.integer(fam - 20), as.double(rep(0, n)), - PACKAGE = "VineCopula")[[6]] +linkVineCop.r90CDF <- function(u, copula) { + param <- copula at parameters + if (!is.matrix(u)) u <- matrix(u, ncol = 2) + u1 <- u[, 1] + u2 <- u[, 2] + n <- nrow(u) + fam <- copula at family + + u2 - .C("archCDF", + as.double(1 - u1), + as.double(u2), + as.integer(n), + as.double(-param), + as.integer(fam - 20), + as.double(rep(0, n)), + PACKAGE = "VineCopula")[[6]] } # for 270 deg rotated copulas: family %in% c(33, 34, 36:40) -linkVineCop.r270CDF <- function (u, copula) { - param <- copula at parameters - if (!is.matrix(u)) u <- matrix(u, ncol = 2) - u1 <- u[,1] - u2 <- u[,2] - n <- nrow(u) - fam <- copula at family - - u1 - .C("archCDF", as.double(u1), as.double(1 - u2), as.integer(n), - as.double(-param), as.integer(fam - 30), as.double(rep(0, n)), - PACKAGE = "VineCopula")[[6]] +linkVineCop.r270CDF <- function(u, copula) { + param <- copula at parameters + if (!is.matrix(u)) u <- matrix(u, ncol = 2) + u1 <- u[, 1] + u2 <- u[, 2] + n <- nrow(u) + fam <- copula at family + + u1 - .C("archCDF", + as.double(u1), + as.double(1 - u2), + as.integer(n), + as.double(-param), + as.integer(fam - 30), + as.double(rep(0, n)), + PACKAGE = "VineCopula")[[6]] } -## derivtives/h-function from BiCopHfunc -# ddu -linkVineCop.ddu <- function (u, copula) { - param <- copula at parameters - - if(length(param)==1) - param <- c(param,0) - - u <- matrix(u, ncol = 2) - n <- nrow(u) - fam <- copula at family - - .C("Hfunc1", as.integer(fam), as.integer(n), as.double(u[,2]), as.double(u[,1]), - as.double(param[1]), as.double(param[2]), as.double(rep(0, n)), - PACKAGE = "VineCopula")[[7]] +## derivtives/h-function from BiCopHfunc ddu +linkVineCop.ddu <- function(u, copula) { + param <- copula at parameters + + if (length(param) == 1) param <- c(param, 0) + + u <- matrix(u, ncol = 2) + n <- nrow(u) + fam <- copula at family + + .C("Hfunc1", + as.integer(fam), + as.integer(n), + as.double(u[, 2]), + as.double(u[, 1]), + as.double(param[1]), + as.double(param[2]), + as.double(rep(0, n)), + PACKAGE = "VineCopula")[[7]] } # ddv -linkVineCop.ddv <- function (u, copula) { - param <- copula at parameters - - if(length(param)==1) - param <- c(param,0) - - u <- matrix(u, ncol = 2) - n <- nrow(u) - fam <- copula at family - - .C("Hfunc2", as.integer(fam), as.integer(n), as.double(u[,1]), as.double(u[,2]), - as.double(param[1]), as.double(param[2]), as.double(rep(0, n)), - PACKAGE = "VineCopula")[[7]] +linkVineCop.ddv <- function(u, copula) { + param <- copula at parameters + + if (length(param) == 1) param <- c(param, 0) + + u <- matrix(u, ncol = 2) + n <- nrow(u) + fam <- copula at family + + .C("Hfunc2", + as.integer(fam), + as.integer(n), + as.double(u[, 1]), + as.double(u[, 2]), + as.double(param[1]), + as.double(param[2]), + as.double(rep(0, n)), + PACKAGE = "VineCopula")[[7]] } ## random numbers from VineCopulaSim -linkVineCop.r <- function (n, copula){ - param <- copula at parameters - - if(length(param)==1) - param <- c(param,0) - - fam <- copula at family - if(is.na(param[2])) param <- c(param,0) - - res <- .C("pcc", as.integer(n), as.integer(2), as.integer(fam), as.integer(1), - as.double(param[1]), as.double(param[2]), as.double(rep(0, n * 2)), - PACKAGE = "VineCopula")[[7]] - - return(matrix(res, ncol = 2)) +linkVineCop.r <- function(n, copula) { + param <- copula at parameters + + if (length(param) == 1) param <- c(param, 0) + + fam <- copula at family + if (is.na(param[2])) param <- c(param, 0) + + res <- .C("pcc", + as.integer(n), + as.integer(2), + as.integer(fam), + as.integer(1), + as.double(param[1]), + as.double(param[2]), + as.double(rep(0, n * 2)), + PACKAGE = "VineCopula")[[7]] + + return(matrix(res, ncol = 2)) } ## Kendall's tau linkVineCop.tau <- function(copula) { - param <- copula at parameters - if(length(param)==1) - param <- c(param,0) - - BiCopPar2Tau(copula at family, param[1], param[2]) + param <- copula at parameters + if (length(param) == 1) param <- c(param, 0) + + BiCopPar2Tau(copula at family, param[1], param[2]) } ## get parameter from Kendall's tau (only for one parameter families) linkVineCop.iTau <- function(copula, tau) { - BiCopTau2Par(copula at family, tau) + BiCopTau2Par(copula at family, tau) } ## tailIndex linkVineCop.tailIndex <- function(copula) { - param <- copula at parameters - if(length(param)==1) - param <- c(param,0) - - unlist(BiCopPar2TailDep(copula at family, param[1], param[2])) + param <- copula at parameters + if (length(param) == 1) param <- c(param, 0) + + unlist(BiCopPar2TailDep(copula at family, param[1], param[2])) } setGeneric("dduCopula", function(u, copula, ...) standardGeneric("dduCopula")) Modified: pkg/R/AD.R =================================================================== --- pkg/R/AD.R 2015-01-28 09:34:49 UTC (rev 80) +++ pkg/R/AD.R 2015-02-20 11:46:26 UTC (rev 81) @@ -1,20 +1,17 @@ -"AD" = -function(cdf=NULL) -{ - # Cumulative distribution function test: - # Function that computes the Anderson-Darling test statistic - #-------------------------------------------------------------------------- - # INPUT: - # cdf CDF for which to compute AD test - # OUTPUT: - # AD Anderson-Darling test statistic - #-------------------------------------------------------------------------- - # Author: Daniel Berg - # Date: 27.03.2006 - # Version: 1.0.1 - #-------------------------------------------------------------------------- - n = length(cdf) - AD = .C("ADtest",as.double(cdf),as.integer(n),as.double(0),PACKAGE='VineCopula')[[3]] - AD -} - +"AD" <- function(cdf = NULL) { + # Cumulative distribution function test: Function that computes the + # Anderson-Darling test statistic + # -------------------------------------------------------------------------- + # INPUT: cdf CDF for which to compute AD test OUTPUT: + # AD Anderson-Darling test statistic + # -------------------------------------------------------------------------- + # Author: Daniel Berg Date: 27.03.2006 Version: 1.0.1 + # -------------------------------------------------------------------------- + n <- length(cdf) + AD <- .C("ADtest", + as.double(cdf), + as.integer(n), + as.double(0), + PACKAGE = "VineCopula")[[3]] + AD +} Modified: pkg/R/BetaMatrix.r =================================================================== --- pkg/R/BetaMatrix.r 2015-01-28 09:34:49 UTC (rev 80) +++ pkg/R/BetaMatrix.r 2015-02-20 11:46:26 UTC (rev 81) @@ -1,48 +1,45 @@ -BetaMatrix<-function(data) -{ - d<-dim(data)[2] - - betahat=matrix(1,d,d) - for(i in 1:(d-1)) - { - u1=data[,i] - for(j in (i+1):d) - { - u2=data[,j] - betahat[i,j]<-betaFunc(u1,u2,1/2,1/2) - betahat[j,i]=betahat[i,j] - } - } - -return(betahat) +BetaMatrix <- function(data) { + d <- dim(data)[2] + + betahat <- matrix(1, d, d) + for (i in 1:(d - 1)) { + u1 <- data[, i] + for (j in (i + 1):d) { + u2 <- data[, j] + betahat[i, j] <- betaFunc(u1, u2, 1/2, 1/2) + betahat[j, i] <- betahat[i, j] + } + } + + return(betahat) } # empirical copula -empcop<-function(u1,u2,u,v) -{ - n=length(u1) - a<-which(u1u) - b<-which(u2>v) - sc<-intersect(a,b) - return(1/n*length(sc)) +survivalcop <- function(u1, u2, u, v) { + n <- length(u1) + a <- which(u1 > u) + b <- which(u2 > v) + sc <- intersect(a, b) + return(1/n * length(sc)) } # h_d -h<-function(u,v) (min(u,v)+min(1-u)-u*v-(1-u)*(1-v))^-1 +h <- function(u, v) (min(u, v) + min(1 - u) - u * v - (1 - u) * (1 - v))^-1 # g_d -g<-function(u,v) (u*v)+(1-u)*(1-v) +g <- function(u, v) (u * v) + (1 - u) * (1 - v) # beta -betaFunc<-function(u1,u2,u,v) h(u,v)*(empcop(u1,u2,u,v)+survivalcop(u1,u2,u,v)-g(u,v)) \ No newline at end of file +betaFunc <- function(u1, u2, u, v) { + h(u, v) * (empcop(u1, u2, u, v) + survivalcop(u1, u2, u, v) - g(u, v)) +} Modified: pkg/R/BiCopCDF.r =================================================================== --- pkg/R/BiCopCDF.r 2015-01-28 09:34:49 UTC (rev 80) +++ pkg/R/BiCopCDF.r 2015-02-20 11:46:26 UTC (rev 81) @@ -1,127 +1,185 @@ -BiCopCDF <- function(u1, u2, family, par, par2 = 0){ - - ## sanity checks - 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)) 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].") - if(length(u1)!=length(u2)) stop("Lengths of 'u1' and 'u2' do not match.") - 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.") - 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].") - - res = rep(NA, length(u1)) - - ## CDFs for the different families - if(family == 0){ - res = u1*u2 - }else if(family == 1){ - cdf = function(u,v) pmvnorm(upper=c(qnorm(u),qnorm(v)), corr=matrix(c(1,par,par,1),2,2)) - res = mapply(cdf, u1, u2, SIMPLIFY=TRUE) - #}else if(family == 2){ -# par2=round(par2) - # cdf = function(u,v) pmvt(upper=c(qt(u,df=par2),qt(v,df=par2)), corr=matrix(c(1,par,par,1),2,2), df=par2) - # res = mapply(cdf, u1, u2, SIMPLIFY=TRUE) - }else if(family %in% c(3:10,41)){ - res = .C("archCDF",as.double(u1),as.double(u2),as.integer(length(u1)),as.double(c(par,par2)),as.integer(family),as.double(rep(0,length(u1))),PACKAGE='VineCopula')[[6]] - }else if(family %in% c(13,14,16:20,51)){ - res = u1+u2-1+.C("archCDF",as.double(1-u1),as.double(1-u2),as.integer(length(u1)),as.double(c(par,par2)),as.integer(family-10),as.double(rep(0,length(u1))),PACKAGE='VineCopula')[[6]] - }else if(family %in% c(23,24,26:30,61)){ - res = u2-.C("archCDF",as.double(1-u1),as.double(u2),as.integer(length(u1)),as.double(c(-par,-par2)),as.integer(family-20),as.double(rep(0,length(u1))),PACKAGE='VineCopula')[[6]] - }else if(family %in% c(33,34,36:40,71)){ - res = u1-.C("archCDF",as.double(u1),as.double(1-u2),as.integer(length(u1)),as.double(c(-par,-par2)),as.integer(family-30),as.double(rep(0,length(u1))),PACKAGE='VineCopula')[[6]] - }else if(family %in% c(104,114,124,134,204,214,224,234)){# maybe replace by C-Code - ## auxiliary functions ### - ta <- function(t,par,par2,par3){(par2*t)^par+(par3*(1-t))^par} - ######## Pickands A - A <- function(t,par,par2,par3){ - (1-par3)*(1-t)+(1-par2)*t+ta(t,par,par2,par3)^(1/par) - } +BiCopCDF <- function(u1, u2, family, par, par2 = 0) { - w <- function(u1,u2){ - log(u2)/log(u1*u2) + ## sanity checks + 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)) + 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].") + if (length(u1) != length(u2)) + stop("Lengths of 'u1' and 'u2' do not match.") + 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.") + 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].") + + res <- rep(NA, length(u1)) + + ## CDFs for the different families + if (family == 0) { + res <- u1 * u2 + } else if (family == 1) { + cdf <- function(u, v) pmvnorm(upper = c(qnorm(u), qnorm(v)), + corr = matrix(c(1, par, par, 1), 2, 2)) + res <- mapply(cdf, u1, u2, SIMPLIFY = TRUE) + # }else if(family == 2){ par2=round(par2) cdf = function(u,v) + # pmvt(upper=c(qt(u,df=par2),qt(v,df=par2)), corr=matrix(c(1,par,par,1),2,2), + # df=par2) res = mapply(cdf, u1, u2, SIMPLIFY=TRUE) + } else if (family %in% c(3:10, 41)) { + res <- .C("archCDF", + as.double(u1), + as.double(u2), + as.integer(length(u1)), + as.double(c(par, par2)), + as.integer(family), + as.double(rep(0, length(u1))), + PACKAGE = "VineCopula")[[6]] + } else if (family %in% c(13, 14, 16:20, 51)) { + res <- u1 + u2 - 1 + .C("archCDF", + as.double(1 - u1), + as.double(1 - u2), + as.integer(length(u1)), + as.double(c(par, par2)), + as.integer(family - 10), + as.double(rep(0, length(u1))), + PACKAGE = "VineCopula")[[6]] + } else if (family %in% c(23, 24, 26:30, 61)) { + res <- u2 - .C("archCDF", + as.double(1 - u1), + as.double(u2), + as.integer(length(u1)), + as.double(c(-par, -par2)), + as.integer(family - 20), + as.double(rep(0, length(u1))), + PACKAGE = "VineCopula")[[6]] + } else if (family %in% c(33, 34, 36:40, 71)) { + res <- u1 - .C("archCDF", + as.double(u1), + as.double(1 - u2), + as.integer(length(u1)), + as.double(c(-par, -par2)), + as.integer(family - 30), + as.double(rep(0, length(u1))), + PACKAGE = "VineCopula")[[6]] + } else if (family %in% c(104, 114, 124, 134, 204, 214, 224, 234)) { + # maybe replace by C-Code auxiliary functions ### + ta <- function(t, par, par2, par3) { + (par2 * t)^par + (par3 * (1 - t))^par + } + ######## Pickands A + A <- function(t, par, par2, par3) { + (1 - par3) * (1 - t) + (1 - par2) * t + ta(t, par, par2, par3)^(1/par) + } + + w <- function(u1, u2) { + log(u2)/log(u1 * u2) + } + C <- function(u, v, par, par2, par3) { + (u1 * u2)^A(w(u1, u2), par, par2, par3) + } + + if (family == 104) { + par3 <- 1 + res <- C(u1, u2, par, par2, par3) + } else if (family == 114) { + par3 <- 1 + res <- u1 + u2 - 1 + C(1 - u1, 1 - u2, par, par2, par3) + } else if (family == 124) { + par3 <- 1 [TRUNCATED] To get the complete diff run: svnlook diff /svnroot/vinecopula -r 81 From noreply at r-forge.r-project.org Fri Feb 20 14:51:02 2015 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Fri, 20 Feb 2015 14:51:02 +0100 (CET) Subject: [Vinecopula-commits] r82 - pkg/R Message-ID: <20150220135102.34E35187690@r-forge.r-project.org> Author: tnagler Date: 2015-02-20 14:51:01 +0100 (Fri, 20 Feb 2015) New Revision: 82 Modified: pkg/R/BiCopEst.r pkg/R/RVineCopSelect.r pkg/R/RVineSim.R Log: Bugfixes: - BiCopEst: extend search interval for Tawn MLE to avoid optim-errors - RVineSim: reorder U so that it corresponds to the order of RVM Modified: pkg/R/BiCopEst.r =================================================================== --- pkg/R/BiCopEst.r 2015-02-20 11:46:26 UTC (rev 81) +++ pkg/R/BiCopEst.r 2015-02-20 13:51:01 UTC (rev 82) @@ -898,17 +898,18 @@ MLE_intern_Tawn <- function(data, start.parm, family, se = FALSE) { n <- dim(data)[1] + + ## set bounds for optimization tau <- fasttau(data[, 1], data[, 2]) - if (family == 104 || family == 114 || family == 204 || family == 214) { - parlower <- c(1.001, max(tau, 1e-04)) - parupper <- c(20, min(tau + 0.1, 0.99)) + parlower <- c(1.001, max(tau - 0.1, 1e-04)) + parupper <- c(20, min(tau + 0.2, 0.99)) } else if (family == 124 || family == 134 || family == 224 || family == 234) { - parlower <- c(-20, max(-tau, 1e-04)) - parupper <- c(-1.001, min(-tau + 0.1, 0.99)) + parlower <- c(-20, max(-tau - 0.1, 1e-04)) + parupper <- c(-1.001, min(-tau + 0.2, 0.99)) } - # Hier fehlt noch die log-likelihood Funktion + ## log-liklihood function loglikfunc <- function(param) { ll <- .C("LL_mod2", as.integer(family), @@ -925,6 +926,7 @@ return(ll) } + ## optimize log-likelihood out <- list() # print(start.parm) if (se == TRUE) { @@ -951,6 +953,7 @@ control = list(fnscale = -1, maxit = 500)) } + ## return results out$par <- optimout$par out$value <- optimout$value return(out) Modified: pkg/R/RVineCopSelect.r =================================================================== --- pkg/R/RVineCopSelect.r 2015-02-20 11:46:26 UTC (rev 81) +++ pkg/R/RVineCopSelect.r 2015-02-20 13:51:01 UTC (rev 82) @@ -1,13 +1,12 @@ RVineCopSelect <- function(data, familyset = NA, Matrix, selectioncrit = "AIC", indeptest = FALSE, level = 0.05, trunclevel = NA) { - n <- dim(data)[2] N <- nrow(data) + ## sanity checks if (dim(Matrix)[1] != dim(Matrix)[2]) stop("Structure matrix has to be quadratic.") if (max(Matrix) > dim(Matrix)[1]) stop("Error in the structure matrix.") - if (N < 2) stop("Number of observations has to be at least 2.") if (n < 2) @@ -24,59 +23,60 @@ if (level < 0 & level > 1) stop("Significance level has to be between 0 and 1.") + ## adjustement for truncated vines if (is.na(trunclevel)) trunclevel <- n - types <- familyset if (trunclevel == 0) types <- 0 + ## reorder matrix to natural order M <- Matrix - Mold <- M - o <- diag(M) M <- reorderRVineMatrix(M) - data <- data[, o[length(o):1]] + ## create matrices required for selection of h-functions MaxMat <- createMaxMat(M) CondDistr <- neededCondDistr(M) + ## create objects for results Types <- matrix(0, n, n) - Params <- matrix(0, n, n) Params2 <- matrix(0, n, n) - V <- list() V$direct <- array(NA, dim = c(n, n, N)) V$indirect <- array(NA, dim = c(n, n, N)) V$direct[n, , ] <- t(data[, n:1]) + ## loop over all trees and pair-copulas for (i in (n - 1):1) { for (k in n:(i + 1)) { - m <- MaxMat[k, i] - + ## get (pseudo-) observations + m <- MaxMat[k, i] # edge identifier zr1 <- V$direct[k, i, ] - if (m == M[k, i]) { zr2 <- V$direct[k, (n - m + 1), ] } else { zr2 <- V$indirect[k, (n - m + 1), ] } + ## estimate pair-copula if (n + 1 - k > trunclevel) { outcop <- BiCopSelect(zr2, zr1, 0, selectioncrit, indeptest, level) } else { # outcop = BiCopSelect(zr1,zr2,types,selectioncrit,indeptest,level) - outcop <- BiCopSelect(zr2, zr1, types, selectioncrit, indeptest, level) + outcop <- BiCopSelect(zr2, zr1, types[1:3], selectioncrit, indeptest, level) } + ## store results for pair-copula Types[k, i] <- outcop$family Params[k, i] <- outcop$par Params2[k, i] <- outcop$par2 + ## calculate pseudo observations required in the next tree if (CondDistr$direct[k - 1, i]) # V$direct[k-1,i,] = outcop$CondOn.2 V$direct[k - 1, i, ] <- .C("Hfunc1", @@ -102,15 +102,13 @@ } } + ## return results varnames <- paste("V", 1:n, sep = "") - print(Types) - RVM <- RVineMatrix(Mold, family = Types, par = Params, par2 = Params2, names = varnames) - return(RVM) } Modified: pkg/R/RVineSim.R =================================================================== --- pkg/R/RVineSim.R 2015-02-20 11:46:26 UTC (rev 81) +++ pkg/R/RVineSim.R 2015-02-20 13:51:01 UTC (rev 82) @@ -1,21 +1,24 @@ RVineSim <- function(N, RVM, U = NULL) { + + ## sanity checks stopifnot(N >= 1) if (!is(RVM, "RVineMatrix")) stop("'RVM' has to be an RVineMatrix object.") + ## reorder matrix and U (if provided) n <- dim(RVM) - o <- diag(RVM$Matrix) RVM <- normalizeRVineMatrix(RVM) - takeU <- !is.null(U) if (takeU) { if (!is.matrix(U)) U <- rbind(U, deparse.level = 0L) if ((d <- ncol(U)) < 2) stop("U should be at least bivariate") # should be an (N, n) matrix + U <- U[, rev(o)] } + ## create objects for C-call matri <- as.vector(RVM$Matrix) w1 <- as.vector(RVM$family) th <- as.vector(RVM$par) @@ -28,9 +31,9 @@ th2[is.na(th2)] <- 0 maxmat[is.na(maxmat)] <- 0 conindirect[is.na(conindirect)] <- 0 - tmp <- rep(0, n * N) + ## simulate R-Vine tmp <- .C("SimulateRVine", as.integer(N), as.integer(n), @@ -45,13 +48,11 @@ as.integer(takeU), PACKAGE = "VineCopula")[[9]] + ## store results, bring back to initial order and return out <- matrix(tmp, ncol = n) - - if (!is.null(RVM$names)) { colnames(out) <- RVM$names } - out <- out[, sort(o[length(o):1], index.return = TRUE)$ix] return(out) } From noreply at r-forge.r-project.org Tue Feb 24 13:00:28 2015 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Tue, 24 Feb 2015 13:00:28 +0100 (CET) Subject: [Vinecopula-commits] r83 - in pkg: . R man Message-ID: <20150224120029.05AA7186F3F@r-forge.r-project.org> Author: tnagler Date: 2015-02-24 13:00:28 +0100 (Tue, 24 Feb 2015) New Revision: 83 Added: pkg/man/RVinePDF.Rd Modified: pkg/DESCRIPTION pkg/NAMESPACE pkg/R/BiCopSelect.r pkg/R/RVineCopSelect.r pkg/R/RVineLogLik.r pkg/R/RVineMatrix.R pkg/R/RVineStructureSelect.r pkg/man/BiCopSelect.Rd pkg/man/RVineCopSelect.Rd pkg/man/RVineMatrix.Rd pkg/man/RVineStructureSelect.Rd Log: - Update version to 1.5 - add function RVinePDF - BiCopSelect, RVineCopSelect, RVineStructureSelect: add option "rotations = TRUE" which augments the familyset with all rotations to a given family - RVineMatrix, RVineStructureSelect: allow upper triagonal matrices as input (output remains lower triagonal) - addapt manual files and NAMESPACE to changes Modified: pkg/DESCRIPTION =================================================================== --- pkg/DESCRIPTION 2015-02-20 13:51:01 UTC (rev 82) +++ pkg/DESCRIPTION 2015-02-24 12:00:28 UTC (rev 83) @@ -1,7 +1,7 @@ Package: VineCopula Type: Package Title: Statistical Inference of Vine Copulas -Version: 1.4 +Version: 1.5 Date: 2015-01-26 Author: Ulf Schepsmeier, Jakob Stoeber, Eike Christian Brechmann, Benedikt Graeler Maintainer: Tobias Erhardt Modified: pkg/NAMESPACE =================================================================== --- pkg/NAMESPACE 2015-02-20 13:51:01 UTC (rev 82) +++ pkg/NAMESPACE 2015-02-24 12:00:28 UTC (rev 83) @@ -31,6 +31,7 @@ export(BiCopGofTest) export(RVineLogLik) +export(RVinePDF) export(RVineAIC) export(RVineBIC) export(RVineMatrix) Modified: pkg/R/BiCopSelect.r =================================================================== --- pkg/R/BiCopSelect.r 2015-02-20 13:51:01 UTC (rev 82) +++ pkg/R/BiCopSelect.r 2015-02-24 12:00:28 UTC (rev 83) @@ -1,4 +1,6 @@ -BiCopSelect <- function(u1, u2, familyset = NA, selectioncrit = "AIC", indeptest = FALSE, level = 0.05, weights = NA) { +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.") if (length(u1) != length(u2)) @@ -23,10 +25,15 @@ if (level < 0 & level > 1) stop("Significance level has to be between 0 and 1.") + ## prepare objects out <- list() data1 <- u1 data2 <- u2 + ## adjust familyset if rotations = TRUE + if (rotations) familyset <- with_rotations(familyset) + + if (!is.na(familyset[1]) & any(familyset == 0)) { # select independence if allowed out$p.value.indeptest <- NA @@ -465,3 +472,28 @@ out$par <- out$par[1] out } + + +##### ---------------------------------------------------------------------- +## function for augmenting a familyset with rotations +with_rotations <- function(nums) { + unique(unlist(lapply(nums, get_rotations))) +} + +get_rotations <- function(i) { + # no roations for independence, gaussian, student and frank copulas + out <- i + + ## rotations for other families + if(i %in% c(3, 13, 23, 33)) out <- c(3, 13, 23, 33) + if(i %in% c(4, 14, 24, 34)) out <- c(4, 14, 24, 34) + if(i %in% c(6, 16, 26, 36)) out <- c(6, 16, 26, 36) + if(i %in% c(7, 17, 27, 37)) out <- c(7, 17, 27, 37) + if(i %in% c(8, 18, 28, 38)) out <- c(8, 18, 28, 38) + if(i %in% c(9, 19, 29, 39)) out <- c(9, 19, 29, 39) + if(i %in% c(10, 20, 30, 40)) out <- c(10, 20, 30, 40) + if(i %in% c(104, 114, 124, 134)) out <- c(104, 114, 124, 134) + if(i %in% c(204, 214, 224, 234)) out <- c(204, 214, 224, 234) + + out +} Modified: pkg/R/RVineCopSelect.r =================================================================== --- pkg/R/RVineCopSelect.r 2015-02-20 13:51:01 UTC (rev 82) +++ pkg/R/RVineCopSelect.r 2015-02-24 12:00:28 UTC (rev 83) @@ -1,5 +1,5 @@ -RVineCopSelect <- function(data, familyset = NA, Matrix, selectioncrit = "AIC", indeptest = FALSE, level = 0.05, trunclevel = NA) { - n <- dim(data)[2] +RVineCopSelect <- function(data, familyset = NA, Matrix, selectioncrit = "AIC", indeptest = FALSE, level = 0.05, trunclevel = NA, rotations = TRUE) { + n <- ncol(data) N <- nrow(data) ## sanity checks @@ -22,15 +22,16 @@ stop("Selection criterion not implemented.") if (level < 0 & level > 1) stop("Significance level has to be between 0 and 1.") - - ## adjustement for truncated vines if (is.na(trunclevel)) trunclevel <- n + + ## adjust familyset types <- familyset if (trunclevel == 0) types <- 0 ## reorder matrix to natural order + Matrix <- ToLowerTri(Matrix) M <- Matrix Mold <- M o <- diag(M) @@ -65,10 +66,24 @@ ## estimate pair-copula if (n + 1 - k > trunclevel) { - outcop <- BiCopSelect(zr2, zr1, 0, selectioncrit, indeptest, level) + outcop <- BiCopSelect(zr2, + zr1, + 0, + selectioncrit, + indeptest, + level, + weights = NA, + rotations) } else { # outcop = BiCopSelect(zr1,zr2,types,selectioncrit,indeptest,level) - outcop <- BiCopSelect(zr2, zr1, types[1:3], selectioncrit, indeptest, level) + outcop <- BiCopSelect(zr2, + zr1, + types, + selectioncrit, + indeptest, + level, + weights = NA, + rotations) } ## store results for pair-copula Modified: pkg/R/RVineLogLik.r =================================================================== --- pkg/R/RVineLogLik.r 2015-02-20 13:51:01 UTC (rev 82) +++ pkg/R/RVineLogLik.r 2015-02-24 12:00:28 UTC (rev 83) @@ -107,3 +107,8 @@ return(list(loglik = loglik, V = V)) } + + +RVinePDF <- function(newdata, RVM) { + exp(RVineLogLik(newdata, RVM, separate = TRUE)$loglik) +} \ No newline at end of file Modified: pkg/R/RVineMatrix.R =================================================================== --- pkg/R/RVineMatrix.R 2015-02-20 13:51:01 UTC (rev 82) +++ pkg/R/RVineMatrix.R 2015-02-24 12:00:28 UTC (rev 83) @@ -1,11 +1,20 @@ RVineMatrix <- function(Matrix, family = array(0, dim = dim(Matrix)), par = array(NA, dim = dim(Matrix)), par2 = array(NA, dim = dim(Matrix)), names = NULL) { + ## set NAs to zero Matrix[is.na(Matrix)] <- 0 family[is.na(family)] <- 0 + par[is.na(par)] <- 0 + par2[is.na(par2)] <- 0 + + ## convert to lower triangular matrix if necessary + Matrix <- ToLowerTri(Matrix) + family <- ToLowerTri(family) + par <- ToLowerTri(par) + par2 <- ToLowerTri(par2) + + ## set upper triangle to zero family[upper.tri(family, diag = T)] <- 0 - par[is.na(par)] <- 0 par[upper.tri(par, diag = T)] <- 0 - par2[is.na(par2)] <- 0 par2[upper.tri(par2, diag = T)] <- 0 if (dim(Matrix)[1] != dim(Matrix)[2]) @@ -554,3 +563,23 @@ if (is.matrix(b)) return(1) else return(-1) } + +#### ------------------------------------------------------------- +## function that converts upper triagonal matrix to lower triagonal +ToLowerTri <- function(x) { + ## only change matrix if not already lower triagonal + if(all(x[lower.tri(x)] == 0)) { + x[nrow(x):1, ncol(x):1] + } else { + x + } +} + +ToUpperTri <- function(x) { + ## only change matrix if not already upper triagonal + if(all(x[upper.tri(x)] == 0)) { + x[nrow(x):1, ncol(x):1] + } else { + x + } +} Modified: pkg/R/RVineStructureSelect.r =================================================================== --- pkg/R/RVineStructureSelect.r 2015-02-20 13:51:01 UTC (rev 82) +++ pkg/R/RVineStructureSelect.r 2015-02-24 12:00:28 UTC (rev 83) @@ -1,46 +1,53 @@ RVineStructureSelect <- function(data, familyset = NA, type = 0, selectioncrit = "AIC", indeptest = FALSE, - level = 0.05, trunclevel = NA, progress = FALSE, weights = NA) { + level = 0.05, trunclevel = NA, progress = FALSE, weights = NA, rotations = TRUE) { + d <- n <- dim(data)[2] + N <- dim(data)[1] + ## sanity checks if (type == 0) type <- "RVine" else if (type == 1) type <- "CVine" if (type != "RVine" & type != "CVine") stop("Vine model not implemented.") - - d <- n <- dim(data)[2] - N <- dim(data)[1] - if (N < 2) stop("Number of observations has to be at least 2.") if (d < 3) stop("Dimension has to be at least 3.") if (any(data > 1) || any(data < 0)) stop("Data has to be in the interval [0,1].") - - if (!is.na(familyset[1])) - for (i in 1:length(familyset)) if (!(familyset[i] %in% c(0, 1:10, 13, 14, 16:20, - 23, 24, 26:30, 33, 34, 36:40, - 104, 114, 124, 134, - 204, 214, 224, 234))) - stop("Copula family not implemented.") + if (!is.na(familyset[1])) { + for (i in 1:length(familyset)) { + if (!(familyset[i] %in% c(0, 1:10, 13, 14, 16:20, + 23, 24, 26:30, 33, 34, 36:40, + 104, 114, 124, 134, 204, 214, 224, 234))) + stop("Copula family not implemented.") + } + } if (selectioncrit != "AIC" && selectioncrit != "BIC") stop("Selection criterion not implemented.") if (level < 0 & level > 1) stop("Significance level has to be between 0 and 1.") + ## set variable names and trunclevel if not provided if (is.null(colnames(data))) colnames(data) <- paste("V", 1:n, sep = "") - if (is.na(trunclevel)) trunclevel <- d - RVine <- list(Tree = NULL, Graph = NULL) - + ## adjust familyset if (trunclevel == 0) familyset <- 0 + if (rotations) + familyset <- with_rotations(familyset) + ## initialize object for results + RVine <- list(Tree = NULL, Graph = NULL) + + ## estimation in first tree ---------------------------- + # find optimal tree g <- initializeFirstGraph(data, weights) - mst <- findMaximumTauTree(g, mode = type) + mst <- findMaximumTauTree(g, mode = type) + # estimate pair-copulas VineTree <- fit.FirstTreeCopulas(mst, data, familyset, @@ -48,20 +55,20 @@ indeptest, level, weights = weights) - + # store results RVine$Tree[[1]] <- VineTree RVine$Graph[[1]] <- g oldVineGraph <- VineTree - + ## estimation in higher trees -------------------------- for (i in 2:(n - 1)) { - + # only estimate pair-copulas if not truncated if (trunclevel == i - 1) familyset <- 0 - + # find optimal tree g <- buildNextGraph(VineTree, weights) - mst <- findMaximumTauTree(g, mode = type) - + mst <- findMaximumTauTree(g, mode = type) + # estimate pair-copulas VineTree <- fit.TreeCopulas(mst, VineTree, familyset, @@ -70,12 +77,13 @@ level, progress, weights = weights) - + # store results RVine$Tree[[i]] <- VineTree RVine$Graph[[i]] <- g } - return(as.RVM(RVine)) + ## return results as 'RVineMatrix' object + as.RVM(RVine) } initializeFirstGraph <- function(data.univ, weights) { @@ -179,11 +187,11 @@ if (is.null(V(mst)[a[1]]$name) || is.null(V(mst)[a[2]]$name)) { E(mst)[i]$Copula.Name <- paste(a[1], a[2], sep = " , ") - } else { - E(mst)[i]$Copula.Name <- paste(V(mst)[a[1]]$name, - V(mst)[a[2]]$name, - sep = " , ") - } + } else { + E(mst)[i]$Copula.Name <- paste(V(mst)[a[1]]$name, + V(mst)[a[2]]$name, + sep = " , ") + } } outForACopula <- lapply(X = parameterForACopula, @@ -451,7 +459,13 @@ fit.ACopula <- function(u1, u2, familyset = NA, selectioncrit = "AIC", indeptest = FALSE, level = 0.05, weights = NA) { ## select family and estimate parameter(s) for the pair copula - out <- BiCopSelect(u1, u2, familyset, selectioncrit, indeptest, level, weights = weights) + out <- BiCopSelect(u1, u2, + familyset, + selectioncrit, + indeptest, + level, + weights = weights, + rotations = FALSE) ## change rotation if family is not symmetric wrt the main diagonal if (out$family %in% c(23, 24, 26:30, 124, 224)) { Modified: pkg/man/BiCopSelect.Rd =================================================================== --- pkg/man/BiCopSelect.Rd 2015-02-20 13:51:01 UTC (rev 82) +++ pkg/man/BiCopSelect.Rd 2015-02-24 12:00:28 UTC (rev 83) @@ -10,8 +10,8 @@ } \usage{ -BiCopSelect(u1, u2, familyset = NA, selectioncrit = "AIC", - indeptest = FALSE, level = 0.05, weights = NA) +BiCopSelect(u1, u2, familyset = NA, selectioncrit = "AIC", indeptest = FALSE, + level = 0.05, weights = NA, rotations = TRUE) } \arguments{ @@ -67,6 +67,7 @@ The independence copula is chosen if the null hypothesis of independence cannot be rejected.} \item{level}{Numeric; significance level of the independence test (default: \code{level = 0.05}).} \item{weights}{Numerical; weights for each observation (optional).} + \item{rotations}{If \code{TRUE}, all rotations of the families in \code{familyset} are included.} } \value{ Modified: pkg/man/RVineCopSelect.Rd =================================================================== --- pkg/man/RVineCopSelect.Rd 2015-02-20 13:51:01 UTC (rev 82) +++ pkg/man/RVineCopSelect.Rd 2015-02-24 12:00:28 UTC (rev 83) @@ -9,8 +9,8 @@ } \usage{ -RVineCopSelect(data, familyset = NA, Matrix, selectioncrit = "AIC", - indeptest = FALSE, level = 0.05, trunclevel = NA) +RVineCopSelect(data, familyset = NA, Matrix, selectioncrit = "AIC", indeptest = FALSE, + level = 0.05, trunclevel = NA, rotations = TRUE) } \arguments{ @@ -19,13 +19,14 @@ The vector has to include at least one pair-copula family that allows for positive and one that allows for negative dependence. Not listed copula families might be included to better handle limit cases. If \code{familyset = NA} (default), selection among all possible families is performed. The coding of pair-copula families is shown below.} - \item{Matrix}{Lower triangular d x d matrix that defines the R-vine tree structure.} + \item{Matrix}{Lower or upper triangular d x d matrix that defines the R-vine tree structure.} \item{selectioncrit}{Character indicating the criterion for pair-copula selection. Possible choices: \code{selectioncrit = "AIC"} (default) or \code{"BIC"} (see \code{\link{BiCopSelect}}).} \item{indeptest}{Logical; whether a hypothesis test for the independence of \code{u1} and \code{u2} is performed before bivariate copula selection (default: \code{indeptest = FALSE}; see \code{\link{BiCopIndTest}}). The independence copula is chosen for a (conditional) pair if the null hypothesis of independence cannot be rejected.} \item{level}{Numeric; significance level of the independence test (default: \code{level = 0.05}).} \item{trunclevel}{Integer; level of truncation.} + \item{rotations}{If \code{TRUE}, all rotations of the families in \code{familyset} are included.} } \details{ @@ -134,5 +135,6 @@ # determine the pair-copula families and parameters RVM1 <- RVineCopSelect(simdata, familyset = c(1, 3, 4, 5 ,6), Matrix) + } Modified: pkg/man/RVineMatrix.Rd =================================================================== --- pkg/man/RVineMatrix.Rd 2015-02-20 13:51:01 UTC (rev 82) +++ pkg/man/RVineMatrix.Rd 2015-02-24 12:00:28 UTC (rev 83) @@ -16,8 +16,8 @@ } \arguments{ - \item{Matrix}{Lower triangular d x d matrix that defines the R-vine tree structure.} - \item{family}{Lower triangular d x d matrix with zero diagonal entries that assigns the pair-copula families + \item{Matrix}{Lower (or upper) triangular d x d matrix that defines the R-vine tree structure.} + \item{family}{Lower (or upper) triangular d x d matrix with zero diagonal entries that assigns the pair-copula families to each (conditional) pair defined by \code{Matrix} (default: \code{family = array(0,dim=dim(Matrix))}). The bivariate copula families are defined as follows:\cr \code{0} = independence copula \cr @@ -61,10 +61,10 @@ \code{224} = rotated Tawn type 2 copula (90 degrees) \cr \code{234} = rotated Tawn type 2 copula (270 degrees) \cr } - \item{par}{Lower triangular d x d matrix with zero diagonal entries that assigns the (first) pair-copula parameter + \item{par}{Lower (or upper) triangular d x d matrix with zero diagonal entries that assigns the (first) pair-copula parameter to each (conditional) pair defined by \code{Matrix} \cr (default: \code{par = array(NA, dim = dim(Matrix))}).} - \item{par2}{Lower triangular d x d matrix with zero diagonal entries that assigns the second parameter + \item{par2}{Lower (or upper) triangular d x d matrix with zero diagonal entries that assigns the second parameter for pair-copula families with two parameters to each (conditional) pair defined by \code{Matrix} (default: \code{par2 = array(NA, dim = dim(Matrix))}).} \item{names}{A vector of names for the d variables; default: \code{names = NULL}.} } @@ -80,7 +80,8 @@ \note{ The \code{print} function writes the R-vine matrix defined by \code{Matrix}. A detailed output is given by \code{print(RVM, detail=TRUE)}, where \code{RVM} is the \code{\link{RVineMatrix}} object. \cr -The \code{\link{RVineMatrix}} function automatically checks if the given matrix is a valid R-vine matrix (see \code{\link{RVineMatrixCheck}}). +The \code{\link{RVineMatrix}} function automatically checks if the given matrix is a valid R-vine matrix (see \code{\link{RVineMatrixCheck}}). \cr +Although the function allows upper triangular matrices as its input, it will always store them as lower triangular matrices. } \references{ Added: pkg/man/RVinePDF.Rd =================================================================== --- pkg/man/RVinePDF.Rd (rev 0) +++ pkg/man/RVinePDF.Rd 2015-02-24 12:00:28 UTC (rev 83) @@ -0,0 +1,91 @@ +\name{RVinePDF} +\alias{RVinePDF} + +\title{PDF of an R-Vine Copula Model} + +\description{ +This function calculates the probability density function of a d-dimensional R-vine copula. +} + +\usage{ +RVinePDF(newdata, RVM) +} + +\arguments{ + \item{newdata}{An N x d data matrix that specifies where the density shall be evaluated.} + \item{RVM}{An \code{\link{RVineMatrix}} object including the structure and the pair-copula families and parameters.} +} + + +\details{ +The density of a \eqn{d}-dimensional R-vine copula with \eqn{d-1} trees and corresponding edge sets \eqn{E_1,...,E_{d-1}} is given by +\deqn{ +\prod_{\ell=1}^{d-1} \prod_{e\in E_\ell} +c_{j(e),k(e)|D(e)}\left(F(u_{j(e)}|\boldsymbol{u}_{D(e)}),F(u_{k(e)}|\boldsymbol{u}_{D(e)})|\boldsymbol{\theta}_{j(e),k(e)|D(e)}\right), +}{ +=\prod_{k=1}^{d-1} \prod_{e\in E_k} +c_{j(e),k(e)|D(e)}(F(u_{j(e)}|u_{D(e)}),F(u_{k(e)}|u_{D(e)})|\theta_{j(e),k(e)|D(e)}), +} +where \eqn{\boldsymbol{u}=(u_{1},...,u_{d})^\prime\in[0,1]^d}{u=(u_{1},...,u_{d})'\in[0,1]^d}. +Further \eqn{c_{j(e),k(e)|D(e)}} denotes a bivariate copula density associated to an edge \eqn{e} and with parameter(s) \eqn{\boldsymbol{\theta}_{j(e),k(e)|D(e)}}{\theta_{j(e),k(e)|D(e)}}. +Conditional distribution functions such as \eqn{F(u_{j(e)}|\boldsymbol{u}_{D(e)})}{F(u_{j(e)}|u_{D(e)})} are obtained recursively using the relationship +\deqn{ +h(u|\boldsymbol{v},\boldsymbol{\theta}) := F(u|\boldsymbol{v}) = +\frac{\partial C_{uv_j|\boldsymbol{v}_{-j}}(F(u|\boldsymbol{v}_{-j}),F(v_j|\boldsymbol{v}_{-j}))}{\partial F(v_j|\boldsymbol{v}_{-j})}, +}{ +h(u|v,\theta) := F(u|v) = +d C_{uv_j|v_{-j}}(F(u|v_{-j}),F(v_j|v_{-j}))/d F(v_j|v_{-j}), +} +where \eqn{C_{uv_j|\boldsymbol{v}_{-j}}}{C_{uv_j|v_{-j}}} is a bivariate copula distribution function with parameter(s) \eqn{\boldsymbol{\theta}}{\theta} +and \eqn{\boldsymbol{v}_{-j}}{v_{-j}} denotes a vector with the \eqn{j}-th component \eqn{v_j} removed. +The notation of h-functions is introduced for convenience. For more details see Dissmann et al. (2013). + +The function is actually just a wrapper to \code{\link{RVineLogLik}}. +} + +\references{ +Dissmann, J. F., E. C. Brechmann, C. Czado, and D. Kurowicka (2013). +Selecting and estimating regular vine copulae and application to financial returns. +Computational Statistics & Data Analysis, 59 (1), 52-69. +} + +\author{Thomas Nagler} + +\seealso{\code{\link{BiCopHfunc}}, \code{\link{RVineMatrix}}, \code{\link{RVineMLE}}, \code{\link{RVineAIC}}, \code{\link{RVineBIC}}} + +\examples{ +# define 5-dimensional R-vine tree structure 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) +Matrix <- matrix(Matrix, 5, 5) + +# define R-vine pair-copula family matrix +family <- c(0, 1, 3, 4, 4, + 0, 0, 3, 4, 1, + 0, 0, 0, 4, 1, + 0, 0, 0, 0, 3, + 0, 0, 0, 0, 0) +family <- matrix(family, 5, 5) + +# define R-vine pair-copula parameter matrix +par <- c(0, 0.2, 0.9, 1.5, 3.9, + 0, 0, 1.1, 1.6, 0.9, + 0, 0, 0, 1.9, 0.5, + 0, 0, 0, 0, 4.8, + 0, 0, 0, 0, 0) +par <- matrix(par, 5, 5) + +# define second R-vine pair-copula parameter matrix +par2 <- matrix(0, 5, 5) + +# define RVineMatrix object +RVM <- RVineMatrix(Matrix = Matrix, family = family, + par = par, par2 = par2, + names = c("V1", "V2", "V3", "V4", "V5")) + +# compute the density at (0.1, 0.2, 0.3, 0.4, 0.5) +RVinePDF(c(0.1, 0.2, 0.3, 0.4, 0.5), RVM) +} Modified: pkg/man/RVineStructureSelect.Rd =================================================================== --- pkg/man/RVineStructureSelect.Rd 2015-02-20 13:51:01 UTC (rev 82) +++ pkg/man/RVineStructureSelect.Rd 2015-02-24 12:00:28 UTC (rev 83) @@ -9,10 +9,9 @@ } \usage{ -RVineStructureSelect(data, familyset = NA, type = 0, - selectioncrit = "AIC", indeptest = FALSE, - level = 0.05, trunclevel = NA, - progress = FALSE, weights = NA) +RVineStructureSelect(data, familyset = NA, type = 0, selectioncrit = "AIC", + indeptest = FALSE, level = 0.05, trunclevel = NA, + progress = FALSE, weights = NA, rotations = TRUE) } \arguments{ @@ -74,6 +73,7 @@ \item{trunclevel}{Integer; level of truncation.} \item{progress}{Logical; whether the tree-wise specification progress is printed (default: \code{progress = FALSE}).} \item{weights}{Numerical; weights for each observation (opitional).} + \item{rotations}{If \code{TRUE}, all rotations of the families in \code{familyset} are included.} } \details{