From noreply at r-forge.r-project.org Mon Apr 6 12:09:15 2015 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Mon, 6 Apr 2015 12:09:15 +0200 (CEST) Subject: [Vinecopula-commits] r93 - pkg/src Message-ID: <20150406100915.AECD2183C66@r-forge.r-project.org> Author: ulf Date: 2015-04-06 12:09:15 +0200 (Mon, 06 Apr 2015) New Revision: 93 Modified: pkg/src/incompleteBeta.c pkg/src/logderiv.c pkg/src/pit.c pkg/src/rvinederiv.c Log: Some more comments of my C-code Modified: pkg/src/incompleteBeta.c =================================================================== --- pkg/src/incompleteBeta.c 2015-03-31 12:15:11 UTC (rev 92) +++ pkg/src/incompleteBeta.c 2015-04-06 10:09:15 UTC (rev 93) @@ -1,6 +1,15 @@ // Implementierung der incomplete beta Funktion und ihrer Ableitungen nach p +// The incomplete beta function is needed for the derivative of the Student's t-copula +// Also Its derivative with respect to the parameter p is needed +// For reference see: Boik and Robinson-Cox (1998). + +// Boik, R. J. and J. F. Robinson-Cox (1998). +// Derivatives of the incomplete beta function. +// Journal of Statistical Software 3(1). +// The implementation follows directly their algorithm and is closely related to their published code + #include "include/vine.h" #include "include/incompleteBeta.h" Modified: pkg/src/logderiv.c =================================================================== --- pkg/src/logderiv.c 2015-03-31 12:15:11 UTC (rev 92) +++ pkg/src/logderiv.c 2015-04-06 10:09:15 UTC (rev 93) @@ -7,10 +7,32 @@ #include "include/incompleteBeta.h" #include "include/logderiv.h" +////////////////////////////////// +// we calculated the derivatives of the copula density in deriv.c and deriv2.c +// Further, the derivatives of the Student's t-copula were derived in separate files due to their complexity +// here some derivatives of log(c) are calculated, since sometime it is numerical advantageous to use the log(c) instead of c, +// in particular for the t-copula. +// +// In most cases the calculation is almost the same as for the derivatives of c +////////////////////////////////// + // Ableitung von log(c) nach rho +///////////////////////////////////////// +// Derivative of log(c) wrt to the first parameter rho of the Student's t-copula +// +// Input: +// u, v copula arguments (vectors) +// n length of u and v +// param two-dimensional parameter vector +// copula copula family (not needed here) +// +// Output: +// out derivative +/////////////////////////////////////////// + void difflPDF_rho_tCopula(double* u, double* v, int* n, double* param, int* copula, double* out) { int j; Modified: pkg/src/pit.c =================================================================== --- pkg/src/pit.c 2015-03-31 12:15:11 UTC (rev 92) +++ pkg/src/pit.c 2015-04-06 10:09:15 UTC (rev 93) @@ -17,15 +17,17 @@ #define XEPS 1e-4 ////////////////////////////////////////////////////////////// -// Function to transform a pair-copula construction (vine) +// Probability integral transform for the C- and 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 // par parameter values (at least d*(d-1)/2 parameters) //////////////////////////////////////////////////////////////// +// The algorithm is based on the pseudo algorithm of Aas et al. (2009) + void pit(int* T, int* d, int* family, int* type, double* par, double* nu, double* data, double* out) { int i, j, in=1, k, **fam, tt; @@ -128,6 +130,27 @@ +////////////////////////////////////////////////////////////// +// Probability integral transform for the R-vine +// +// Input: +// T, d dimensions of the data +// family,... RVM objects +// data data +// vv, vv2 h-functions derived bei the likelihood function +// calcupdate which h-functions, inverse h-functions have to be derived +// +// Output: +// out PIT +////////////////////////////////////////////////////////////// + +// Reference: Schepsmeier (2015) + +// Ulf Schepsmeier, Efficient information based goodness-of-fit tests for vine copula models with fixed margins: A comprehensive review, +// Journal of Multivariate Analysis, Available online 14 January 2015, ISSN 0047-259X, http://dx.doi.org/10.1016/j.jmva.2015.01.001. +// (http://www.sciencedirect.com/science/article/pii/S0047259X15000068) + + void RvinePIT(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) { @@ -154,6 +177,7 @@ } } + // From vector to array k=0; for(i=0;i<(*d);i++) { @@ -178,6 +202,7 @@ } } + // First column is easy; it's the data for(t=0;t<*T;t++) { z[0][t]=x[0][t]; Modified: pkg/src/rvinederiv.c =================================================================== --- pkg/src/rvinederiv.c 2015-03-31 12:15:11 UTC (rev 92) +++ pkg/src/rvinederiv.c 2015-04-06 10:09:15 UTC (rev 93) @@ -11,27 +11,38 @@ // Code from Jakob Stoeber and Ulf Schepsmeier for R-vine log-likelihood derivative calculation ////////////////////////////////////////////////////////////// -// Function to compute the derivative of log-likelihood for the pair-copula construction (Rvine) +// Function to compute the derivative of log-likelihood for the pair-copula construction (Rvine) (one-element of the gradient) // (by J.S.) // Input: -// T sample size -// d dimension (>=2) -// family copula families: only student // (1=gaussian, 2=student, 3=clayton, 4=gumbel, 5=frank, 6=joe) -// kk row number of the parameter wrt to which we want to calculate the derivative -// ii column number of the parameter wrt to which we want to calculate the derivative -// par parameter values (at least d*(d-1)/2 parameters -// par2 second set of parameter values (f.e. for student copulas) -// data data set for which to compute the derivative of the log-likelihood -// matrix an RVineMatrix in vector form -// condirect, conindirect Matrizes which tell us where we find the right values -// calcupdate matrix which tells which terns we need to consider for the calculation of the derivative +// T sample size +// d dimension (>=2) +// family copula families: only student // (1=gaussian, 2=student, 3=clayton, 4=gumbel, 5=frank, 6=joe) +// kk row number of the parameter wrt to which we want to calculate the derivative +// ii column number of the parameter wrt to which we want to calculate the derivative +// par parameter values (at least d*(d-1)/2 parameters +// par2 second set of parameter values (f.e. for student copulas) +// data data set for which to compute the derivative of the log-likelihood +// matrix an RVineMatrix in vector form +// condirect, conindirect Matrices which tell us where we find the right values +// calcupdate matrix which tells which terns we need to consider for the calculation of the derivative +// ll array with the contribution to the derivative (for each copula) +// vv,vv2 array of the h-functions (given as by-product of the log-likelihood calculation) +// tcop a special marker for the Student's t-copula (1=first parameter, 2=second parameter) +// margin derivative wrt to the margins as well? (TRUE/FALSE) (needed by Jakob for some of his calculations) +// // Output: -// out Loglikelihood -// ll array with the contribution to the derivative (for each copula) -// vv,vv2 array for the derivatives of the h-functions +// out Log-likelihood derivative +// tilde_value array of separated derivatives in the R-vine construction +// tilde_vdirect array of separated derivatives of the h-functions needed +// tilde_vindirect array of separated derivatives of the h-functions needed ///////////////////////////////////////////////////////////// +// Reference: +// Stöber, J. and U. Schepsmeier (2013) +// Estimating standard errors in regular vine copula models +// Computational Statistics, 28 (6), 2679-2707 + void VineLogLikRvineDeriv(int* T, int* d, int* family, int* kk, int* ii, int* maxmat, int* matrix, int* condirect, int* conindirect, double* par, double* par2, double* data, double* out, double* ll, double* vv, double* vv2, int* calcupdate, double* tilde_vdirect, double* tilde_vindirect, double* tilde_value, int* tcop, int* margin) { @@ -158,7 +169,7 @@ param[0]=theta[*kk-1][*ii-1]; param[1]=nu[*kk-1][*ii-1]; - if(*tcop==1) //Für die t-copula + if(*tcop==1) //For the t-copula (first parameter) { diffhfunc_rho_tCopula(zr1,zr2,T,param,&fam[*kk-1][*ii-1],tildevdirect[*kk-2][*ii-1]); diffhfunc_rho_tCopula(zr2,zr1,T,param,&fam[*kk-1][*ii-1],tildevindirect[*kk-2][*ii-1]); @@ -168,7 +179,7 @@ tildevalue[*kk-1][*ii-1][t]=tildevalue[*kk-1][*ii-1][t]/cop[t]; } } - else if(*tcop==2) + else if(*tcop==2) // for the t-copula (second parameter) { diffhfunc_nu_tCopula_new(zr1,zr2,T,param,&fam[*kk-1][*ii-1],tildevdirect[*kk-2][*ii-1]); diffhfunc_nu_tCopula_new(zr2,zr1,T,param,&fam[*kk-1][*ii-1],tildevindirect[*kk-2][*ii-1]); @@ -216,6 +227,7 @@ //Rprintf("%f \n",tildevalue[*kk-1][*ii-1][1]); + // add up for the final derivative for(t=0;t<*T;t++ ) { sumloglik+=tildevalue[*kk-1][*ii-1][t]; @@ -267,7 +279,7 @@ { param[0]=theta[k][i]; param[1]=nu[k][i]; - if(fam[k][i]==2) //Für die t-copula + if(fam[k][i]==2) //For the t-copula { diffPDF_u_tCopula_new(zr1,zr2,T,param,&fam[k][i],handle1); } @@ -293,7 +305,7 @@ { param[0]=theta[k][i]; param[1]=nu[k][i]; - if(fam[k][i]==2) //Für die t-copula + if(fam[k][i]==2) //For the t-copula { diffhfunc_v_tCopula_new(zr2,zr1,T,param,&fam[k][i],handle1); } @@ -312,7 +324,7 @@ { param[0]=theta[k][i]; param[1]=nu[k][i]; - if(fam[k][i]==2) //Für die t-copula + if(fam[k][i]==2) //For the t-copula { diffPDF_u_tCopula_new(zr2,zr1,T,param,&fam[k][i],handle1); } @@ -330,7 +342,7 @@ { param[0]=theta[k][i]; param[1]=nu[k][i]; - if(fam[k][i]==2) //Für die t-copula + if(fam[k][i]==2) //For the t-copula { diffhfunc_v_tCopula_new(zr1,zr2,T,param,&fam[k][i],handle1); } @@ -398,7 +410,18 @@ } +///////////////////////////////////////////////// +// Calculate the gradient +// (uses the function VineLogLikRvineDeriv) +// +// Input: +// see above +// +// Output: +// out gradient vector +/////////////////////////////////////////////////// + void VineLogLikRvineGradient(int* T, int* d, int* family, int* maxmat, int* matrix, int* condirect, int* conindirect, double* par, double* par2, double* data, double* out, double* ll, double* vv, double* vv2, int* posParams) //double* tilde_vdirect_array, double* tilde_vindirect_array, double* tilde_value_array) @@ -448,12 +471,12 @@ // tilde_value[t] = tilde_value_array[(*d)*(*d)*(*d)*(*T)*(ii-1)+(*d)*(*d)*(*T)*(kk-1)+t]; //} //Rprintf("\n"); - if(fam[kk-1][ii-1]==2) + if(fam[kk-1][ii-1]==2) // for the t-copula { - tcop=1; + tcop=1; // first parameter VineLogLikRvineDeriv(T, d, family, &kk, &ii, maxmat, matrix, condirect, conindirect, par, par2, data, &out[tt], ll, vv, vv2, calc, tilde_vdirect, tilde_vindirect, tilde_value, &tcop, &margin); - tcop=2; - VineLogLikRvineDeriv(T, d, family, &kk, &ii, maxmat, matrix, condirect, conindirect, par, par2, data, &out[aa-1+dd], ll, vv, vv2, calc, tilde_vdirect, tilde_vindirect, tilde_value, &tcop, &margin); + tcop=2; // second parameter + VineLogLikRvineDeriv(T, d, family, &kk, &ii, maxmat, matrix, condirect, conindirect, par, par2, data, &out[aa-1+dd], ll, vv, vv2, calc, tilde_vdirect, tilde_vindirect, tilde_value, &tcop, &margin); // important: position in the gradient out[aa-1+dd] dd++; } else From noreply at r-forge.r-project.org Mon Apr 13 14:28:01 2015 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Mon, 13 Apr 2015 14:28:01 +0200 (CEST) Subject: [Vinecopula-commits] r94 - pkg/R Message-ID: <20150413122801.CBCFF187003@r-forge.r-project.org> Author: tnagler Date: 2015-04-13 14:28:01 +0200 (Mon, 13 Apr 2015) New Revision: 94 Modified: pkg/R/BiCopEst.r Log: increase lower bound of likelihood to -10^250 for all families (fixes optim errors in MLE) Modified: pkg/R/BiCopEst.r =================================================================== --- pkg/R/BiCopEst.r 2015-04-06 10:09:15 UTC (rev 93) +++ pkg/R/BiCopEst.r 2015-04-13 12:28:01 UTC (rev 94) @@ -1,989 +1,989 @@ -BiCopEst <- function(u1, u2, family, method = "mle", se = FALSE, max.df = 30, max.BB = list(BB1 = c(5, 6), BB6 = c(6, 6), BB7 = c(5, 6), BB8 = c(6, 1)), - weights = NA) { - # Function that estimates the parameter(s) of the bivatiate copula - #--------------------------------------------------------- - # INPUT: - # u1,u2 Data for which to estimate parameter - # family The array definig the copulas in the pcc copula construction - # OUTPUT: - # theta Estimated Parameters - #---------------------------------------------------------- - # Author: Carlos Almeida - # Update: Ulf Schepsmeier - # Date: 2008-12-08 - # Update date: 2011-05-27 - # Version: 1.1 - #--------------------------------------------------------------- - - # 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)) - stop("Lengths of 'u1' and 'u2' do not match.") - if (length(u1) < 2) - stop("Number of observations has to be at least 2.") - 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 (!(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 (max.df <= 2) - stop("The upper bound for the degrees of freedom parameter has to be larger than 2.") - if (!is.list(max.BB)) - stop("'max.BB' has to be a list.") - if (max.BB$BB1[1] < 0.001) - stop("The upper bound for the first parameter of the BB1 copula should be greater than 0.001 (lower bound for estimation).") - if (max.BB$BB1[2] < 1.001) - stop("The upper bound for the second parameter of the BB1 copula should be greater than 1.001 (lower bound for estimation).") - if (max.BB$BB6[1] < 1.001) - stop("The upper bound for the first parameter of the BB6 copula should be greater than 1.001 (lower bound for estimation).") - if (max.BB$BB6[2] < 1.001) - stop("The upper bound for the second parameter of the BB6 copula should be greater than 1.001 (lower bound for estimation).") - if (max.BB$BB7[1] < 1.001) - stop("The upper bound for the first parameter of the BB7 copula should be greater than 1.001 (lower bound for estimation).") - if (max.BB$BB7[2] < 0.001) - stop("The upper bound for the second parameter of the BB7 copula should be greater than 0.001 (lower bound for estimation).") - if (max.BB$BB8[1] < 1.001) - stop("The upper bound for the first parameter of the BB1 copula should be greater than 0.001 (lower bound for estimation).") - if (max.BB$BB8[2] < 0.001 || max.BB$BB8[2] > 1) - stop("The upper bound for the second parameter of the BB1 copula should be in the interval [0,1].") - - if (method != "mle" && method != "itau") - stop("Estimation method has to be either 'mle' or 'itau'.") - if (method == "itau" && 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)) { - message("For two parameter copulas the estimation method 'itau' cannot be used. The method is automatically set to 'mle'.") - method <- "mle" - } - if (is.logical(se) == FALSE) - stop("'se' has to be a logical variable (TRUE or FALSE).") - - - ## calculate empirical kendall's tau - if (family != 0) { - # tau <- cor(u1,u2,method='kendall') - tau <- fasttau(u1, u2) - } - - ## inversion of kendall's tau - theta <- 0 - if (family == 0) { - # independent - theta <- 0 - } else if (family == 1) { - ## Gaussian - theta <- sin(tau * pi/2) - } else if (family == 3 || family == 13) { - ## Clayton - if (tau <= 0) { - warning("Clayton copula cannot be used for negatively dependent data.") - tau <- 0.05 - } - theta <- max(0, 2 * tau/(1 - tau)) - } else if (family == 4 || family == 14) { - ## Gumbel - if (tau < 0) { - warning("Gumbel copula cannot be used for negatively dependent data.") - tau <- 0.05 - } - theta <- max(1, 1/(1 - tau)) - } else if (family == 5) { - ## Frank - theta <- Frank.itau.JJ(tau) - } else if (family == 6 || family == 16) { - ## Joe - if (tau <= 0) { - warning("Joe copula cannot be used for negatively dependent data.") - tau <- 0.05 - } - theta <- Joe.itau.JJ(tau) - } else if (family == 23 || family == 33) { - if (tau >= 0) { - warning("Rotated Clayton copula cannot be used for positively dependent data.") - tau <- -0.05 - } - theta <- (2 * tau/(1 + tau)) - } else if (family == 24 || family == 34) { - if (tau > 0) { - warning("Rotated Gumbel copula cannot be used for positively dependent data.") - tau <- -0.05 - } - theta <- -(1/(1 + tau)) - } else if (family == 26 || family == 36) { - if (tau >= 0) { - warning("Rotated Joe copula cannot be used for positively dependent data.") - tau <- -0.05 - } - theta <- -Joe.itau.JJ(-tau) - } else if (family %in% c(41, 51)) { - theta <- ipsA.tau2cpar(tau) - } else if (family %in% c(61, 71)) { - theta <- -ipsA.tau2cpar(-tau) - } - - ## standard errors for method itau - se1 <- 0 - if (method == "itau" && se == TRUE) { - p <- 2 - n <- length(u1) - ec <- numeric(n) - u <- cbind(u1, u2) - v <- matrix(0, n, p * (p - 1)/2) - - if (family == 1) - tauder <- function(x) 2/(pi * sqrt(1 - x^2)) else if (family %in% c(3, 13, 23, 33)) - tauder <- function(x) 2 * (2 + x)^(-2) else if (family %in% c(4, 14, 24, 34)) - tauder <- function(x) x^(-2) else if (family == 5) { - tauder <- function(x) { - f <- function(x) x/(exp(x) - 1) - 4/x^2 - 8/x^3 * integrate(f, lower = 0 + .Machine$double.eps^0.5, upper = x)$value + 4/(x * (exp(x) - 1)) - } - } else if (family %in% c(6, 16, 26, 36)) { - tauder <- function(x) { - euler <- 0.577215664901533 - -((-2 + 2 * euler + 2 * log(2) + digamma(1/x) + digamma(1/2 * (2 + x)/x) + x)/(-2 + x)^2) + ((-trigamma(1/x)/x^2 + trigamma(1/2 * (2 + - x)/x) * (1/(2 + x) - (2 + x)/(2 * x^2)) + 1)/(-2 + x)) - } - } else if (family %in% c(41, 51, 61, 71)) { - tauder <- function(x) { - 2 * sqrt(pi) * gamma(0.5 + x) * (digamma(1 + x) - digamma(0.5 + x))/gamma(1 + x) - } - } - - l <- 1 - for (j in 1:(p - 1)) { - for (i in (j + 1):p) { - for (k in 1:n) ec[k] <- sum(u[, i] <= u[k, i] & u[, j] <= u[k, j])/n - v[, l] <- 2 * ec - u[, i] - u[, j] - l <- l + 1 - } - } - - if (family == 0) - D <- 0 else if (family %in% c(1, 3, 4, 5, 6, 13, 14, 16, 41, 51)) - D <- 1/tauder(theta) else if (family %in% c(23, 33, 24, 34, 26, 36, 61, 71)) - D <- 1/tauder(-theta) - - - se1 <- as.numeric(sqrt(16/n * var(v %*% D))) - } - - ## set starting parameters for maximum likelihood estimation - if (method == "mle") { - theta1 <- 0 - delta <- 0 - - if (!(family %in% c(2, 6, 7, 8, 9, 10, 17, 18, 19, 20, 27, 28, 29, 30, 37, 38, 39, 40, 104, 114, 124, 134, 204, 214, 224, 234))) { - theta1 <- theta - } - if (family == 2) { - ## t - theta1 <- sin(tau * pi/2) - delta1 <- min(10, (max.df + 2)/2) # Take the middle between 2 and max.df - delta <- MLE_intern(cbind(u1, u2), - c(theta1, delta1), - family = family, - se = FALSE, - max.df, - max.BB, - cor.fixed = TRUE, - weights)$par[2] - } else if (family == 7 || family == 17) { - ## BB1 - if (tau < 0) { - print("The BB1 or survival BB1 copula cannot be used for negatively dependent data.") - delta <- 1.001 - theta1 <- 0.001 - } else { - delta <- min(1.5, max((max.BB$BB1[2] + 1.001)/2, 1.001)) - theta1 <- min(0.5, max((max.BB$BB1[1] + 0.001)/2, 0.001)) - } - } else if (family == 27 || family == 37) { - ## BB1 - if (tau > 0) { - print("The rotated BB1 copulas cannot be used for positively dependent data.") - delta <- -1.001 - theta1 <- -0.001 - } else { - delta <- max(-1.5, -max((max.BB$BB1[2] + 1.001)/2, 1.001)) - theta1 <- max(-0.5, -max((max.BB$BB1[1] + 0.001)/2, 0.001)) - } - } else if (family == 8 || family == 18) { - ## BB6 - if (tau < 0) { - print("The BB6 or survival BB6 copula cannot be used for negatively dependent data.") - delta <- 1.001 - theta1 <- 1.001 - } else { - delta <- min(1.5, max((max.BB$BB6[2] + 1.001)/2, 1.001)) - theta1 <- min(1.5, max((max.BB$BB6[1] + 1.001)/2, 1.001)) - } - } else if (family == 28 || family == 38) { - ## BB6 - if (tau > 0) { - print("The rotated BB6 copulas cannot be used for positively dependent data.") - delta <- -1.001 - theta1 <- -1.001 - } else { - delta <- max(-1.5, -max((max.BB$BB6[2] + 1.001)/2, 1.001)) - theta1 <- max(-1.5, -max((max.BB$BB6[1] + 1.001)/2, 1.001)) - } - } else if (family == 9 || family == 19) { - ## BB7 - if (tau < 0) { - print("The BB7 or survival BB7 copula cannot be used for negatively dependent data.") - delta <- 0.001 - theta <- 1.001 - } else { - delta <- min(0.5, max((max.BB$BB7[2] + 0.001)/2, 0.001)) - theta1 <- min(1.5, max((max.BB$BB7[1] + 1.001)/2, 1.001)) - } - } else if (family == 29 || family == 39) { - ## BB7 - if (tau > 0) { - print("The rotated BB7 copulas cannot be used for positively dependent data.") - delta <- -0.001 - theta1 <- -1.001 - } else { - delta <- max(-0.5, -max((max.BB$BB7[2] + 0.001)/2, 0.001)) - theta1 <- max(-1.5, -max((max.BB$BB7[1] + 1.001)/2, 1.001)) - } - } else if (family == 10 || family == 20) { - ## BB8 - if (tau < 0) { - print("The BB8 or survival BB8 copula cannot be used for negatively dependent data.") - delta <- 0.001 - theta <- 1.001 - } else { - delta <- min(0.5, max((max.BB$BB8[2] + 0.001)/2, 0.001)) - theta1 <- min(1.5, max((max.BB$BB8[1] + 1.001)/2, 1.001)) - } - } else if (family == 30 || family == 40) { - ## BB8 - if (tau > 0) { - print("The rotated BB8 copulas cannot be used for positively dependent data.") - delta <- -0.001 - theta1 <- -1.001 - } else { - delta <- max(-0.5, -max((max.BB$BB8[2] + 0.001)/2, 0.001)) - theta1 <- max(-1.5, -max((max.BB$BB8[1] + 1.001)/2, 1.001)) - } - } else if (family %in% c(104, 114, 124, 134, 204, 214, 224, 234)) { - ## Tawn - - # the folllowing gives a theoretical kendall's tau close to the empirical one - delta <- min(abs(tau) + 0.1, 0.999) - theta1 <- 1 + 6 * abs(tau) - - # check if data can be modeled by selected family - if (family %in% c(104, 114)) { - if (tau < 0) { - print("The Tawn or survival Tawn copula cannot be used for negatively dependent data.") - delta <- 1 - theta1 <- 1.001 - } - } else if (family %in% c(124, 134)) { - if (tau > 0) { - print("The rotated Tawn copula cannot be used for positively dependent data.") - delta <- 1 - theta1 <- -1.001 - } else theta1 <- -theta1 - - } else if (family %in% c(204, 214)) { - if (tau < 0) { - print("The Tawn2 or survival Tawn2 copula cannot be used for negatively dependent data.") - delta <- 1 - theta1 <- 1.001 - } - } else if (family %in% c(224, 234)) { - if (tau > 0) { - print("The rotated Tawn2 copula cannot be used for positively dependent data.") - delta <- 1 - theta1 <- -1.001 - } else theta1 <- -theta1 - } - } - - ## likelihood optimization - if (family != 0 && family < 100) { - out <- MLE_intern(cbind(u1, u2), - c(theta1, delta), - family = family, - se, - max.df, - max.BB - , weights) - theta <- out$par - if (se == TRUE) - se1 <- out$se - } else if (family != 0 && family > 100) { - # New - out <- MLE_intern_Tawn(cbind(u1, u2), - c(theta1, delta), - family = family, - se) - theta <- out$par - if (se == TRUE) - se1 <- out$se - } - } - - ## store estimated parameters - out2 <- list(family = family) - if (length(theta) == 2) { - out2$par <- theta[1] - out2$par2 <- theta[2] - } else { - out2$par <- theta - out2$par2 <- 0 - } - - ## store standard errors (if asked for) - if (se == TRUE) { - if (length(se1) == 2) { - out2$se <- se1[1] - out2$se2 <- se1[2] - } else { - out2$se <- se1 - out2$se2 <- 0 - } - } - - ## return results - class(out2) <- "BiCop" - out2 -} - - - -Frank.itau.JJ <- function(tau) { - a <- 1 - if (tau < 0) { - a <- -1 - tau <- -tau - } - f <- function(x) { - x/(exp(x) - 1) - } - tauF <- function(x) 1 - 4/x + 4/x^2 * integrate(f, - lower = 0 + .Machine$double.eps^0.5, - upper = x)$value - v <- uniroot(function(x) tau - tauF(x), - lower = 0, - upper = 500, - tol = .Machine$double.eps^0.5)$root - return(a * v) -} - - - -Joe.itau.JJ <- function(tau) { - if (tau < 0) { - return(1.000001) - } else { - tauF <- function(a) { - # euler=0.5772156649015328606 1+((-2+2*euler+2*log(2)+digamma(1/a)+digamma(1/2*(2+a)/a)+a)/(-2+a)) - 1 + 4/a^2 * integrate(function(x) log(x) * x * (1 - x)^(2 * (1 - a)/a), 0, 1)$value - } - - v <- uniroot(function(x) tau - tauF(x), - lower = 1, - upper = 500, - tol = .Machine$double.eps^0.5)$root - return(v) - } -} - -ipsA.tau2cpar <- function(tau, mxiter = 20, eps = 1e-06, dstart = 0, iprint = FALSE) { - con <- log((1 - tau) * sqrt(pi)/2) - de <- dstart - if (dstart <= 0) - de <- tau + 1 - iter <- 0 - diff <- 1 - while (iter < mxiter & max(abs(diff)) > eps) { - g <- con + lgamma(1 + de) - lgamma(de + 0.5) - gp <- digamma(1 + de) - digamma(de + 0.5) - iter <- iter + 1 - diff <- g/gp - de <- de - diff - while (min(de) <= 0) { - diff <- diff/2 - de <- de + diff - } - if (iprint) - cat(iter, " ", de, " ", diff, "\n") - } - if (iter >= mxiter) - cat("did not converge\n") - de -} - - -############################################################# -# bivariate MLE function -# -#------------------------------------------------------------ -# INPUT: -# data Data for which to estimate parameter -# start.parm Start parameter for the MLE -# Maxiter max number of iterations -# se TRUE or FALSE -# OUTPUT: -# out Estimated Parameters and standard error (if se==TRUE) -#-------------------------------------------------------------- -# Author: Ulf Schepsmeier -# Date: 2011-02-04 -# Version: 1.1 -#--------------------------------------------------------------- - -MLE_intern <- function(data, start.parm, family, se = FALSE, max.df = 30, - max.BB = list(BB1 = c(5, 6), BB6 = c(6, 6), BB7 = c(5, 6), BB8 = c(6, 1)), - weights = NULL, cor.fixed = FALSE) { - - n <- dim(data)[1] - if (any(is.na(weights))) - weights <- NULL - - if (family %in% c(7, 8, 9, 10, 17, 18, 19, 20, 27, 28, 29, 30, 37, 38, 39, 40)) { - t_LL <- function(param) { - - if (is.null(weights)) { - ll <- .C("LL_mod2", - as.integer(family), - as.integer(n), - as.double(data[, 1]), - as.double(data[, 2]), - as.double(param[1]), - as.double(param[2]), - as.double(0), - PACKAGE = "VineCopula")[[7]] - } else { - ll <- .C("LL_mod_seperate", - as.integer(family), - as.integer(n), - as.double(data[, 1]), - as.double(data[, 2]), - as.double(param[1]), - as.double(param[2]), - as.double(rep(0, n)), - PACKAGE = "VineCopula")[[7]] %*% weights - } - - if (is.infinite(ll) || is.na(ll) || ll < -10^250) - ll <- -10^250 - - return(ll) - } - - if (family == 7 || family == 17) { - low <- c(0.001, 1.001) - up <- max.BB$BB1 - } else if (family == 8 || family == 18) { - low <- c(1.001, 1.001) - up <- max.BB$BB6 - } else if (family == 9 | family == 19) { - low <- c(1.001, 0.001) - up <- max.BB$BB7 - } else if (family == 10 | family == 20) { - low <- c(1.001, 0.001) - up <- max.BB$BB8 - } else if (family == 27 | family == 37) { - up <- c(-0.001, -1.001) - low <- -max.BB$BB1 - } else if (family == 28 | family == 38) { - up <- c(-1.001, -1.001) - low <- -max.BB$BB6 - } else if (family == 29 | family == 39) { - up <- c(-1.001, -0.001) - low <- -max.BB$BB7 - } else if (family == 30 | family == 40) { - up <- c(-1.001, -0.001) - low <- -max.BB$BB8 - } - - if (se == TRUE) { - optimout <- optim(par = start.parm, - fn = t_LL, - method = "L-BFGS-B", - lower = low, - upper = up, - control = list(fnscale = -1, maxit = 500), - hessian = TRUE) - } else { - optimout <- optim(par = start.parm, - fn = t_LL, - method = "L-BFGS-B", - lower = low, - upper = up, - control = list(fnscale = -1, maxit = 500)) - } - - } else if (family == 2) { - - if (cor.fixed == FALSE) { - - t_LL <- function(param) { - if (param[1] < -0.9999 | param[1] > 0.9999 | param[2] < 2.0001 | param[2] > max.df) { - ll <- -10^10 - } else { - if (is.null(weights)) { - ll <- .C("LL_mod2", - as.integer(family), - as.integer(n), - as.double(data[, 1]), - as.double(data[, 2]), - as.double(param[1]), - as.double(param[2]), - as.double(0), - PACKAGE = "VineCopula")[[7]] - } else { - ll <- .C("LL_mod_seperate", - as.integer(family), - as.integer(n), - as.double(data[, 1]), - as.double(data[, 2]), - as.double(param[1]), - as.double(param[2]), - as.double(rep(0, n)), - PACKAGE = "VineCopula")[[7]] %*% weights - } - - if (is.infinite(ll) || is.na(ll) || ll < -10^10) - ll <- -10^10 - } - return(ll) - } - - gr_LL <- function(param) { - gr <- rep(0, 2) - gr[1] <- sum(BiCopDeriv(data[, 1], - data[, 2], - family = 2, - par = param[1], - par2 = param[2], - deriv = "par", - log = TRUE)) - gr[2] <- sum(BiCopDeriv(data[, 1], - data[, 2], - family = 2, - par = param[1], - par2 = param[2], - deriv = "par2", - log = TRUE)) - return(gr) - } - - if (is.null(weights)) { - if (se == TRUE) { - optimout <- optim(par = start.parm, - fn = t_LL, - gr = gr_LL, - method = "L-BFGS-B", - control = list(fnscale = -1, maxit = 500), - hessian = TRUE, - lower = c(-0.9999, 2.0001), - upper = c(0.9999, max.df)) - } else { - optimout <- optim(par = start.parm, - fn = t_LL, - gr = gr_LL, - method = "L-BFGS-B", - control = list(fnscale = -1, maxit = 500), - lower = c(-0.9999, 2.0001), - upper = c(0.9999, max.df)) - } - } else { - if (se == TRUE) { - optimout <- optim(par = start.parm, - fn = t_LL, - method = "L-BFGS-B", - control = list(fnscale = -1, maxit = 500), - hessian = TRUE, - lower = c(-0.9999, 2.0001), - upper = c(0.9999, max.df)) - } else { - optimout <- optim(par = start.parm, - fn = t_LL, - method = "L-BFGS-B", - control = list(fnscale = -1, maxit = 500), - lower = c(-0.9999, 2.0001), - upper = c(0.9999, max.df)) - } - } - - if (optimout$par[2] >= (max.df - 1e-04)) - warning(paste("Degrees of freedom of the t-copula estimated to be larger than ", - max.df, ". Consider using the Gaussian copula instead.", - sep = "")) - - } else { - t_LL <- function(param) { - if (is.null(weights)) { - ll <- .C("LL_mod2", - as.integer(family), - as.integer(n), - as.double(data[, 1]), - as.double(data[, 2]), - as.double(start.parm[1]), - as.double(param[1]), - as.double(0), - PACKAGE = "VineCopula")[[7]] - } else { - ll <- .C("LL_mod_seperate", - as.integer(family), - as.integer(n), - as.double(data[, 1]), - as.double(data[, 2]), - as.double(start.parm[1]), - as.double(param[1]), - as.double(rep(0, n)), - PACKAGE = "VineCopula")[[7]] %*% weights - } - - if (is.infinite(ll) || is.na(ll) || ll < -10^250) - ll <- -10^250 - - return(ll) - } - - gr_LL <- function(param) { - gr <- sum(BiCopDeriv(data[, 1], - data[, 2], - family = 2, - par = start.parm[1], - par2 = param[1], - deriv = "par2", - log = TRUE)) - return(gr) - } - - if (se == TRUE) { - if (is.null(weights)) { - optimout <- optim(par = start.parm[2], - fn = t_LL, - gr = gr_LL, - method = "L-BFGS-B", - control = list(fnscale = -1, maxit = 500), - hessian = TRUE, - lower = 2.0001, - upper = max.df) - } else { - optimout <- optim(par = start.parm[2], - fn = t_LL, - method = "L-BFGS-B", - control = list(fnscale = -1, maxit = 500), - hessian = TRUE, - lower = 2.0001, - upper = max.df) - } - } else { - optimout <- optimize(f = t_LL, - maximum = TRUE, - interval = c(2.0001, max.df)) - optimout$par <- optimout$maximum - } - optimout$par <- c(0, optimout$par) - - } - - } else { - - t_LL <- function(param) { - if (is.null(weights)) { - ll <- .C("LL_mod2", as.integer(family), - as.integer(n), - as.double(data[, 1]), - as.double(data[, 2]), - as.double(param), - as.double(0), as.double(0), - PACKAGE = "VineCopula")[[7]] - } else { - ll <- .C("LL_mod_seperate", - as.integer(family), - as.integer(n), - as.double(data[, 1]), - as.double(data[, 2]), - as.double(param[1]), - as.double(0), - as.double(rep(0, n)), - PACKAGE = "VineCopula")[[7]] %*% weights - } - if (is.infinite(ll) || is.na(ll) || ll < -10^250) - ll <- -10^250 - - return(ll) - } - - gr_LL <- function(param) { - gr <- sum(BiCopDeriv(data[, 1], - data[, 2], - family = family, - par = param, - deriv = "par", - log = TRUE)) - return(gr) - } - - low <- -Inf - up <- Inf - - if (family == 1) { - low <- -0.9999 - up <- 0.9999 - } else if (family %in% c(3, 13)) { - low <- 1e-04 - up <- BiCopTau2Par(family, 0.99) - if (t_LL(up) == -10^300) - up <- BiCopTau2Par(family, 0.95) - if (t_LL(up) == -10^300) - up <- BiCopTau2Par(family, 0.9) - } else if (family %in% c(4, 14)) { - low <- 1.0001 - up <- BiCopTau2Par(family, 0.99) - if (t_LL(up) == -10^300) - up <- BiCopTau2Par(family, 0.95) - if (t_LL(up) == -10^300) - up <- BiCopTau2Par(family, 0.9) - } else if (family %in% c(5)) { - low <- BiCopTau2Par(family, -0.99) - if (t_LL(low) == -10^300) - low <- BiCopTau2Par(family, -0.95) - if (t_LL(low) == -10^300) - low <- BiCopTau2Par(family, -0.9) - up <- BiCopTau2Par(family, 0.99) - if (t_LL(up) == -10^300) - up <- BiCopTau2Par(family, 0.95) - if (t_LL(up) == -10^300) - up <- BiCopTau2Par(family, 0.9) - } else if (family %in% c(6, 16)) { - low <- 1.0001 - up <- BiCopTau2Par(family, 0.99) - if (t_LL(up) == -10^300) - up <- BiCopTau2Par(family, 0.95) - if (t_LL(up) == -10^300) - up <- BiCopTau2Par(family, 0.9) - } else if (family %in% c(23, 33)) { - up <- -1e-04 - low <- BiCopTau2Par(family, -0.99) - if (t_LL(low) == -10^300) - low <- BiCopTau2Par(family, -0.95) - if (t_LL(low) == -10^300) - low <- BiCopTau2Par(family, -0.9) - } else if (family %in% c(24, 34)) { - up <- -1.0001 - low <- BiCopTau2Par(family, -0.99) - if (t_LL(low) == -10^300) - low <- BiCopTau2Par(family, -0.95) - if (t_LL(low) == -10^300) - low <- BiCopTau2Par(family, -0.9) - } else if (family %in% c(26, 36)) { - up <- -1.0001 - low <- BiCopTau2Par(family, -0.99) - if (t_LL(low) == -10^300) - low <- BiCopTau2Par(family, -0.95) - if (t_LL(low) == -10^300) - low <- BiCopTau2Par(family, -0.9) - } else if (family %in% c(41, 51)) { - low <- 1e-04 - up <- BiCopTau2Par(family, 0.85) - # if(t_LL(up)==-10^300) up=BiCopTau2Par(family,0.95) if(t_LL(up)==-10^300) up=BiCopTau2Par(family,0.9) - } else if (family %in% c(61, 71)) { - up <- -1e-04 [TRUNCATED] To get the complete diff run: svnlook diff /svnroot/vinecopula -r 94 From noreply at r-forge.r-project.org Fri Apr 17 19:02:12 2015 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Fri, 17 Apr 2015 19:02:12 +0200 (CEST) Subject: [Vinecopula-commits] r95 - pkg/R Message-ID: <20150417170212.7A5FD18787E@r-forge.r-project.org> Author: tnagler Date: 2015-04-17 19:02:11 +0200 (Fri, 17 Apr 2015) New Revision: 95 Modified: pkg/R/RVinePartialcorr.R Log: - RVinePcor2cor: bug fixes for d=2 and d>9 Modified: pkg/R/RVinePartialcorr.R =================================================================== --- pkg/R/RVinePartialcorr.R 2015-04-13 12:28:01 UTC (rev 94) +++ pkg/R/RVinePartialcorr.R 2015-04-17 17:02:11 UTC (rev 95) @@ -103,7 +103,7 @@ 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 + ## store variable names and set to V1:d 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 = "") @@ -122,10 +122,9 @@ ## if d=2 there is nothing to compute if (d <= 2) { iorder <- diag(RVM$Matrix) - corMat <- matrix(c(1, - pc[iorder[1], iorder[2]], - pc[iorder[1], iorder[2]], - 1)) + corMat <- matrix(c(1, pc[iorder[1], iorder[2]], + pc[iorder[1], iorder[2]], 1), + nrow = 2, ncol = 2) return(corMat) } @@ -170,14 +169,13 @@ ## revert matrix to appropriate order corMat <- corMat[rev(oldOrder), rev(oldOrder)] - nameOrder <- order(oldRVM$names) + nameOrder <- order(as.numeric(sub("V", "", oldRVM$names))) corMat <- corMat[nameOrder, nameOrder] - ## 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. + warning("Some RVM$names are not default (such as ''V5'') and their initial ordering cannot be checked. Make sure to interpret the correlation matrix as indicated by the row and column names.") rownames(corMat) <- colnames(corMat) <- oldNames } else { From noreply at r-forge.r-project.org Mon Apr 20 10:36:01 2015 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Mon, 20 Apr 2015 10:36:01 +0200 (CEST) Subject: [Vinecopula-commits] r96 - pkg/R Message-ID: <20150420083601.1A06518683E@r-forge.r-project.org> Author: tnagler Date: 2015-04-20 10:36:00 +0200 (Mon, 20 Apr 2015) New Revision: 96 Modified: pkg/R/RVinePartialcorr.R Log: - RVinePcor2cor: another bug fix for d = 2 Modified: pkg/R/RVinePartialcorr.R =================================================================== --- pkg/R/RVinePartialcorr.R 2015-04-17 17:02:11 UTC (rev 95) +++ pkg/R/RVinePartialcorr.R 2015-04-20 08:36:00 UTC (rev 96) @@ -98,6 +98,7 @@ RVinePcor2cor <- function(RVM) { d <- nrow(RVM$Matrix) ## sanity checks + stopifnot(d > 1) stopifnot(is(RVM, "RVineMatrix")) stopifnot(all(RVM$family %in% c(0, 1, 2))) if (is.null(RVM$names)) @@ -120,10 +121,8 @@ 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, pc[iorder[1], iorder[2]], - pc[iorder[1], iorder[2]], 1), + if (d == 2) { + corMat <- matrix(c(1, rep(RVM$par[2, 1], 2), 1), nrow = 2, ncol = 2) return(corMat) }