From noreply at r-forge.r-project.org Thu Sep 10 17:54:37 2015 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Thu, 10 Sep 2015 17:54:37 +0200 (CEST) Subject: [Vinecopula-commits] r130 - pkg/R Message-ID: <20150910155437.6D27F187B6D@r-forge.r-project.org> Author: tnagler Date: 2015-09-10 17:54:36 +0200 (Thu, 10 Sep 2015) New Revision: 130 Modified: pkg/R/BiCopPar2Tau.r Log: * set BiCopPar2Tau(5, 0, check.pars = FALSE) = 0 Modified: pkg/R/BiCopPar2Tau.r =================================================================== --- pkg/R/BiCopPar2Tau.r 2015-08-28 17:01:07 UTC (rev 129) +++ pkg/R/BiCopPar2Tau.r 2015-09-10 15:54:36 UTC (rev 130) @@ -58,7 +58,7 @@ } else if (family == 4 || family == 14) { tau <- 1 - 1/par } else if (family == 5) { - tau <- 1 - 4/par + 4/par * debye1(par) + tau <- if (par == 0) 0 else 1 - 4/par + 4/par * debye1(par) } else if (family == 6 || family == 16) { # tau = 1 + 4/par^2 * integrate(function(x) log(x)*x*(1-x)^(2*(1-par)/par), 0, # 1)$value From noreply at r-forge.r-project.org Thu Sep 10 17:55:41 2015 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Thu, 10 Sep 2015 17:55:41 +0200 (CEST) Subject: [Vinecopula-commits] r131 - pkg/man Message-ID: <20150910155541.858B7183E0A@r-forge.r-project.org> Author: tnagler Date: 2015-09-10 17:55:41 +0200 (Thu, 10 Sep 2015) New Revision: 131 Modified: pkg/man/plot.RVineMatrix.Rd Log: * correct advize for plot size in plot.RVineMatrix.Rd Modified: pkg/man/plot.RVineMatrix.Rd =================================================================== --- pkg/man/plot.RVineMatrix.Rd 2015-09-10 15:54:36 UTC (rev 130) +++ pkg/man/plot.RVineMatrix.Rd 2015-09-10 15:55:41 UTC (rev 131) @@ -45,7 +45,7 @@ \details{ -If you want the contour boxes to be perfect sqaures, the plot height should be \code{1.14/length(tree)*(d - min(tree))} times the plot width. +If you want the contour boxes to be perfect sqaures, the plot height should be \code{1.25/length(tree)*(d - min(tree))} times the plot width. } From noreply at r-forge.r-project.org Tue Sep 15 17:59:59 2015 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Tue, 15 Sep 2015 17:59:59 +0200 (CEST) Subject: [Vinecopula-commits] r132 - pkg/man Message-ID: <20150915155959.2C3E5187C0D@r-forge.r-project.org> Author: tnagler Date: 2015-09-15 17:59:58 +0200 (Tue, 15 Sep 2015) New Revision: 132 Modified: pkg/man/BiCop.Rd Log: fix typo in BiCop.Rd Modified: pkg/man/BiCop.Rd =================================================================== --- pkg/man/BiCop.Rd 2015-09-10 15:55:41 UTC (rev 131) +++ pkg/man/BiCop.Rd 2015-09-15 15:59:58 UTC (rev 132) @@ -1,7 +1,7 @@ \name{BiCop} \alias{BiCop} -\title{Cunstructing BiCop-objects} +\title{Constructing BiCop-objects} \description{ This function creates an object of class \code{BiCop} and checks for family/parameter consistency. From noreply at r-forge.r-project.org Thu Sep 17 13:30:31 2015 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Thu, 17 Sep 2015 13:30:31 +0200 (CEST) Subject: [Vinecopula-commits] r133 - in pkg: . R Message-ID: <20150917113031.A125418629D@r-forge.r-project.org> Author: tnagler Date: 2015-09-17 13:30:31 +0200 (Thu, 17 Sep 2015) New Revision: 133 Removed: pkg/R/RVineStructureSelect2.R Modified: pkg/NAMESPACE pkg/R/RVineStructureSelect.r Log: * replace old RVineStructureSelect with new version (not using igraph) Modified: pkg/NAMESPACE =================================================================== --- pkg/NAMESPACE 2015-09-15 15:59:58 UTC (rev 132) +++ pkg/NAMESPACE 2015-09-17 11:30:31 UTC (rev 133) @@ -57,7 +57,6 @@ export(RVineCopSelect) export(RVineMLE) export(RVineStructureSelect) -export(RVineStructureSelect2) export(RVineTreePlot) export(RVineVuongTest) export(RVineClarkeTest) Modified: pkg/R/RVineStructureSelect.r =================================================================== --- pkg/R/RVineStructureSelect.r 2015-09-15 15:59:58 UTC (rev 132) +++ pkg/R/RVineStructureSelect.r 2015-09-17 11:30:31 UTC (rev 133) @@ -1,43 +1,42 @@ -RVineStructureSelect <- function(data, familyset = NA, type = 0, selectioncrit = "AIC", indeptest = FALSE, - level = 0.05, trunclevel = NA, progress = FALSE, weights = NA, rotations = TRUE) { +RVineStructureSelect <- function(data, familyset = NA, type = 0, selectioncrit = "AIC", indeptest = FALSE, level = 0.05, trunclevel = NA, progress = FALSE, weights = NA, rotations = TRUE) { d <- ncol(data) - N <- nrow(data) + n <- nrow(data) - ## sanity checks - if (type == 0) - type <- "RVine" else if (type == 1) + ## sanity checks + if (type == 0) + type <- "RVine" else if (type == 1) type <- "CVine" - if (type != "RVine" & type != "CVine") + if (type != "RVine" & type != "CVine") stop("Vine model not implemented.") - if (N < 2) + if (n < 2) stop("Number of observations has to be at least 2.") - if (d < 3) + if (d < 3) stop("Dimension has to be at least 3.") - if (any(data > 1) || any(data < 0)) + 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)) { + 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))) + 104, 114, 124, 134, 204, 214, 224, 234))) stop("Copula family not implemented.") } } - if (selectioncrit != "AIC" && selectioncrit != "BIC") + if (selectioncrit != "AIC" && selectioncrit != "BIC") stop("Selection criterion not implemented.") - if (level < 0 & level > 1) + 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:d, sep = "") - if (is.na(trunclevel)) + ## set variable names and trunclevel if not provided + if (is.null(colnames(data))) + colnames(data) <- paste0("V", 1:d) + if (is.na(trunclevel)) trunclevel <- d - ## adjust familyset - if (trunclevel == 0) + ## adjust familyset + if (trunclevel == 0) familyset <- 0 - if (rotations) + if (rotations) familyset <- with_rotations(familyset) ## initialize object for results @@ -45,16 +44,17 @@ ## estimation in first tree ---------------------------- # find optimal tree - g <- initializeFirstGraph(data, weights) - MST <- findMaximumTauTree(g, mode = type) + g <- initializeFirstGraph2(data, weights) + MST <- findMaximumTauTree2(g, mode = type) + # estimate pair-copulas - VineTree <- fit.FirstTreeCopulas(MST, - data, - familyset, - selectioncrit, - indeptest, - level, - weights = weights) + VineTree <- fit.FirstTreeCopulas2(MST, + data, + familyset, + selectioncrit, + indeptest, + level, + weights = weights) # store results RVine$Tree[[1]] <- VineTree RVine$Graph[[1]] <- g @@ -63,20 +63,20 @@ ## estimation in higher trees -------------------------- for (i in 2:(d - 1)) { # only estimate pair-copulas if not truncated - if (trunclevel == i - 1) + if (trunclevel == i - 1) familyset <- 0 # find optimal tree - g <- buildNextGraph(VineTree, weights) - MST <- findMaximumTauTree(g, mode = type) + g <- buildNextGraph2(VineTree, weights) + MST <- findMaximumTauTree2(g, mode = type) # estimate pair-copulas - VineTree <- fit.TreeCopulas(MST, - VineTree, - familyset, - selectioncrit, - indeptest, - level, - progress, - weights = weights) + VineTree <- fit.TreeCopulas2(MST, + VineTree, + familyset, + selectioncrit, + indeptest, + level, + progress, + weights = weights) # store results RVine$Tree[[i]] <- VineTree RVine$Graph[[i]] <- g @@ -85,57 +85,96 @@ ## free memory and return results as 'RVineMatrix' object .RVine <- RVine rm(list = ls()) - as.RVM(.RVine) + as.RVM2(.RVine) } -initializeFirstGraph <- function(data.univ, weights) { - +initializeFirstGraph2 <- function(data.univ, weights) { ## calculate Kendall's tau taus <- TauMatrix(data = data.univ, weights = weights) - ## create graph with Kendall's tau as weights - g <- graph_from_adjacency_matrix(taus, - mode = "lower", - weighted = TRUE, - diag = FALSE) - E(g)$tau <- E(g)$weight - E(g)$name <- paste(as_edgelist(g)[, 1], as_edgelist(g)[, 2], sep = ",") - - ## store condition sets - E(g)$conditionedSet <- unname(split(ends(g, 1:gsize(g), names = FALSE), - 1:gsize(g))) - - ## return graph object - g + ## return full graph with tau as weights + graphFromTauMatrix(taus) } -## find maximum spanning tree/ first vine tree -findMaximumTauTree <- function(g, mode = "RVine") { +findMaximumTauTree2 <- function(g, mode = "RVine") { + ## construct adjency matrix + A <- adjacencyMatrix(g) + d <- ncol(A) if (mode == "RVine") { - return(mst(g, weights = 1 - abs(E(g)$weight))) - } else if (mode == "CVine") { - M <- abs(as_adjacency_matrix(g, attr = "weight", sparse = 0)) - sumtaus <- rowSums(M) - root <- which.max(sumtaus) + ## initialize + tree <- NULL + edges <- matrix(NA, d - 1, 2) + w <- numeric(d - 1) + i <- 1 - Ecken <- ends(g, 1:gsize(g), names = FALSE) - pos <- Ecken[, 2] == root | Ecken[, 1] == root + ## construct minimum spanning tree + for (k in 1:(d - 1)) { + # add selected edge to tree + tree <- c(tree, i) + + # find edge with minimal weight + m <- apply(as.matrix(A[, tree]), 2, min) + a <- apply(as.matrix(A[, tree]), 2, + function(x) order(rank(x)))[1, ] + b <- order(rank(m))[1] + j <- tree[b] + i <- a[b] + + # store edge and weight + edges[k, ] <- c(j, i) + w[k] <- A[i, j] + + ## adjust adjecency matrix to prevent loops + for (t in tree) + A[i, t] <- A[t, i] <- Inf + } - MST <- delete_edges(g, E(g)[!pos]) + ## reorder edges for backwads compatibility with igraph output + edges <- t(apply(edges, 1, function(x) sort(x))) + edges <- edges[order(edges[, 2], edges[, 1]), ] - return(MST) + ## delete unused edges from graph + E <- g$E$nums + in.tree <- apply(matrix(edges, ncol = 2), 1, + function(x) which((x[1] == E[, 1]) & (x[2] == E[, 2]))) + if (is.list(in.tree)) + do.call() + MST <- g + g$E$todel <- rep(TRUE, nrow(E)) + if (any(g$E$todel)) { + g$E$todel[in.tree] <- FALSE + MST <- deleteEdges(g) + } + } else if (mode == "CVine") { + ## set root as vertex with minimal sum of weights + A <- adjacencyMatrix(g) + diag(A) <- 0 + sumtaus <- rowSums(A) + root <- which.min(sumtaus) + + ## delete unused edges + g$E$todel <- !((g$E$nums[, 2] == root) | (g$E$nums[, 1] == root)) + MST <- g + if (any(g$E$todel )) + MST <- deleteEdges(g) + } else { + stop("vine not implemented") } + + ## return result + MST } + # not required any longer? Use TauMatrix instead fasttau <- function(x, y, weights = NA) { if (any(is.na(weights))) { m <- length(x) n <- length(y) - if (m == 0 || n == 0) + if (m == 0 || n == 0) stop("both 'x' and 'y' must be non-empty") - if (m != n) + if (m != n) stop("'x' and 'y' must have the same length") out <- .C("ktau", x = as.double(x), @@ -144,9 +183,9 @@ tau = as.double(0), S = as.double(0), D = as.double(0), - T = as.integer(0), + T = as.integer(0), U = as.integer(0), - V = as.integer(0), + V = as.integer(0), PACKAGE = "VineCopula") ktau <- out$tau } else { @@ -156,77 +195,80 @@ } ## fit pair-copulas for the first vine tree -fit.FirstTreeCopulas <- function(MST, data.univ, type, copulaSelectionBy, testForIndependence, testForIndependence.level, weights = NA) { +fit.FirstTreeCopulas2 <- function(MST, data.univ, type, copulaSelectionBy, testForIndependence, testForIndependence.level, weights = NA) { - d <- gsize(MST) + ## initialize estimation results with empty list + d <- nrow(MST$E$nums) + parameterForACopula <- lapply(1:d, function(i) NULL) - parameterForACopula <- list() - + ## prepare for estimation and store names for (i in 1:d) { - parameterForACopula[[i]] <- list() - - a <- ends(MST, i, names = FALSE) - + ## get edge and corresponding data + a <- MST$E$nums[i, ] parameterForACopula[[i]]$zr1 <- data.univ[, a[1]] parameterForACopula[[i]]$zr2 <- data.univ[, a[2]] + MST$E$Copula.Data.1[i] <- list(data.univ[, a[1]]) + MST$E$Copula.Data.2[i] <- list(data.univ[, a[2]]) - E(MST)[i]$Copula.Data.1 <- list(data.univ[, a[1]]) - E(MST)[i]$Copula.Data.2 <- list(data.univ[, a[2]]) - - if (is.null(V(MST)[a[1]]$name)) { - E(MST)[i]$Copula.CondName.1 <- a[1] - } else { - E(MST)[i]$Copula.CondName.1 <- V(MST)[a[1]]$name + ## set names for this edge + if (is.null(MST$V$names[a[1]])) { + MST$E$Copula.CondName.1[i] <- a[1] + } else { + MST$E$Copula.CondName.1[i] <- MST$V$names[a[1]] } - - if (is.null(V(MST)[a[2]]$name)) { - E(MST)[i]$Copula.CondName.2 <- a[2] + if (is.null(MST$V$names[a[2]])) { + MST$E$Copula.CondName.2[i] <- a[2] } else { - E(MST)[i]$Copula.CondName.2 <- V(MST)[a[2]]$name + MST$E$Copula.CondName.2[i] <- MST$V$names[a[2]] } - - 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 = " , ") + if (is.null(MST$V$names[a[1]]) || is.null(MST$V$names[a[2]])) { + MST$E$Copula.Name[i] <- paste(a[1], a[2], sep = " , ") } else { - E(MST)[i]$Copula.Name <- paste(V(MST)[a[1]]$name, - V(MST)[a[2]]$name, - sep = " , ") + MST$E$Copula.Name[i] <- paste(MST$V$names[a[1]], + MST$V$names[a[2]], + sep = " , ") } } + ## estimate parameters and select family outForACopula <- lapply(X = parameterForACopula, FUN = wrapper_fit.ACopula, - type, copulaSelectionBy, + type, + copulaSelectionBy, testForIndependence, - testForIndependence.level, + testForIndependence.level, weights) + ## store estimated model and pseudo-obversations for next tree for (i in 1:d) { - E(MST)$Copula.param[[i]] <- c(outForACopula[[i]]$par, - outForACopula[[i]]$par2) - E(MST)[i]$Copula.type <- outForACopula[[i]]$family - E(MST)[i]$Copula.out <- list(outForACopula[[i]]) + MST$E$Copula.param[[i]] <- c(outForACopula[[i]]$par, + outForACopula[[i]]$par2) + MST$E$Copula.type[i] <- outForACopula[[i]]$family + MST$E$Copula.out[i] <- list(outForACopula[[i]]) - E(MST)[i]$Copula.CondData.1 <- list(outForACopula[[i]]$CondOn.1) - E(MST)[i]$Copula.CondData.2 <- list(outForACopula[[i]]$CondOn.2) + MST$E$Copula.CondData.1[i] <- list(outForACopula[[i]]$CondOn.1) + MST$E$Copula.CondData.2[i] <- list(outForACopula[[i]]$CondOn.2) } - return(MST) + ## return results + MST } ## fit pair-copulas for vine trees 2,... -fit.TreeCopulas <- function(MST, oldVineGraph, type, copulaSelectionBy, testForIndependence, testForIndependence.level, progress, weights = NA) { - d <- gsize(MST) +fit.TreeCopulas2 <- function(MST, oldVineGraph, type, copulaSelectionBy, testForIndependence, testForIndependence.level, progress, weights = NA) { - parameterForACopula <- list() + ## initialize estimation results with empty list + d <- nrow(MST$E$nums) + parameterForACopula <- lapply(1:d, function(i) NULL) + + ## prepare for estimation for (i in 1:d) { - parameterForACopula[[i]] <- list() + ## get edge and corresponding data + con <- MST$E$nums[i, ] + temp <- oldVineGraph$E$nums[con, ] - con <- as.vector(ends(MST, i, names = FALSE)) - - temp <- ends(oldVineGraph, con, names = FALSE) - + ## fetch corresponding data and names if ((temp[1, 1] == temp[2, 1]) || (temp[1, 2] == temp[2, 1])) { same <- temp[2, 1] } else { @@ -235,23 +277,19 @@ } } - # other1 <- temp[1, temp[1, ] != same] - # other2 <- temp[2, temp[2, ] != same] - if (temp[1, 1] == same) { - zr1 <- E(oldVineGraph)[con[1]]$Copula.CondData.2 - n1 <- E(oldVineGraph)[con[1]]$Copula.CondName.2 + zr1 <- oldVineGraph$E$Copula.CondData.2[con[1]] + n1 <- oldVineGraph$E$Copula.CondName.2[con[1]] } else { - zr1 <- E(oldVineGraph)[con[1]]$Copula.CondData.1 - n1 <- E(oldVineGraph)[con[1]]$Copula.CondName.1 + zr1 <- oldVineGraph$E$Copula.CondData.1[con[1]] + n1 <- oldVineGraph$E$Copula.CondName.1[con[1]] } - if (temp[2, 1] == same) { - zr2 <- E(oldVineGraph)[con[2]]$Copula.CondData.2 - n2 <- E(oldVineGraph)[con[2]]$Copula.CondName.2 + zr2 <- oldVineGraph$E$Copula.CondData.2[con[2]] + n2 <- oldVineGraph$E$Copula.CondName.2[con[2]] } else { - zr2 <- E(oldVineGraph)[con[2]]$Copula.CondData.1 - n2 <- E(oldVineGraph)[con[2]]$Copula.CondName.1 + zr2 <- oldVineGraph$E$Copula.CondData.1[con[2]] + n2 <- oldVineGraph$E$Copula.CondName.1[con[2]] } if (is.list(zr1)) { @@ -266,79 +304,78 @@ n2a <- n2 } - if (progress == TRUE) - message(n1a, " + ", n2a, " --> ", E(MST)[i]$name) + if (progress == TRUE) + message(n1a, " + ", n2a, " --> ", MST$E$names[i]) parameterForACopula[[i]]$zr1 <- zr1a parameterForACopula[[i]]$zr2 <- zr2a - E(MST)[i]$Copula.Data.1 <- list(zr1a) - E(MST)[i]$Copula.Data.2 <- list(zr2a) + MST$E$Copula.Data.1[i] <- list(zr1a) + MST$E$Copula.Data.2[i] <- list(zr2a) - E(MST)[i]$Copula.CondName.1 <- n1a - E(MST)[i]$Copula.CondName.2 <- n2a + MST$E$Copula.CondName.1[i] <- n1a + MST$E$Copula.CondName.2[i] <- n2a } + ## estimate parameters and select family outForACopula <- lapply(X = parameterForACopula, FUN = wrapper_fit.ACopula, - type, copulaSelectionBy, - testForIndependence, - testForIndependence.level, + type, + copulaSelectionBy, + testForIndependence, + testForIndependence.level, weights) + ## store estimated model and pseudo-obversations for next tree for (i in 1:d) { - E(MST)$Copula.param[[i]] <- c(outForACopula[[i]]$par, outForACopula[[i]]$par2) - E(MST)[i]$Copula.type <- outForACopula[[i]]$family - E(MST)[i]$Copula.out <- list(outForACopula[[i]]) + MST$E$Copula.param[[i]] <- c(outForACopula[[i]]$par, + outForACopula[[i]]$par2) + MST$E$Copula.type[i] <- outForACopula[[i]]$family + MST$E$Copula.out[i] <- list(outForACopula[[i]]) - E(MST)[i]$Copula.CondData.1 <- list(outForACopula[[i]]$CondOn.1) - E(MST)[i]$Copula.CondData.2 <- list(outForACopula[[i]]$CondOn.2) + MST$E$Copula.CondData.1[i] <- list(outForACopula[[i]]$CondOn.1) + MST$E$Copula.CondData.2[i] <- list(outForACopula[[i]]$CondOn.2) } - return(MST) + ## return results + MST } ## initialize graph for next vine tree (possible edges) -buildNextGraph <- function(oldVineGraph, weights = NA) { +buildNextGraph2 <- function(oldVineGraph, weights = NA) { - d <- gsize(oldVineGraph) + d <- nrow(oldVineGraph$E$nums) ## initialize with full graph - g <- make_full_graph(d) - V(g)$name <- E(oldVineGraph)$name - V(g)$conditionedSet <- E(oldVineGraph)$conditionedSet - if (!is.null(E(oldVineGraph)$conditioningSet)) { - V(g)$conditioningSet <- E(oldVineGraph)$conditioningSet - } + g <- makeFullGraph(d) + g$V$names <- oldVineGraph$E$names + g$V$conditionedSet <- oldVineGraph$E$conditionedSet + g$V$conditioningSet <- oldVineGraph$E$conditioningSet ## get info for all edges - out <- lapply(1:gsize(g), - getEdgeInfo, - g = g, + out <- lapply(1:nrow(g$E$nums), + getEdgeInfo2, + g = g, oldVineGraph = oldVineGraph, weights = weights) ## annotate graph (same order as in old version of this function) - E(g)$weight <- sapply(out, function(x) x$tau) - E(g)$name <- sapply(out, function(x) x$name) - E(g)$conditionedSet <- lapply(out, function(x) x$nedSet) - E(g)$conditioningSet <- lapply(out, function(x) x$ningSet) - E(g)$todel <- sapply(out, function(x) x$todel) - E(g)$tau <- E(g)$weight + g$E$weights <- sapply(out, function(x) x$tau) + g$E$names <- sapply(out, function(x) x$name) + g$E$conditionedSet <- lapply(out, function(x) x$nedSet) + g$E$conditioningSet <- lapply(out, function(x) x$ningSet) + g$E$todel <- sapply(out, function(x) x$todel) ## delete edges that are prohibited by the proximity condition - g <- delete_edges(g, E(g)[E(g)$todel]) - - ## return new graph - g + deleteEdges(g) } ## function for obtaining edge information -getEdgeInfo <- function(i, g, oldVineGraph, weights) { +getEdgeInfo2 <- function(i, g, oldVineGraph, weights) { ## get edge - con <- as.vector(ends(g, i, names = FALSE)) - temp <- ends(oldVineGraph, con, names = FALSE) + con <- g$E$nums[i, ] + temp <- oldVineGraph$E$nums[con, ] ## check for proximity condition ok <- FALSE @@ -356,18 +393,18 @@ tau <- nedSet <- ningSet <- name <- NA todel <- TRUE - ## calculate edge info if proximity condition is fulfilled + # info if proximity condition is fulfilled ... if (ok) { - # get data + ## get data if (temp[1, 1] == same) { - zr1 <- E(oldVineGraph)[con[1]]$Copula.CondData.2 + zr1 <- oldVineGraph$E$Copula.CondData.2[con[1]] } else { - zr1 <- E(oldVineGraph)[con[1]]$Copula.CondData.1 + zr1 <- oldVineGraph$E$Copula.CondData.1[con[1]] } if (temp[2, 1] == same) { - zr2 <- E(oldVineGraph)[con[2]]$Copula.CondData.2 + zr2 <- oldVineGraph$E$Copula.CondData.2[con[2]] } else { - zr2 <- E(oldVineGraph)[con[2]]$Copula.CondData.1 + zr2 <- oldVineGraph$E$Copula.CondData.1[con[2]] } if (is.list(zr1)) { zr1a <- as.vector(zr1[[1]]) @@ -377,40 +414,31 @@ zr2a <- zr2 } - # calculate Kendall's tau + ## calculate Kendall's tau keine_nas <- !(is.na(zr1a) | is.na(zr2a)) - tau <- fasttau(zr1a[keine_nas], - zr2a[keine_nas], - weights) + tau <- fasttau(zr1a[keine_nas], zr2a[keine_nas], weights) - # get names - name.node1 <- strsplit(V(g)[con[1]]$name, split = " *[,;] *")[[1]] - name.node2 <- strsplit(V(g)[con[2]]$name, split = " *[,;] *")[[1]] + ## get names + name.node1 <- strsplit(g$V$names[con[1]], split = " *[,;] *")[[1]] + name.node2 <- strsplit(g$V$names[con[2]], split = " *[,;] *")[[1]] - # infer conditioned set and conditioning set - if (is.list(V(g)[con[1]]$conditionedSet)) { - l1 <- c(as.vector(V(g)[con[1]]$conditionedSet[[1]]), - as.vector(V(g)[con[1]]$conditioningSet[[1]])) - l2 <- c(as.vector(V(g)[con[2]]$conditionedSet[[1]]), - as.vector(V(g)[con[2]]$conditioningSet[[1]])) - } else { - l1 <- c(V(g)[con[1]]$conditionedSet, - V(g)[con[1]]$conditioningSet) - l2 <- c(V(g)[con[2]]$conditionedSet, - V(g)[con[2]]$conditioningSet) - } + ## infer conditioned set and conditioning set + l1 <- c(g$V$conditionedSet[[con[1]]], + g$V$conditioningSet[[con[1]]]) + l2 <- c(g$V$conditionedSet[[con[2]]], + g$V$conditioningSet[[con[2]]]) nedSet <- c(setdiff(l1, l2), setdiff(l2, l1)) ningSet <- intersect(l1, l2) - - # set edge name + + ## set edge name nmdiff <- c(setdiff(name.node1, name.node2), - setdiff(name.node2, name.node1)) - nmsect <- intersect(name.node1, name.node2) + setdiff(name.node2, name.node1)) + nmsect <- intersect(name.node1, name.node2) name <- paste(paste(nmdiff, collapse = ","), paste(nmsect, collapse = ","), sep = " ; ") - # mark as ok + ## mark as ok todel <- FALSE } @@ -424,7 +452,7 @@ wrapper_fit.ACopula <- function(parameterForACopula, type, ...) { - return(fit.ACopula(parameterForACopula$zr1, + return(fit.ACopula(parameterForACopula$zr1, parameterForACopula$zr2, type, ...)) @@ -458,23 +486,23 @@ } ## store pseudo-observations for estimation in next tree - out$CondOn.1 <- .C("Hfunc1", + out$CondOn.1 <- .C("Hfunc1", as.integer(out$family), as.integer(length(u1)), as.double(u1), as.double(u2), as.double(out$par), - as.double(out$par2), - as.double(rep(0, length(u1))), + as.double(out$par2), + as.double(rep(0, length(u1))), PACKAGE = "VineCopula")[[7]] out$CondOn.2 <- .C("Hfunc2", as.integer(out$family), as.integer(length(u1)), as.double(u2), - as.double(u1), - as.double(out$par), - as.double(out$par2), - as.double(rep(0, length(u1))), + as.double(u1), + as.double(out$par), + as.double(out$par2), + as.double(rep(0, length(u1))), PACKAGE = "VineCopula")[[7]] ## return results @@ -482,41 +510,28 @@ } ## build R-Vine matrix object based on nested set of trees -as.RVM <- function(RVine) { +as.RVM2 <- function(RVine) { ## initialize objects n <- length(RVine$Tree) + 1 con <- list() - nam <- V(RVine$Tree[[1]])$name - conditionedSets <- NULL - corresppondingParams <- list() - corresppondingTypes <- list() + nam <- RVine$Tree[[1]]$V$names + nedSets <- list() + crspParams <- list() + crspTypes <- list() ## get selected pairs, families and estimated parameters - if (is.list(E(RVine$Tree[[n - 1]])$conditionedSet)) { - conditionedSets[[n - 1]][[1]] <- (E(RVine$Tree[[n - 1]])$conditionedSet[[1]]) - for (k in 1:(n - 2)) { - # conditionedSets[[k]] = E(RVine$Tree[[k]])$conditionedSet[[1]] - conditionedSets[[k]] <- E(RVine$Tree[[k]])$conditionedSet - corresppondingParams[[k]] <- as.list(E(RVine$Tree[[k]])$Copula.param) - corresppondingTypes[[k]] <- as.list(E(RVine$Tree[[k]])$Copula.type) - } - - corresppondingParams[[n - 1]] <- list() - corresppondingParams[[n - 1]] <- as.list(E(RVine$Tree[[n - 1]])$Copula.param) - corresppondingTypes[[n - 1]] <- as.list(E(RVine$Tree[[n - 1]])$Copula.type) - # print(corresppondingParams) + for (k in 1:(n - 2)) { + nedSets[[k]] <- RVine$Tree[[k]]$E$conditionedSet + crspParams[[k]] <- as.list(RVine$Tree[[k]]$E$Copula.param) + crspTypes[[k]] <- as.list(RVine$Tree[[k]]$E$Copula.type) + } + crspParams[[n - 1]] <- as.list(RVine$Tree[[n - 1]]$E$Copula.param) + crspTypes[[n - 1]] <- as.list(RVine$Tree[[n - 1]]$E$Copula.type) + if (is.list(RVine$Tree[[n - 1]]$E$conditionedSet)) { + nedSets[[n - 1]] <- list(RVine$Tree[[n - 1]]$E$conditionedSet[[1]]) } else { - conditionedSets[[n - 1]][[1]] <- (E(RVine$Tree[[n - 1]])$conditionedSet) - for (k in 1:(n - 2)) { - conditionedSets[[k]] <- E(RVine$Tree[[k]])$conditionedSet - corresppondingParams[[k]] <- as.list(E(RVine$Tree[[k]])$Copula.param) - corresppondingTypes[[k]] <- as.list(E(RVine$Tree[[k]])$Copula.type) - } - # print(conditionedSets) - corresppondingParams[[n - 1]] <- list() - corresppondingParams[[n - 1]] <- as.list(E(RVine$Tree[[n - 1]])$Copula.param) - corresppondingTypes[[n - 1]] <- as.list(E(RVine$Tree[[n - 1]])$Copula.type) + nedSets[[n - 1]] <- list(RVine$Tree[[n - 1]]$E$conditionedSet) } ## initialize matrices for RVineMatrix object @@ -527,23 +542,22 @@ ## store structure, families and parameters in matrices for (k in 1:(n - 1)) { - w <- conditionedSets[[n - k]][[1]][1] + w <- nedSets[[n - k]][[1]][1] M[k, k] <- w - M[(k + 1), k] <- conditionedSets[[n - k]][[1]][2] + M[(k + 1), k] <- nedSets[[n - k]][[1]][2] - Param[(k + 1), k] <- corresppondingParams[[n - k]][[1]][1] - Params2[(k + 1), k] <- corresppondingParams[[n - k]][[1]][2] + Param[(k + 1), k] <- crspParams[[n - k]][[1]][1] + Params2[(k + 1), k] <- crspParams[[n - k]][[1]][2] + Type[(k + 1), k] <- crspTypes[[n - k]][[1]] - Type[(k + 1), k] <- corresppondingTypes[[n - k]][[1]] - if (k == (n - 1)) { - M[(k + 1), (k + 1)] <- conditionedSets[[n - k]][[1]][2] + M[(k + 1), (k + 1)] <- nedSets[[n - k]][[1]][2] } else { for (i in (k + 2):n) { - for (j in 1:length(conditionedSets[[n - i + 1]])) { - cs <- conditionedSets[[n - i + 1]][[j]] - cty <- corresppondingTypes[[n - i + 1]][[j]] + for (j in 1:length(nedSets[[n - i + 1]])) { + cs <- nedSets[[n - i + 1]][[j]] + cty <- crspTypes[[n - i + 1]][[j]] if (cs[1] == w) { M[i, k] <- cs[2] Type[i, k] <- cty @@ -566,14 +580,13 @@ break } } - Param[i, k] <- corresppondingParams[[n - i + 1]][[j]][1] - Params2[i, k] <- corresppondingParams[[n - i + 1]][[j]][2] - conditionedSets[[n - i + 1]][[j]] <- NULL - corresppondingParams[[n - i + 1]][[j]] <- NULL - corresppondingTypes[[n - i + 1]][[j]] <- NULL + Param[i, k] <- crspParams[[n - i + 1]][[j]][1] + Params2[i, k] <- crspParams[[n - i + 1]][[j]][2] + nedSets[[n - i + 1]][[j]] <- NULL + crspParams[[n - i + 1]][[j]] <- NULL + crspTypes[[n - i + 1]][[j]] <- NULL } } - } ## clean NAs @@ -583,3 +596,84 @@ ## return RVineMatrix object RVineMatrix(M, family = Type, par = Param, par2 = Params2, names = nam) } + + +## functions for handling the tree structure ------------------------- +graphFromTauMatrix <- function(tau) { + d <- ncol(tau) + # get variable names + nms <- colnames(tau) + # construct edge set + E <- cbind(do.call(c, sapply(1:(d-1), function(i) seq.int(i))), + do.call(c, sapply(1:(d-1), function(i) rep(i+1, i)))) + # add edge names + E.names <- apply(E, 1, function(x) paste(nms[x[1]], nms[x[2]], sep = ",")) + # set weights + w <- tau[upper.tri(tau)] + + ## return results + list(V = list(names = nms, + conditionedSet = NULL, + conditioningSet = NULL), + E = list(nums = E, + names = E.names, + weights = w, + conditionedSet = lapply(1:nrow(E), function(i) E[i, ]), + conditioningSet = NULL)) +} + +makeFullGraph <- function(d) { + ## create matrix of all combinations + E <- cbind(do.call(c, lapply(1:(d-1), function(i) rep(i, d-i))), + do.call(c, lapply(1:(d-1), function(i) (i+1):d))) + E <- matrix(E, ncol = 2) + + ## output dummy list with edges set + list(V = list(names = NULL, + conditionedSet = NULL, + conditioningSet = NULL), + E = list(nums = E, + names = NULL, + weights = NULL, + conditionedSet = E, + conditioningSet = NULL)) +} + +adjacencyMatrix <- function(g) { + ## create matrix of all combinations + d <- length(g$V$names) + v.all <- cbind(do.call(c, lapply(1:(d-1), function(i) seq.int(i))), + do.call(c, lapply(1:(d-1), function(i) rep(i+1, i)))) + + ## fnd weight + vals <- apply(v.all, 1, set_weight, E = g$E) + + ## create symmetric matrix of weights + M <- matrix(0, d, d) + M[upper.tri(M)] <- vals + M <- M + t(M) + diag(M) <- Inf + + ## return final matrix + M +} + +set_weight <- function(x, E) { + is.edge <- (x[1] == E$nums[, 1]) & (x[2] == E$nums[, 2]) + if (!any(is.edge)) Inf else (1 - abs(E$weights[which(is.edge)])) +} + + +deleteEdges <- function(g) { + ## reduce edge list + keep <- which(!g$E$todel) + E <- list(nums = matrix(g$E$nums[keep, ], ncol = 2), + names = g$E$names[keep], + weights = g$E$weights[keep], + conditionedSet = g$E$conditionedSet[keep], + conditioningSet = g$E$conditioningSet[keep]) + [TRUNCATED] To get the complete diff run: svnlook diff /svnroot/vinecopula -r 133 From noreply at r-forge.r-project.org Thu Sep 17 14:09:57 2015 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Thu, 17 Sep 2015 14:09:57 +0200 (CEST) Subject: [Vinecopula-commits] r134 - pkg/R Message-ID: <20150917120957.9A26F180965@r-forge.r-project.org> Author: tnagler Date: 2015-09-17 14:09:57 +0200 (Thu, 17 Sep 2015) New Revision: 134 Modified: pkg/R/RVineTreePlot.r Log: * replace RVineTreePlot with a call to plot.RVineMatrix Modified: pkg/R/RVineTreePlot.r =================================================================== --- pkg/R/RVineTreePlot.r 2015-09-17 11:30:31 UTC (rev 133) +++ pkg/R/RVineTreePlot.r 2015-09-17 12:09:57 UTC (rev 134) @@ -1,462 +1,471 @@ -RVineTreePlot <- function(data = NULL, RVM, method = "mle", max.df = 30, - max.BB = list(BB1 = c(5, 6), BB6 = c(6, 6), BB7 = c(5, 6), BB8 = c(6, 1)), - tree = "ALL", edge.labels = c("family"), P = NULL, legend = FALSE) { - - if (is(RVM)[1] != "RVineMatrix") - stop("'RVM' has to be an RVineMatrix object.") - - if (edge.labels[1] != FALSE & !all(edge.labels %in% c("family", "par", "par2", "theotau", "emptau", "pair"))) - stop("Edge label not implemented.") - if (is.null(data) & any(edge.labels == "emptau")) - stop("Empirical Kendall's tau values cannot be obtained if no data is provided.") - - if (is.null(data) == FALSE && (any(data > 1) || any(data < 0))) - stop("Data has be in the interval [0,1].") - d <- dim(RVM) - - if (is.null(RVM$names)) - RVM$names <- paste("V", 1:d, sep = "") - - empTauMat <- matrix(NA, d, d) - - if (!is.null(data)) { - - seqpar <- RVineSeqEstTau(data, - RVM, - method = method, - se = FALSE, - max.df = max.df, - max.BB = max.BB, - progress = FALSE) - - RVM$par <- seqpar$par - RVM$par2 <- seqpar$par2 - - if (any(edge.labels == "emptau")) - empTauMat <- round(seqpar$tau, 2) - +RVineTreePlot <- function(x, tree = "ALL", type = 0, edge.labels = NULL, legend.pos = "bottomleft", interactive = FALSE, ...) { + if (!inherits(x, "RVineMatrix")) { + stop("'x' has to be an RVineMatrix object.") } - - theoTauMat <- round(RVinePar2Tau(RVM), 2) - if (any(edge.labels == "par")) - parMat <- round(RVM$par, 2) - if (any(edge.labels == "par2")) - parMat2 <- round(RVM$par2, 2) - - if (is.null(P)) { - P <- list() - for (i in 1:(d - 1)) P[[i]] <- 0 - } - - if (tree != "ALL" && tree > d - 1) - stop("Selected tree does not exist.") - - if (tree == "ALL") - tree <- 1:(d - 1) - - M <- RVM$Matrix - - # cp. Alg. 3.1 in Dissmann - - edges <- list() - for (j in 1:(d - 1)) edges[[j]] <- array(NA, dim = c(d - j, 2, j)) - - weight <- list() - for (j in 1:(d - 1)) weight[[j]] <- rep(NA, d - j) - -# # label the nodes -# for (j in 1:(d - 1)) -# for (k in 1:d) edges[[j]][edges[[j]] == k] <- RVM$names[k] - - - if (edge.labels[1] != FALSE) { - numlabels <- length(edge.labels) - elabels <- list() - for (j in 1:(d - 1)) elabels[[j]] <- matrix(NA, d - j, numlabels) - } - - # initial edge - edges[[1]][1, , ] <- sort(c(M[d - 1, d - 1], M[d, d - 1])) - weight[[1]][1] <- ifelse(is.null(data), theoTauMat[d, d - 1], empTauMat[d, d - 1]) - if (edge.labels[1] != FALSE) { - for (jj in 1:numlabels) { - if (edge.labels[jj] == "family") - elabels[[1]][1, jj] <- BiCopName(RVM$family[d, d - 1], - short = TRUE) - if (edge.labels[jj] == "par") - elabels[[1]][1, jj] <- parMat[d, d - 1] - if (edge.labels[jj] == "par2") - elabels[[1]][1, jj] <- parMat2[d, d - 1] - if (edge.labels[jj] == "theotau") - elabels[[1]][1, jj] <- theoTauMat[d, d - 1] - if (edge.labels[jj] == "emptau") - elabels[[1]][1, jj] <- empTauMat[d, d - 1] - if (edge.labels[jj] == "pair") - if (legend == TRUE) { - elabels[[1]][1, jj] <- paste(RVM$Matrix[d - 1, d - 1], - RVM$Matrix[d, d - 1], - sep = ",") - } else { - elabels[[1]][1, jj] <- paste(RVM$names[RVM$Matrix[d - 1, d - 1]], - RVM$names[RVM$Matrix[d, d - 1]], - sep = ",") - } - } - } - - for (i in (d - 2):1) { - - # new edge in first tree - ee <- sort(c(M[i, i], M[d, i])) - edges[[1]][d - i, , ] <- ee - weight[[1]][d - i] <- ifelse(is.null(data), theoTauMat[d, i], empTauMat[d, i]) - if (edge.labels[1] != FALSE) { - for (jj in 1:numlabels) { - if (edge.labels[jj] == "family") - elabels[[1]][d - i, jj] <- BiCopName(RVM$family[d, i], - short = TRUE) - if (edge.labels[jj] == "par") - elabels[[1]][d - i, jj] <- parMat[d, i] - if (edge.labels[jj] == "par2") - elabels[[1]][d - i, jj] <- parMat2[d, i] - if (edge.labels[jj] == "theotau") - elabels[[1]][d - i, jj] <- theoTauMat[d, i] - if (edge.labels[jj] == "emptau") - elabels[[1]][d - i, jj] <- empTauMat[d, i] - if (edge.labels[jj] == "pair") - if (legend == TRUE) { - elabels[[1]][d - i, jj] <- paste(RVM$Matrix[i, i], - RVM$Matrix[d, i], - sep = ",") - } else { - elabels[[1]][d - i, jj] <- paste(RVM$names[RVM$Matrix[i, i]], - RVM$names[RVM$Matrix[d, i]], - sep = ",") - } - } - } - # edges in further trees - for (k in 1:(d - i - 1)) { - edges[[k + 1]][d - i - k, 1, ] <- ee - - # identify conditioned and conditioning sets - if (length(M[(d - k):d, i]) >= 3) { - if (setequal(M[(d - k):d, i], ee_old)) { - edges[[k + 1]][d - i - k, 2, ] <- ee_old - } else { - for (j in 1:(d - i - k)) { - if (setequal(M[(d - k):d, i], edges[[k + 1]][j, 1, ])) - edges[[k + 1]][d - i - k, 2, ] <- edges[[k + 1]][j, 1, ] - if (setequal(M[(d - k):d, i], edges[[k + 1]][j, 2, ])) - edges[[k + 1]][d - i - k, 2, ] <- edges[[k + 1]][j, 2, ] - } - } - } else { - edges[[k + 1]][d - i - k, 2, ] <- sort(M[(d - k):d, i]) - } - - # create edge lables - weight[[k + 1]][d - i - k] <- ifelse(is.null(data), theoTauMat[d - k, i], empTauMat[d - k, i]) - if (edge.labels[1] != FALSE) { - for (jj in 1:numlabels) { - if (edge.labels[jj] == "family") - elabels[[k + 1]][d - i - k, jj] <- BiCopName(RVM$family[d - k, i], short = TRUE) - if (edge.labels[jj] == "par") - elabels[[k + 1]][d - i - k, jj] <- parMat[d - k, i] - if (edge.labels[jj] == "par2") - elabels[[k + 1]][d - i - k, jj] <- parMat2[d - k, i] - if (edge.labels[jj] == "theotau") - elabels[[k + 1]][d - i - k, jj] <- theoTauMat[d - k, i] - if (edge.labels[jj] == "emptau") - elabels[[k + 1]][d - i - k, jj] <- empTauMat[d - k, i] - if (edge.labels[jj] == "pair") { - if (legend == TRUE) { - handle1 <- paste(RVM$Matrix[i, i], - RVM$Matrix[d - k, i], - sep = ",") - handle2 <- paste(RVM$Matrix[(d - k + 1):d, i], - collapse = ",") - handle3 <- paste(handle1, - handle2, - sep = ";") - } else { - handle1 <- paste(RVM$names[RVM$Matrix[i, i]], - RVM$names[RVM$Matrix[d - k, i]], - sep = ",") - handle2 <- paste(RVM$names[RVM$Matrix[(d - k + 1):d, i]], - collapse = ",") - handle3 <- paste(handle1, - handle2, - sep = ";") - } - elabels[[k + 1]][d - i - k, jj] <- handle3 #paste(handle1,handle2,sep=';') - } - } - } - - # identify conditioned and conditioning sets - ee <- c(sort(c(setdiff(ee, M[(d - k):d, i]), - setdiff(M[(d - k):d, i], ee))), - sort(intersect(ee, M[(d - k):d, i]))) - } - - ee_old <- ee - - } - - # label the nodes - if (legend == FALSE) { - for (j in 1:(d - 1)) for (k in 1:d) edges[[j]][edges[[j]] == k] <- RVM$names[k] - } - - # convert to edge lists - edgelist <- list() - for (j in 1:(d - 1)) edgelist[[j]] <- matrix(NA, d - j, 2) - - edgelist[[1]] <- matrix(as.character(edges[[1]][, , 1]), d - 1, 2) - - for (j in 1:(d - 2)) edgelist[[2]][j, ] <- c(paste(edges[[2]][j, 1, ], collapse = ","), - paste(edges[[2]][j, 2, ], collapse = ",")) - - # separate conditioned and conditioning sets - if (d > 3) { - for (i in 3:(d - 1)) { - for (j in 1:(d - i)) { - edgelist[[i]][j, 1] <- paste(paste(edges[[i]][j, 1, 1:2], collapse = ","), - paste(edges[[i]][j, 1, 3:i], collapse = ","), sep = ";") - edgelist[[i]][j, 2] <- paste(paste(edges[[i]][j, 2, 1:2], collapse = ","), - paste(edges[[i]][j, 2, 3:i], collapse = ","), sep = ";") - } - } - } - - # combine edge lables - if (edge.labels[1] != FALSE) { - elabels2 <- list() - for (j in 1:(d - 1)) { - elabels2[[j]] <- rep(NA, d - j) - for (i in 1:(d - j)) elabels2[[j]][i] <- paste(elabels[[j]][i, ], collapse = ",") - } - } - - # create graphs - gg <- list() - for (i in 1:(d - 1)) { - gg[[i]] <- graph_from_edgelist(edgelist[[i]], directed = FALSE) - E(gg[[i]])$weight <- weight[[i]] - if (edge.labels[1] != FALSE) - E(gg[[i]])$name <- elabels2[[i]] - } - - # loop through the trees - for (i in tree) { - - g <- gg[[i]] - - if (edge.labels[1] != FALSE) { - elabel <- E(g)$name - } else { - elabel <- NULL - } - - ## specify layout for plotting - if (all(P[[i]] == 0)) { - P[[i]] <- layout_in_circle(g) - P[[i]] <- layout_with_graphopt(g, start = P[[i]], niter = 50, spring.length = 1) - } - - ## initialize plotting - main <- paste("Tree ", i, sep = "") - if (legend == TRUE) { - vwidth <- max(strwidth(V(g)$name, units = "figure")) * 800 - vheight <- 20 - } else { - vwidth <- max(strwidth(V(g)$name, units = "figure")) * 1000 - vheight <- 20 - } - - ## plot tree - plot(g, layout = P[[i]], - vertex.label = V(g)$name, - vertex.shape = "rectangle", - vertex.size = vwidth, - vertex.size2 = vheight, - edge.label.family = "sans", - edge.label = elabel, - edge.width = (10*abs(E(g)$weight) + 0.5), - edge.arrow.size = 0, - main = main) - if (legend == TRUE) { - legend("bottomleft", legend = paste(1:d, RVM$name, sep = " = "), - bty = "n", xjust = 0) - } - - if (i != max(tree)) { - par(ask = TRUE) - } else { - par(ask = FALSE) - } - - } - - return(P) - + warning("RVineTreePlot is deprecated and behaves differently compared to versions < 2.0. Use plot.RVineMatrix instead.") + plot(x, tree, type, edge.labels, legend.pos, interactive, ...) } -RVineSeqEstTau <- function(data, RVM, 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)), - progress = FALSE) { - data <- as.matrix(data) - n <- dim(RVM) - N <- nrow(data) - if (dim(data)[2] != dim(RVM)) - stop("Dimensions of 'data' and 'RVM' do not match.") - if (N < 2) - stop("Number of observations has to be at least 2.") - if (!("RVineMatrix" %in% is(RVM))) - stop("'RVM' has to be an RVineMatrix object.") - - if (method != "mle" && method != "itau") - stop("Estimation method has to be either 'mle' or 'itau'.") - - 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].") - - o <- diag(RVM$Matrix) - - if (any(o != length(o):1)) { - oldRVM <- RVM - RVM <- normalizeRVineMatrix(RVM) - data <- data[, o[length(o):1]] - } - - Params <- RVM$par - Params2 <- RVM$par2 - - if (se == TRUE) { - seMat1 <- matrix(0, nrow = n, ncol = n) - seMat2 <- matrix(0, nrow = n, ncol = n) - } - - empTauMat <- matrix(0, nrow = n, ncol = 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]) - - for (i in (n - 1):1) { - - for (k in n:(i + 1)) { - - m <- RVM$MaxMat[k, i] - zr1 <- V$direct[k, i, ] - - if (m == RVM$Matrix[k, i]) { - zr2 <- V$direct[k, (n - m + 1), ] - } else { - zr2 <- V$indirect[k, (n - m + 1), ] - } - - - if (RVM$family[k, i] == 2 | RVM$family[k, i] == 7 | RVM$family[k, i] == 8 | RVM$family[k, i] == 9) { - if (progress == TRUE) { - if (k == n) { - message(oldRVM$Matrix[i, i], ",", oldRVM$Matrix[k, i]) - } else { - message(oldRVM$Matrix[i, i], ",", oldRVM$Matrix[k, i], ";", - paste(oldRVM$Matrix[(k + 1):n, i], collapse = ",")) - } - } - par.out <- BiCopEst(zr2, - zr1, - RVM$family[k, i], - method, - se, - max.df, - max.BB) - # par1 <- out.par$par - Params[k, i] <- par.out$par - Params2[k, i] <- par.out$par2 - # empTauMat[k,i] = cor(zr2,zr1,method='kendall') - empTauMat[k, i] <- fasttau(zr2, zr1) - if (se == TRUE) { - # se1 <- par.out$se - seMat1[k, i] <- par.out$se - seMat2[k, i] <- par.out$se2 - } - } else { - if (progress == TRUE) { - if (k == n) { - message(oldRVM$Matrix[i, i], ",", oldRVM$Matrix[k, i]) - } else { - message(oldRVM$Matrix[i, i], ",", oldRVM$Matrix[k, i], ";", - paste(oldRVM$Matrix[(k + 1):n, i], collapse = ",")) - } - } - par.out <- BiCopEst(zr2, zr1, RVM$family[k, i], method, se, max.df, max.BB) - Params[k, i] <- par.out$par - empTauMat[k, i] <- cor(zr2, zr1, method = "kendall") - empTauMat[k, i] <- fasttau(zr2, zr1) - if (se == TRUE) { - seMat1[k, i] <- par.out$se - } - } - - - if (RVM$CondDistr$direct[k - 1, i]) { - V$direct[k - 1, i, ] <- .C("Hfunc1", - as.integer(RVM$family[k, i]), - as.integer(length(zr1)), - as.double(zr1), - as.double(zr2), - as.double(Params[k, i]), - as.double(Params2[k, i]), - as.double(rep(0, length(zr1))), - PACKAGE = "VineCopula")[[7]] - } - if (RVM$CondDistr$indirect[k - 1, i]) { - V$indirect[k - 1, i, ] <- .C("Hfunc2", - as.integer(RVM$family[k, i]), - as.integer(length(zr2)), - as.double(zr2), - as.double(zr1), - as.double(Params[k, i]), - as.double(Params2[k, i]), - as.double(rep(0, length(zr1))), - PACKAGE = "VineCopula")[[7]] - } - - } - } - - if (se == FALSE) { - return(list(par = Params, - par2 = Params2, - tau = empTauMat)) - } else { - return(list(par = Params, - par2 = Params2, - tau = empTauMat, - se = seMat1, - se2 = seMat2)) - } -} + +# RVineTreePlot <- function(data = NULL, RVM, method = "mle", max.df = 30, +# max.BB = list(BB1 = c(5, 6), BB6 = c(6, 6), BB7 = c(5, 6), BB8 = c(6, 1)), +# tree = "ALL", edge.labels = c("family"), P = NULL, legend = FALSE) { +# +# if (is(RVM)[1] != "RVineMatrix") +# stop("'RVM' has to be an RVineMatrix object.") +# +# if (edge.labels[1] != FALSE & !all(edge.labels %in% c("family", "par", "par2", "theotau", "emptau", "pair"))) +# stop("Edge label not implemented.") +# if (is.null(data) & any(edge.labels == "emptau")) +# stop("Empirical Kendall's tau values cannot be obtained if no data is provided.") +# +# if (is.null(data) == FALSE && (any(data > 1) || any(data < 0))) +# stop("Data has be in the interval [0,1].") +# d <- dim(RVM) +# +# if (is.null(RVM$names)) +# RVM$names <- paste("V", 1:d, sep = "") +# +# empTauMat <- matrix(NA, d, d) +# +# if (!is.null(data)) { +# +# seqpar <- RVineSeqEstTau(data, +# RVM, +# method = method, +# se = FALSE, +# max.df = max.df, +# max.BB = max.BB, +# progress = FALSE) +# +# RVM$par <- seqpar$par +# RVM$par2 <- seqpar$par2 +# +# if (any(edge.labels == "emptau")) +# empTauMat <- round(seqpar$tau, 2) +# +# } +# +# theoTauMat <- round(RVinePar2Tau(RVM), 2) +# if (any(edge.labels == "par")) +# parMat <- round(RVM$par, 2) +# if (any(edge.labels == "par2")) +# parMat2 <- round(RVM$par2, 2) +# +# if (is.null(P)) { +# P <- list() +# for (i in 1:(d - 1)) P[[i]] <- 0 +# } +# +# if (tree != "ALL" && tree > d - 1) +# stop("Selected tree does not exist.") +# +# if (tree == "ALL") +# tree <- 1:(d - 1) +# +# M <- RVM$Matrix +# +# # cp. Alg. 3.1 in Dissmann +# +# edges <- list() +# for (j in 1:(d - 1)) edges[[j]] <- array(NA, dim = c(d - j, 2, j)) +# +# weight <- list() +# for (j in 1:(d - 1)) weight[[j]] <- rep(NA, d - j) +# +# # # label the nodes +# # for (j in 1:(d - 1)) +# # for (k in 1:d) edges[[j]][edges[[j]] == k] <- RVM$names[k] +# +# +# if (edge.labels[1] != FALSE) { +# numlabels <- length(edge.labels) +# elabels <- list() +# for (j in 1:(d - 1)) elabels[[j]] <- matrix(NA, d - j, numlabels) +# } +# +# # initial edge +# edges[[1]][1, , ] <- sort(c(M[d - 1, d - 1], M[d, d - 1])) +# weight[[1]][1] <- ifelse(is.null(data), theoTauMat[d, d - 1], empTauMat[d, d - 1]) +# if (edge.labels[1] != FALSE) { +# for (jj in 1:numlabels) { +# if (edge.labels[jj] == "family") +# elabels[[1]][1, jj] <- BiCopName(RVM$family[d, d - 1], +# short = TRUE) +# if (edge.labels[jj] == "par") +# elabels[[1]][1, jj] <- parMat[d, d - 1] +# if (edge.labels[jj] == "par2") +# elabels[[1]][1, jj] <- parMat2[d, d - 1] +# if (edge.labels[jj] == "theotau") +# elabels[[1]][1, jj] <- theoTauMat[d, d - 1] +# if (edge.labels[jj] == "emptau") +# elabels[[1]][1, jj] <- empTauMat[d, d - 1] +# if (edge.labels[jj] == "pair") +# if (legend == TRUE) { +# elabels[[1]][1, jj] <- paste(RVM$Matrix[d - 1, d - 1], +# RVM$Matrix[d, d - 1], +# sep = ",") +# } else { +# elabels[[1]][1, jj] <- paste(RVM$names[RVM$Matrix[d - 1, d - 1]], +# RVM$names[RVM$Matrix[d, d - 1]], +# sep = ",") +# } +# } +# } +# +# for (i in (d - 2):1) { +# +# # new edge in first tree +# ee <- sort(c(M[i, i], M[d, i])) +# edges[[1]][d - i, , ] <- ee +# weight[[1]][d - i] <- ifelse(is.null(data), theoTauMat[d, i], empTauMat[d, i]) +# if (edge.labels[1] != FALSE) { +# for (jj in 1:numlabels) { +# if (edge.labels[jj] == "family") +# elabels[[1]][d - i, jj] <- BiCopName(RVM$family[d, i], +# short = TRUE) +# if (edge.labels[jj] == "par") +# elabels[[1]][d - i, jj] <- parMat[d, i] +# if (edge.labels[jj] == "par2") +# elabels[[1]][d - i, jj] <- parMat2[d, i] +# if (edge.labels[jj] == "theotau") +# elabels[[1]][d - i, jj] <- theoTauMat[d, i] +# if (edge.labels[jj] == "emptau") +# elabels[[1]][d - i, jj] <- empTauMat[d, i] +# if (edge.labels[jj] == "pair") +# if (legend == TRUE) { +# elabels[[1]][d - i, jj] <- paste(RVM$Matrix[i, i], +# RVM$Matrix[d, i], +# sep = ",") +# } else { +# elabels[[1]][d - i, jj] <- paste(RVM$names[RVM$Matrix[i, i]], +# RVM$names[RVM$Matrix[d, i]], +# sep = ",") +# } +# } +# } +# # edges in further trees +# for (k in 1:(d - i - 1)) { +# edges[[k + 1]][d - i - k, 1, ] <- ee +# +# # identify conditioned and conditioning sets +# if (length(M[(d - k):d, i]) >= 3) { +# if (setequal(M[(d - k):d, i], ee_old)) { +# edges[[k + 1]][d - i - k, 2, ] <- ee_old +# } else { +# for (j in 1:(d - i - k)) { +# if (setequal(M[(d - k):d, i], edges[[k + 1]][j, 1, ])) +# edges[[k + 1]][d - i - k, 2, ] <- edges[[k + 1]][j, 1, ] +# if (setequal(M[(d - k):d, i], edges[[k + 1]][j, 2, ])) +# edges[[k + 1]][d - i - k, 2, ] <- edges[[k + 1]][j, 2, ] +# } +# } +# } else { +# edges[[k + 1]][d - i - k, 2, ] <- sort(M[(d - k):d, i]) +# } +# +# # create edge lables +# weight[[k + 1]][d - i - k] <- ifelse(is.null(data), theoTauMat[d - k, i], empTauMat[d - k, i]) +# if (edge.labels[1] != FALSE) { +# for (jj in 1:numlabels) { +# if (edge.labels[jj] == "family") +# elabels[[k + 1]][d - i - k, jj] <- BiCopName(RVM$family[d - k, i], short = TRUE) +# if (edge.labels[jj] == "par") +# elabels[[k + 1]][d - i - k, jj] <- parMat[d - k, i] +# if (edge.labels[jj] == "par2") +# elabels[[k + 1]][d - i - k, jj] <- parMat2[d - k, i] +# if (edge.labels[jj] == "theotau") +# elabels[[k + 1]][d - i - k, jj] <- theoTauMat[d - k, i] +# if (edge.labels[jj] == "emptau") +# elabels[[k + 1]][d - i - k, jj] <- empTauMat[d - k, i] +# if (edge.labels[jj] == "pair") { +# if (legend == TRUE) { +# handle1 <- paste(RVM$Matrix[i, i], +# RVM$Matrix[d - k, i], +# sep = ",") +# handle2 <- paste(RVM$Matrix[(d - k + 1):d, i], +# collapse = ",") +# handle3 <- paste(handle1, +# handle2, +# sep = ";") +# } else { +# handle1 <- paste(RVM$names[RVM$Matrix[i, i]], +# RVM$names[RVM$Matrix[d - k, i]], +# sep = ",") +# handle2 <- paste(RVM$names[RVM$Matrix[(d - k + 1):d, i]], +# collapse = ",") +# handle3 <- paste(handle1, +# handle2, +# sep = ";") +# } +# elabels[[k + 1]][d - i - k, jj] <- handle3 #paste(handle1,handle2,sep=';') +# } +# } +# } +# +# # identify conditioned and conditioning sets +# ee <- c(sort(c(setdiff(ee, M[(d - k):d, i]), +# setdiff(M[(d - k):d, i], ee))), +# sort(intersect(ee, M[(d - k):d, i]))) +# } +# +# ee_old <- ee +# +# } +# +# # label the nodes +# if (legend == FALSE) { +# for (j in 1:(d - 1)) for (k in 1:d) edges[[j]][edges[[j]] == k] <- RVM$names[k] +# } +# +# # convert to edge lists +# edgelist <- list() +# for (j in 1:(d - 1)) edgelist[[j]] <- matrix(NA, d - j, 2) +# +# edgelist[[1]] <- matrix(as.character(edges[[1]][, , 1]), d - 1, 2) +# +# for (j in 1:(d - 2)) edgelist[[2]][j, ] <- c(paste(edges[[2]][j, 1, ], collapse = ","), +# paste(edges[[2]][j, 2, ], collapse = ",")) +# +# # separate conditioned and conditioning sets +# if (d > 3) { +# for (i in 3:(d - 1)) { +# for (j in 1:(d - i)) { +# edgelist[[i]][j, 1] <- paste(paste(edges[[i]][j, 1, 1:2], collapse = ","), +# paste(edges[[i]][j, 1, 3:i], collapse = ","), sep = ";") +# edgelist[[i]][j, 2] <- paste(paste(edges[[i]][j, 2, 1:2], collapse = ","), +# paste(edges[[i]][j, 2, 3:i], collapse = ","), sep = ";") +# } +# } +# } +# +# # combine edge lables +# if (edge.labels[1] != FALSE) { +# elabels2 <- list() +# for (j in 1:(d - 1)) { +# elabels2[[j]] <- rep(NA, d - j) +# for (i in 1:(d - j)) elabels2[[j]][i] <- paste(elabels[[j]][i, ], collapse = ",") +# } +# } +# +# # create graphs +# gg <- list() +# for (i in 1:(d - 1)) { +# gg[[i]] <- graph_from_edgelist(edgelist[[i]], directed = FALSE) +# E(gg[[i]])$weight <- weight[[i]] +# if (edge.labels[1] != FALSE) +# E(gg[[i]])$name <- elabels2[[i]] +# } +# +# # loop through the trees +# for (i in tree) { +# +# g <- gg[[i]] +# +# if (edge.labels[1] != FALSE) { +# elabel <- E(g)$name +# } else { +# elabel <- NULL +# } +# +# ## specify layout for plotting +# if (all(P[[i]] == 0)) { +# P[[i]] <- layout_in_circle(g) +# P[[i]] <- layout_with_graphopt(g, start = P[[i]], niter = 50, spring.length = 1) +# } +# +# ## initialize plotting +# main <- paste("Tree ", i, sep = "") +# if (legend == TRUE) { +# vwidth <- max(strwidth(V(g)$name, units = "figure")) * 800 +# vheight <- 20 +# } else { +# vwidth <- max(strwidth(V(g)$name, units = "figure")) * 1000 +# vheight <- 20 +# } +# +# ## plot tree +# plot(g, layout = P[[i]], +# vertex.label = V(g)$name, +# vertex.shape = "rectangle", +# vertex.size = vwidth, +# vertex.size2 = vheight, +# edge.label.family = "sans", +# edge.label = elabel, +# edge.width = (10*abs(E(g)$weight) + 0.5), +# edge.arrow.size = 0, +# main = main) +# if (legend == TRUE) { +# legend("bottomleft", legend = paste(1:d, RVM$name, sep = " = "), +# bty = "n", xjust = 0) +# } +# +# if (i != max(tree)) { +# par(ask = TRUE) +# } else { +# par(ask = FALSE) +# } +# +# } +# +# return(P) +# +# } +# +# RVineSeqEstTau <- function(data, RVM, 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)), +# progress = FALSE) { +# data <- as.matrix(data) +# n <- dim(RVM) +# N <- nrow(data) +# if (dim(data)[2] != dim(RVM)) +# stop("Dimensions of 'data' and 'RVM' do not match.") +# if (N < 2) +# stop("Number of observations has to be at least 2.") +# if (!("RVineMatrix" %in% is(RVM))) +# stop("'RVM' has to be an RVineMatrix object.") +# +# if (method != "mle" && method != "itau") +# stop("Estimation method has to be either 'mle' or 'itau'.") +# +# if (max.df <= 2) +# stop("The upper bound for the degrees of freedom parameter has to be larger than 2.") [TRUNCATED] To get the complete diff run: svnlook diff /svnroot/vinecopula -r 134 From noreply at r-forge.r-project.org Thu Sep 17 14:24:06 2015 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Thu, 17 Sep 2015 14:24:06 +0200 (CEST) Subject: [Vinecopula-commits] r135 - in pkg: . R man Message-ID: <20150917122406.4965C186726@r-forge.r-project.org> Author: tnagler Date: 2015-09-17 14:24:05 +0200 (Thu, 17 Sep 2015) New Revision: 135 Removed: pkg/man/RVineStructureSelect2.Rd Modified: pkg/DESCRIPTION pkg/NAMESPACE pkg/R/RVineMatrix.R pkg/man/RVineStructureSelect.Rd pkg/man/RVineTreePlot.Rd pkg/man/VineCopula-package.Rd Log: * remove igraph dependency for the package * update manual files accordingly Modified: pkg/DESCRIPTION =================================================================== --- pkg/DESCRIPTION 2015-09-17 12:09:57 UTC (rev 134) +++ pkg/DESCRIPTION 2015-09-17 12:24:05 UTC (rev 135) @@ -6,7 +6,7 @@ Author: Ulf Schepsmeier, Jakob Stoeber, Eike Christian Brechmann, Benedikt Graeler, Thomas Nagler, Tobias Erhardt Maintainer: Tobias Erhardt Depends: R (>= 2.11.0) -Imports: graphics, grDevices, stats, utils, MASS, mvtnorm, igraph (>= 1.0.0), network, methods, copula, ADGofTest, lattice +Imports: graphics, grDevices, stats, utils, MASS, mvtnorm, network, methods, copula, ADGofTest, lattice Suggests: CDVine, TSP Description: Tools for bivariate exploratory data analysis, bivariate copula selection and (vine) tree construction are provided. Vine copula models can be estimated either sequentially or by joint maximum likelihood estimation. Sampling algorithms and plotting methods are included. Data is assumed to lie in the unit hypercube (so-called copula data). For C- and D-vines links to the package 'CDVine' are provided. License: GPL (>= 2) Modified: pkg/NAMESPACE =================================================================== --- pkg/NAMESPACE 2015-09-17 12:09:57 UTC (rev 134) +++ pkg/NAMESPACE 2015-09-17 12:24:05 UTC (rev 135) @@ -15,10 +15,6 @@ "qnorm", "qt", "runif", "uniroot", "var") importFrom("utils", "combn", "getFromNamespace", "modifyList") importFrom("ADGofTest", "ad.test") -importFrom("igraph", "E", "E<-", "V", "V<-", "as_adjacency_matrix", - "as_edgelist", "delete_edges", "ends", "graph_from_adjacency_matrix", - "graph_from_edgelist", "gsize", "layout_in_circle", "layout_with_graphopt", - "make_full_graph", "mst", "plot.igraph") export(pobs) Modified: pkg/R/RVineMatrix.R =================================================================== --- pkg/R/RVineMatrix.R 2015-09-17 12:09:57 UTC (rev 134) +++ pkg/R/RVineMatrix.R 2015-09-17 12:24:05 UTC (rev 135) @@ -269,81 +269,7 @@ return(M) } -as.RVineMatrix <- function(RVine) { - - n <- length(RVine$Tree) + 1 - con <- list() - nam <- V(RVine$Tree[[1]])$name - - conditionedSets <- NULL - corresppondingParams <- list() - corresppondingTypes <- list() - - print(is.list(E(RVine$Tree[[n - 1]])$conditionedSet)) - - conditionedSets[[n - 1]][[1]] <- (E(RVine$Tree[[n - 1]])$conditionedSet) - for (k in 1:(n - 2)) { - conditionedSets[[k]] <- E(RVine$Tree[[k]])$conditionedSet - corresppondingParams[[k]] <- as.list(E(RVine$Tree[[k]])$Copula.param) - corresppondingTypes[[k]] <- as.list(E(RVine$Tree[[k]])$Copula.type) - } - corresppondingParams[[n - 1]] <- list() - corresppondingParams[[n - 1]][[1]] <- (E(RVine$Tree[[n - 1]])$Copula.param) - corresppondingTypes[[n - 1]] <- as.list(E(RVine$Tree[[n - 1]])$Copula.type) - - Param <- array(dim = c(n, n)) - Params2 <- array(0, dim = c(n, n)) - Type <- array(dim = c(n, n)) - M <- matrix(NA, n, n) - - for (k in 1:(n - 1)) { - w <- conditionedSets[[n - k]][[1]][1] - - M[k, k] <- w - M[(k + 1), k] <- conditionedSets[[n - k]][[1]][2] - - Param[(k + 1), k] <- corresppondingParams[[n - k]][[1]][1] - Params2[(k + 1), k] <- corresppondingParams[[n - k]][[1]][2] - - Type[(k + 1), k] <- corresppondingTypes[[n - k]][[1]] - - if (k == (n - 1)) { - M[(k + 1), (k + 1)] <- conditionedSets[[n - k]][[1]][2] - } else { - for (i in (k + 2):n) { - for (j in 1:length(conditionedSets[[n - i + 1]])) { - cs <- conditionedSets[[n - i + 1]][[j]] - if (cs[1] == w) { - M[i, k] <- cs[2] - break - } else if (cs[2] == w) { - M[i, k] <- cs[1] - break - } - } - Param[i, k] <- corresppondingParams[[n - i + 1]][[j]][1] - Params2[i, k] <- corresppondingParams[[n - i + 1]][[j]][2] - Type[i, k] <- corresppondingTypes[[n - i + 1]][[j]] - - conditionedSets[[n - i + 1]][[j]] <- NULL - corresppondingParams[[n - i + 1]][[j]] <- NULL - corresppondingTypes[[n - i + 1]][[j]] <- NULL - } - } - - } - - M <- M + 1 - M[is.na(M)] <- 0 - Type[is.na(Type)] <- 0 - - return(RVineMatrix(M, - family = Type, - par = Param, - par2 = Params2, - names = nam)) - -} +as.RVineMatrix <- function(RVine) as.RVM2(RVine) ########################################################################### Modified: pkg/man/RVineStructureSelect.Rd =================================================================== --- pkg/man/RVineStructureSelect.Rd 2015-09-17 12:09:57 UTC (rev 134) +++ pkg/man/RVineStructureSelect.Rd 2015-09-17 12:24:05 UTC (rev 135) @@ -1,4 +1,4 @@ -\name{RVineStructureSelect} +\name{RVineStructureSelect} \alias{RVineStructureSelect} \title{Sequential Specification of R- and C-Vine Copula Models} @@ -10,14 +10,14 @@ \usage{ RVineStructureSelect(data, familyset = NA, type = 0, selectioncrit = "AIC", - indeptest = FALSE, level = 0.05, trunclevel = NA, - progress = FALSE, weights = NA, rotations = TRUE) + indeptest = FALSE, level = 0.05, trunclevel = NA, + progress = FALSE, weights = NA, rotations = TRUE) } \arguments{ \item{data}{An N x d data matrix (with uniform margins).} \item{familyset}{An integer vector of pair-copula families to select from (the independence copula MUST NOT be specified in this vector unless one wants to fit an independence vine!). - 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. + 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. Coding of pair-copula families: \cr \code{1} = Gaussian copula \cr @@ -25,14 +25,14 @@ \code{3} = Clayton copula \cr \code{4} = Gumbel copula \cr \code{5} = Frank copula \cr - \code{6} = Joe copula \cr + \code{6} = Joe copula \cr \code{7} = BB1 copula \cr \code{8} = BB6 copula \cr \code{9} = BB7 copula \cr \code{10} = BB8 copula \cr \code{13} = rotated Clayton copula (180 degrees; ``survival Clayton'') \cr \code{14} = rotated Gumbel copula (180 degrees; ``survival Gumbel'') \cr - \code{16} = rotated Joe copula (180 degrees; ``survival Joe'') \cr + \code{16} = rotated Joe copula (180 degrees; ``survival Joe'') \cr \code{17} = rotated BB1 copula (180 degrees; ``survival BB1'')\cr \code{18} = rotated BB6 copula (180 degrees; ``survival BB6'')\cr \code{19} = rotated BB7 copula (180 degrees; ``survival BB7'')\cr @@ -112,10 +112,10 @@ Computational Statistics & Data Analysis, 59 (1), 52-69. } -\author{Jeffrey Dissmann, Eike Brechmann, Ulf Schepsmeier} +\author{Jeffrey Dissmann, Eike Brechmann, Ulf Schepsmeier, Thomas Nagler} \seealso{\code{\link{RVineTreePlot}}, \code{\link{RVineCopSelect}}} - + \examples{ # load data set data(daxreturns) @@ -127,7 +127,7 @@ \dontrun{ # specify a C-vine copula model with only Clayton, Gumbel and Frank copulas (time-consuming) -CVM <- RVineStructureSelect(daxreturns, c(3,4,5), "CVine") +CVM <- RVineStructureSelect2(daxreturns, c(3,4,5), "CVine") } \dontrun{ Deleted: pkg/man/RVineStructureSelect2.Rd =================================================================== --- pkg/man/RVineStructureSelect2.Rd 2015-09-17 12:09:57 UTC (rev 134) +++ pkg/man/RVineStructureSelect2.Rd 2015-09-17 12:24:05 UTC (rev 135) @@ -1,145 +0,0 @@ -\name{RVineStructureSelect2} -\alias{RVineStructureSelect2} - -\title{Sequential Specification of R- and C-Vine Copula Models} - -\description{ -This function fits either an R- or a C-vine copula model to a d-dimensional copula data set. -Tree structures are determined and appropriate pair-copula families are selected using \code{\link{BiCopSelect}} and estimated sequentially (forward selection of trees). -} - -\usage{ -RVineStructureSelect2(data, familyset = NA, type = 0, selectioncrit = "AIC", - indeptest = FALSE, level = 0.05, trunclevel = NA, - progress = FALSE, weights = NA, rotations = TRUE) -} - -\arguments{ - \item{data}{An N x d data matrix (with uniform margins).} - \item{familyset}{An integer vector of pair-copula families to select from (the independence copula MUST NOT be specified in this vector unless one wants to fit an independence vine!). - 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. - Coding of pair-copula families: \cr - \code{1} = Gaussian copula \cr - \code{2} = Student t copula (t-copula) \cr - \code{3} = Clayton copula \cr - \code{4} = Gumbel copula \cr - \code{5} = Frank copula \cr - \code{6} = Joe copula \cr - \code{7} = BB1 copula \cr - \code{8} = BB6 copula \cr - \code{9} = BB7 copula \cr - \code{10} = BB8 copula \cr - \code{13} = rotated Clayton copula (180 degrees; ``survival Clayton'') \cr - \code{14} = rotated Gumbel copula (180 degrees; ``survival Gumbel'') \cr - \code{16} = rotated Joe copula (180 degrees; ``survival Joe'') \cr - \code{17} = rotated BB1 copula (180 degrees; ``survival BB1'')\cr - \code{18} = rotated BB6 copula (180 degrees; ``survival BB6'')\cr - \code{19} = rotated BB7 copula (180 degrees; ``survival BB7'')\cr - \code{20} = rotated BB8 copula (180 degrees; ``survival BB8'')\cr - \code{23} = rotated Clayton copula (90 degrees) \cr - \code{24} = rotated Gumbel copula (90 degrees) \cr - \code{26} = rotated Joe copula (90 degrees) \cr - \code{27} = rotated BB1 copula (90 degrees) \cr - \code{28} = rotated BB6 copula (90 degrees) \cr - \code{29} = rotated BB7 copula (90 degrees) \cr - \code{30} = rotated BB8 copula (90 degrees) \cr - \code{33} = rotated Clayton copula (270 degrees) \cr - \code{34} = rotated Gumbel copula (270 degrees) \cr - \code{36} = rotated Joe copula (270 degrees) \cr - \code{37} = rotated BB1 copula (270 degrees) \cr - \code{38} = rotated BB6 copula (270 degrees) \cr - \code{39} = rotated BB7 copula (270 degrees) \cr - \code{40} = rotated BB8 copula (270 degrees) \cr - \code{104} = Tawn type 1 copula \cr - \code{114} = rotated Tawn type 1 copula (180 degrees) \cr - \code{124} = rotated Tawn type 1 copula (90 degrees) \cr - \code{134} = rotated Tawn type 1 copula (270 degrees) \cr - \code{204} = Tawn type 2 copula \cr - \code{214} = rotated Tawn type 2 copula (180 degrees) \cr - \code{224} = rotated Tawn type 2 copula (90 degrees) \cr - \code{234} = rotated Tawn type 2 copula (270 degrees) \cr - } - \item{type}{Type of the vine model to be specified:\cr - \code{0} or \code{"RVine"} = R-vine (default)\cr - \code{1} or \code{"CVine"} = C-vine\cr - C- and D-vine copula models with pre-specified order can be specified using \code{CDVineCopSelect} of the package CDVine. - Similarly, R-vine copula models with pre-specified tree structure can be specified using \code{\link{RVineCopSelect}}.} - \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}{Numerical; significance level of the independence test (default: \code{level = 0.05}).} - \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{ -R-vine trees are selected using maximum spanning trees with absolute values of pairwise Kendall's taus as weights, i.e., -the following optimization problem is solved for each tree: -\deqn{ -\max \sum_{edges\ e_{ij}\ in\ spanning\ tree} |\hat{\tau}_{ij}|, -}{ -\max \sum_{edges e_{ij} in spanning tree} |\hat{\tau}_{ij}|, -} -where \eqn{\hat{\tau}_{ij}} denote the pairwise empirical Kendall's taus and a spanning tree is a tree on all nodes. -The setting of the first tree selection step is always a complete graph. -For subsequent trees, the setting depends on the R-vine construction principles, in particular on the proximity condition. - -The root nodes of C-vine trees are determined similarly by identifying the node with strongest dependencies to all other nodes. -That is we take the node with maximum column sum in the empirical Kendall's tau matrix. - -Note that a possible way to determine the order of the nodes in the D-vine is to identify a shortest Hamiltonian path in terms -of weights \eqn{1-|\tau_{ij}|}. -This can be established for example using the package TSP. -Example code is shown below. -} - -\value{ - An \code{\link{RVineMatrix}} object with the selected structure (\code{RVM$Matrix}) and families (\code{RVM$family}) - as well as sequentially estimated parameters stored in \code{RVM$par} and \code{RVM$par2}. -} - -\references{ -Brechmann, E. C., C. Czado, and K. Aas (2012). -Truncated regular vines in high dimensions with applications to financial data. -Canadian Journal of Statistics 40 (1), 68-85. - -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{Jeffrey Dissmann, Eike Brechmann, Ulf Schepsmeier} - -\seealso{\code{\link{RVineTreePlot}}, \code{\link{RVineCopSelect}}} - -\examples{ -# load data set -data(daxreturns) - -# select the R-vine structure, families and parameters -# using only the first 4 variables and the first 750 observations -# we allow for the copula families: Gauss, t, Clayton, Gumbel, Frank and Joe -RVM <- RVineStructureSelect(daxreturns[1:750,1:4], c(1:6), progress = TRUE) - -\dontrun{ -# specify a C-vine copula model with only Clayton, Gumbel and Frank copulas (time-consuming) -CVM <- RVineStructureSelect2(daxreturns, c(3,4,5), "CVine") -} - -\dontrun{ -# determine the order of the nodes in a D-vine using the package TSP (time-consuming) -library(TSP) -d <- dim(daxreturns)[2] -M <- 1 - abs(TauMatrix(daxreturns)) -hamilton <- insert_dummy(TSP(M), label = "cut") -sol <- solve_TSP(hamilton, method = "repetitive_nn") -order <- cut_tour(sol, "cut") -DVM <- D2RVine(order, family = rep(0,d*(d-1)/2), par = rep(0, d*(d-1)/2)) -RVineCopSelect(daxreturns, c(1:6), DVM$Matrix) -} -} - Modified: pkg/man/RVineTreePlot.Rd =================================================================== --- pkg/man/RVineTreePlot.Rd 2015-09-17 12:09:57 UTC (rev 134) +++ pkg/man/RVineTreePlot.Rd 2015-09-17 12:24:05 UTC (rev 135) @@ -4,105 +4,37 @@ \title{Visualisation of R-Vine Tree Structure} \description{ -This function plots one or all trees of a given R-vine copula model. +Function is deprecated since \code{VineCopula 2.0}. Use \code{\link[VineCopula:plot.RVineMatrix]{plot.RVineMatrix}} instead. } \usage{ -RVineTreePlot(data = NULL, RVM, method = "mle", max.df = 30, - max.BB = list(BB1=c(5,6),BB6=c(6,6),BB7=c(5,6),BB8=c(6,1)), - tree = "ALL", edge.labels = c("family"), P = NULL, legend = FALSE) +RVineTreePlot(x, tree = "ALL", type = 0, edge.labels = NULL, legend.pos = "bottomleft", + interactive = FALSE, ...) } \arguments{ - \item{data}{An N x d data matrix (with uniform margins), default: \code{data = NULL}.} - \item{RVM}{An \code{\link{RVineMatrix}} object including the structure and the pair-copula families and parameters.} - \item{method}{Character indicating the estimation method: - either maximum likelihood estimation (\code{method = "mle"}; default) or inversion of Kendall's tau (\code{method = "itau"}).} - \item{max.df}{Numeric; upper bound for the estimation of the degrees of freedom parameter of the t-copula - (default: \code{max.df = 30}; for more details see \code{\link{BiCopEst}}).} - \item{max.BB}{List; upper bounds for the estimation of the two parameters (in absolute values) of the BB1, BB6, BB7 and BB8 copulas \cr - (default: \code{max.BB = list(BB1=c(5,6),BB6=c(6,6),BB7=c(5,6),BB8=c(6,1))}).} - \item{tree}{Number of the tree to be plotted or \code{tree = "ALL"} (default) to plot all trees.} - \item{edge.labels}{Vector of edge labels. Possible choices:\cr - \code{FALSE}: no edge labels\cr - \code{"family"}: pair-copula families (default)\cr - \code{"par"}: pair-copula parameters\cr - \code{"par2"}: second pair-copula parameters\cr - \code{"theotau"}: theoretical Kendall's tau values corresponding to pair-copula families and parameters (see \code{\link{BiCopPar2Tau}})\cr - \code{"emptau"}: empirical Kendall's tau values (only if data is provided!)\cr - \code{"pair"}: indices of (conditioned) pair of variables identified by the edges} - \item{P}{A list of matrices with two columns for the x-y-coordinates of the nodes in the plot(s) (optional; default: \code{P = NULL}).} - \item{legend}{If \code{TRUE} the variables are numbered from 1 to d and a legend is added to the plot(s). Otherwise node and edge lables are based on the variable names (default: \code{legend = FALSE}).} + \item{x}{\code{RVineMatrix} object.} + \item{tree}{\code{"ALL"} or integer vector; specifies which trees are plotted.} + \item{type}{integer; specifies how to make use of variable names: \cr + \code{0} = variable names are ignored, \cr + \code{1} = variable names are used to annotate vertices, \cr + \code{2} = uses numbers in plot and adds a legend for variable names.} + \item{edge.labels}{character; either a vector of edge labels + or one of the following: \cr + \code{"family"} = pair-copula family abbreviation (see \code{\link[VineCopula:BiCopName]{BiCopName}}), \cr + \code{"par"} = pair-copula parameters, \cr + \code{"tau"} = pair-copula Kendall's tau (by conversion of parameters) \cr + \code{"family-par"} = pair-copula family and parameters \cr + \code{"family-tau"} = pair-copula family and Kendall's tau. + } + \item{legend.pos}{the \code{x} argument for \code{\link[graphics:legend]{legend}}.} + \item{interactive}{logical; if TRUE, the user is asked to adjust the positioning of + vertices with his mouse.} + \item{\dots}{ +Arguments passed to \code{\link[network:plot.network]{plot.network}}.} } -\note{ -The function computes the positions of the nodes automatically with the Fruchterman-Reingold algorithm (see \code{\link{plot.igraph}} -for a detailed description). -If one would like to set the positions manually, one has to specify a list of matrices \code{P} in the argument list. -A good starting point may be to run the function \code{\link{RVineTreePlot}} and manipulate the returning matrix P. -If data is provided, the parameters of the R-vine copula model are estimated sequentially using \cr -\code{\link{RVineSeqEst}}/\code{\link{BiCopEst}}. -Then the edge width is chosen according to the empirical Kendall's tau values. Otherwise theoretical values are used. -} +\author{Thomas Nagler} -\value{ -A list of matrices \code{P} with two columns for the x-y-coordinates of the nodes in the plot(s). -} - -\author{Eike Brechmann} - -\seealso{\code{\link{BiCopName}}} - -\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")) - -# set random seed for testing -set.seed(123) - -# plot all trees with pair-copula families and -# theoretical Kendall's tau values as edge labels -P <- RVineTreePlot(data = NULL, RVM = RVM, tree = "ALL", - edge.labels = c("family","theotau"), - P = NULL) - -# manipulate the first matrix of x-y-coordinates -P[[1]][1,] = P[[1]][1,]*2 - -# re-set random seed for testing -set.seed(123) -# plot only the first tree with new coordinates -P <- RVineTreePlot(data = NULL, RVM = RVM, tree = 1, - edge.labels = FALSE, P = P) -} - +\seealso{\code{\link[VineCopula:plot.RVineMatrix]{plot.RVineMatrix}}} Modified: pkg/man/VineCopula-package.Rd =================================================================== --- pkg/man/VineCopula-package.Rd 2015-09-17 12:09:57 UTC (rev 134) +++ pkg/man/VineCopula-package.Rd 2015-09-17 12:24:05 UTC (rev 135) @@ -83,7 +83,7 @@ Date: \tab 2015-07-30\cr License: \tab GPL (>=2)\cr Depends: \tab R (\eqn{\geq 2.11.0}{>= 2.11.0})\cr -Imports: \tab graphics, grDevices, stats, utils, MASS, mvtnorm, igraph (>= 1.0.0), methods, copula, ADGofTest, lattice\cr +Imports: \tab graphics, grDevices, stats, utils, MASS, mvtnorm, network, methods, copula, ADGofTest, lattice\cr Suggests: \tab CDVine, TSP\cr LazyLoad: \tab yes } From noreply at r-forge.r-project.org Thu Sep 17 18:50:01 2015 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Thu, 17 Sep 2015 18:50:01 +0200 (CEST) Subject: [Vinecopula-commits] r136 - in pkg: R src Message-ID: <20150917165001.397B51869CE@r-forge.r-project.org> Author: tnagler Date: 2015-09-17 18:50:00 +0200 (Thu, 17 Sep 2015) New Revision: 136 Modified: pkg/R/BiCopTau2Par.r pkg/src/likelihood.c Log: * allow for zero parameter for Frank and Clayton BiCopPDF (so far only when check.pars = FALSE) and BiCopTau2Par Modified: pkg/R/BiCopTau2Par.r =================================================================== --- pkg/R/BiCopTau2Par.r 2015-09-17 12:24:05 UTC (rev 135) +++ pkg/R/BiCopTau2Par.r 2015-09-17 16:50:00 UTC (rev 136) @@ -34,32 +34,30 @@ } else if (family %in% 1:2) { par <- sin(pi * tau/2) } else if (family %in% c(3, 13)) { - if (tau <= 0) - stop("Clayton copula cannot be used for tau<=0.") + if (tau < 0) + stop("Clayton copula cannot be used for tau<0.") par <- 2 * tau/(1 - tau) } else if (family %in% c(4, 14)) { if (tau < 0) stop("Gumbel copula cannot be used for tau<0.") par <- 1/(1 - tau) } else if (family == 5) { - if (tau == 0) - stop("Frank copula cannot be used for tau=0.") - par <- Frank.itau.JJ(tau) + par <- if (tau == 0) 0 else Frank.itau.JJ(tau) } else if (family %in% c(6, 16)) { - if (tau <= 0) - stop("Joe copula cannot be used for tau<=0.") + if (tau < 0) + stop("Joe copula cannot be used for tau<0.") par <- Joe.itau.JJ(tau) } else if (family %in% c(23, 33)) { - if (tau >= 0) - stop("Rotated Clayton copula cannot be used for tau>=0.") + if (tau > 0) + stop("Rotated Clayton copula cannot be used for tau>0.") par <- 2 * tau/(1 + tau) } else if (family %in% c(24, 34)) { if (tau > 0) stop("Rotated Gumbel copula cannot be used for tau>0.") par <- -(1/(1 + tau)) } else if (family %in% c(26, 36)) { - if (tau >= 0) - stop("Rotated Joe copula cannot be used for tau>=0.") + if (tau > 0) + stop("Rotated Joe copula cannot be used for tau>0.") par <- -Joe.itau.JJ(-tau) } else if (family %in% c(41, 51)) { par <- ipsA.tau2cpar(tau) Modified: pkg/src/likelihood.c =================================================================== --- pkg/src/likelihood.c 2015-09-17 12:24:05 UTC (rev 135) +++ pkg/src/likelihood.c 2015-09-17 16:50:00 UTC (rev 136) @@ -1,14 +1,14 @@ /* -** likelihood.c - C code of the package CDRVine -** -** with contributions from Carlos Almeida, Aleksey Min, -** Ulf Schepsmeier, Jakob Stoeber and Eike Brechmann -** -** A first version was based on code -** from Daniel Berg -** provided by personal communication. -** -*/ + ** likelihood.c - C code of the package CDRVine + ** + ** with contributions from Carlos Almeida, Aleksey Min, + ** Ulf Schepsmeier, Jakob Stoeber and Eike Brechmann + ** + ** A first version was based on code + ** from Daniel Berg + ** provided by personal communication. + ** + */ #include "include/vine.h" #include "include/memoryhandling.h" @@ -35,57 +35,57 @@ // out outout ////////////////////////////////////////////////////////////// /* -void gen(double* u, int* n, double* param, int* copula, double* out) -{ - int j; - double *h; - h = Calloc(*n,double); + void gen(double* u, int* n, double* param, int* copula, double* out) + { + int j; + double *h; + h = Calloc(*n,double); + + for(j=0;j<*n;j++) + { + if(u[j]==0) h[j] = 0; + else if (u[j]==1) h[j] = u[j]; + else + { + if(*copula==3) //Clayton + { + h[j] = 1/param[0]*(pow(u[j],(-param[0]))-1); + } + if(*copula==4) //Gumbel + { + h[j] = pow((-log(u[j])),param[0]); + } + if(*copula==5) //Frank + { + h[j] = -log((exp(-param[0]*u[j])-1)/(exp(-param[0])-1)); + } + if(*copula==6) //Joe + { + h[j] = -log(1-pow((1-u[j]),param[0])); + } + if(*copula==7) //BB1 + { + h[j] = pow((pow(u[j],(-param[0]))-1),param[1]); + } + else if(*copula==8) //BB6 + { + h[j] = pow((-log(-pow(1-u[j],param[0])+1)),param[1]); + } + else if(*copula==9) //BB7 + { + h[j] = pow(1-pow(1-u[j],param[0]),-param[1])-1; + } + else if(*copula==10) //BB8 + { + h[j] = -log( (1-pow(1-param[1]*u[j],param[0])) / (1-pow(1-param[1],param[0])) ); + } + } + out[j]=h[j]; + } + Free(h); + } + */ - for(j=0;j<*n;j++) - { - if(u[j]==0) h[j] = 0; - else if (u[j]==1) h[j] = u[j]; - else - { - if(*copula==3) //Clayton - { - h[j] = 1/param[0]*(pow(u[j],(-param[0]))-1); - } - if(*copula==4) //Gumbel - { - h[j] = pow((-log(u[j])),param[0]); - } - if(*copula==5) //Frank - { - h[j] = -log((exp(-param[0]*u[j])-1)/(exp(-param[0])-1)); - } - if(*copula==6) //Joe - { - h[j] = -log(1-pow((1-u[j]),param[0])); - } - if(*copula==7) //BB1 - { - h[j] = pow((pow(u[j],(-param[0]))-1),param[1]); - } - else if(*copula==8) //BB6 - { - h[j] = pow((-log(-pow(1-u[j],param[0])+1)),param[1]); - } - else if(*copula==9) //BB7 - { - h[j] = pow(1-pow(1-u[j],param[0]),-param[1])-1; - } - else if(*copula==10) //BB8 - { - h[j] = -log( (1-pow(1-param[1]*u[j],param[0])) / (1-pow(1-param[1],param[0])) ); - } - } - out[j]=h[j]; - } - Free(h); -} -*/ - ////////////////////////////////////////////////////////////// // Inverse generator of BB1, BB6, BB7 and BB8 // Input: @@ -96,57 +96,57 @@ // out outout ////////////////////////////////////////////////////////////// /* -void genInv(double* u, int* n, double* param, int* copula, double* out) -{ - int j; - double *h; - h = Calloc(*n,double); + void genInv(double* u, int* n, double* param, int* copula, double* out) + { + int j; + double *h; + h = Calloc(*n,double); + + for(j=0;j<*n;j++) + { + if(u[j]==0) h[j] = 0; + else if (u[j]==1) h[j] = u[j]; + else + { + if(*copula==3) //Clayton + { + h[j] = pow((1+param[0]*u[j]),(-1/param[0])); + } + if(*copula==4) //Gumbel + { + h[j] = exp(-pow(u[j],1/param[0])); + } + if(*copula==5) //Frank + { + h[j] = -1/param[0]*log(1-exp(-u[j])*(1-exp(-param[0]))); + } + if(*copula==6) //Joe + { + h[j] = 1-pow((1-exp(-u[j])),1/param[0]); + } + if(*copula==7) //BB1 + { + h[j] = pow(1+pow(u[j],1/param[1]),(-1/param[0])); + } + else if(*copula==8) //BB6 + { + h[j] = 1-pow(1-exp(-pow(u[j],1/param[1])),1/param[0]); + } + else if(*copula==9) //BB7 + { + h[j] = 1-pow(1-pow(1+u[j],-1/param[1]),(1/param[0])); + } + else if(*copula==10) //BB8 + { + h[j] = 1/param[1] * ( 1-pow(1-(1-pow(1-param[1],param[0]))*exp(-u[j]),1/param[0]) ); + } + } + out[j]=h[j]; + } + Free(h); + } + */ - for(j=0;j<*n;j++) - { - if(u[j]==0) h[j] = 0; - else if (u[j]==1) h[j] = u[j]; - else - { - if(*copula==3) //Clayton - { - h[j] = pow((1+param[0]*u[j]),(-1/param[0])); - } - if(*copula==4) //Gumbel - { - h[j] = exp(-pow(u[j],1/param[0])); - } - if(*copula==5) //Frank - { - h[j] = -1/param[0]*log(1-exp(-u[j])*(1-exp(-param[0]))); - } - if(*copula==6) //Joe - { - h[j] = 1-pow((1-exp(-u[j])),1/param[0]); - } - if(*copula==7) //BB1 - { - h[j] = pow(1+pow(u[j],1/param[1]),(-1/param[0])); - } - else if(*copula==8) //BB6 - { - h[j] = 1-pow(1-exp(-pow(u[j],1/param[1])),1/param[0]); - } - else if(*copula==9) //BB7 - { - h[j] = 1-pow(1-pow(1+u[j],-1/param[1]),(1/param[0])); - } - else if(*copula==10) //BB8 - { - h[j] = 1/param[1] * ( 1-pow(1-(1-pow(1-param[1],param[0]))*exp(-u[j]),1/param[0]) ); - } - } - out[j]=h[j]; - } - Free(h); -} -*/ - ////////////////////////////////////////////////////////////// // First derivative of the generator of BB1, BB2 and BB7 // Input: @@ -157,40 +157,40 @@ // out outout ////////////////////////////////////////////////////////////// /* -void genDrv(double* u, int* n, double* param, int* copula, double* out) -{ - int j; - double *h; - h = Calloc(*n,double); - - for(j=0;j<*n;j++) - { - if(u[j]==0) h[j] = 0; - else if (u[j]==1) h[j] = u[j]; - else - { - if(*copula==7) //BB1 - { - h[j] = -(param[0]*param[1])*pow(pow(u[j],-param[0])-1,param[1]-1)*pow(u[j],-1-param[0]); - } - else if(*copula==8) //BB6 - { - h[j] = pow(-log(-pow(1-u[j],param[0])+1),param[1]-1) * param[1] * pow(1-u[j],param[0]-1) * param[0] / (pow(1-u[j],param[0])-1); - } - else if(*copula==9) //BB7 - { - h[j] = -(param[0]*param[1])*pow(1-u[j],param[0]-1)*pow(1-pow(1-u[j],param[0]),-1-param[1]); - } - else if(*copula==10) //BB8 - { - h[j] = -param[0] * param[1] * ( pow(1-param[1]*u[j],param[0]-1) ) / ( 1-pow(1-param[1]*u[j],param[0]) ); - } - } - out[j]=h[j]; - } - Free(h); -} -*/ + void genDrv(double* u, int* n, double* param, int* copula, double* out) + { + int j; + double *h; + h = Calloc(*n,double); + + for(j=0;j<*n;j++) + { + if(u[j]==0) h[j] = 0; + else if (u[j]==1) h[j] = u[j]; + else + { + if(*copula==7) //BB1 + { + h[j] = -(param[0]*param[1])*pow(pow(u[j],-param[0])-1,param[1]-1)*pow(u[j],-1-param[0]); + } + else if(*copula==8) //BB6 + { + h[j] = pow(-log(-pow(1-u[j],param[0])+1),param[1]-1) * param[1] * pow(1-u[j],param[0]-1) * param[0] / (pow(1-u[j],param[0])-1); + } + else if(*copula==9) //BB7 + { + h[j] = -(param[0]*param[1])*pow(1-u[j],param[0]-1)*pow(1-pow(1-u[j],param[0]),-1-param[1]); + } + else if(*copula==10) //BB8 + { + h[j] = -param[0] * param[1] * ( pow(1-param[1]*u[j],param[0]-1) ) / ( 1-pow(1-param[1]*u[j],param[0]) ); + } + } + out[j]=h[j]; + } + Free(h); + } + */ ////////////////////////////////////////////////////////////// // Second derivative of the generator of BB1, BB6, BB7 and BB8 @@ -202,47 +202,47 @@ // out outout ////////////////////////////////////////////////////////////// /* -void genDrv2(double* u, int* n, double* param, int* copula, double* out) -{ - int j; - double *h; - h = Calloc(*n,double); - - for(j=0;j<*n;j++) - { - if(u[j]==0) h[j] = 0; - else if (u[j]==1) h[j] = u[j]; - else - { - if(*copula==7) //BB1 - { - h[j] = param[0]*param[1]*pow(u[j],-2-param[0])*pow(pow(u[j],-param[0])-1,param[1]-2)*((1+param[0]*param[1])*pow(u[j],-param[0])-param[0]-1); - } - else if(*copula==8) //BB6 - { - h[j] = ( param[0]*param[1] * ( - pow(-log(-pow(1-u[j],param[0])+1),param[1]-2) * pow(1-u[j],2*param[0]-2) * param[0]*param[1] - - pow(-log(-pow(1-u[j],param[0])+1),param[1]-2) * pow(1-u[j],2*param[0]-2) * param[0] - - pow(-log(-pow(1-u[j],param[0])+1),param[1]-1) * pow(1-u[j],param[0]-2) * param[0] - - pow(-log(-pow(1-u[j],param[0])+1),param[1]-1) * pow(1-u[j],2*param[0]-2) + - pow(-log(-pow(1-u[j],param[0])+1),param[1]-1) * pow(1-u[j],param[0]-2) ) ) / pow(pow(1-u[j],param[0])-1,2); - } - else if(*copula==9) //BB7 - { - h[j] = param[0]*param[1]*pow(1-u[j],param[0]-2)*pow(1-pow(1-u[j],param[0]),-2-param[1])*((1+param[0]*param[1])*pow(1-u[j],param[0])+param[0]-1); - } - else if(*copula==10) //BB8 - { - h[j] = ( pow(param[1],2) * param[0] * - (pow(1-u[j]*param[1],param[0]-2) * param[0] + pow(1-u[j]*param[1],2*param[0]-2) - pow(1-u[j]*param[1],param[0]-2)) ) / - ( pow(pow(1-u[j]*param[1],param[0])-1,2) ); - } - } - out[j]=h[j]; - } - Free(h); -} -*/ + void genDrv2(double* u, int* n, double* param, int* copula, double* out) + { + int j; + double *h; + h = Calloc(*n,double); + + for(j=0;j<*n;j++) + { + if(u[j]==0) h[j] = 0; + else if (u[j]==1) h[j] = u[j]; + else + { + if(*copula==7) //BB1 + { + h[j] = param[0]*param[1]*pow(u[j],-2-param[0])*pow(pow(u[j],-param[0])-1,param[1]-2)*((1+param[0]*param[1])*pow(u[j],-param[0])-param[0]-1); + } + else if(*copula==8) //BB6 + { + h[j] = ( param[0]*param[1] * ( + pow(-log(-pow(1-u[j],param[0])+1),param[1]-2) * pow(1-u[j],2*param[0]-2) * param[0]*param[1] - + pow(-log(-pow(1-u[j],param[0])+1),param[1]-2) * pow(1-u[j],2*param[0]-2) * param[0] - + pow(-log(-pow(1-u[j],param[0])+1),param[1]-1) * pow(1-u[j],param[0]-2) * param[0] - + pow(-log(-pow(1-u[j],param[0])+1),param[1]-1) * pow(1-u[j],2*param[0]-2) + + pow(-log(-pow(1-u[j],param[0])+1),param[1]-1) * pow(1-u[j],param[0]-2) ) ) / pow(pow(1-u[j],param[0])-1,2); + } + else if(*copula==9) //BB7 + { + h[j] = param[0]*param[1]*pow(1-u[j],param[0]-2)*pow(1-pow(1-u[j],param[0]),-2-param[1])*((1+param[0]*param[1])*pow(1-u[j],param[0])+param[0]-1); + } + else if(*copula==10) //BB8 + { + h[j] = ( pow(param[1],2) * param[0] * + (pow(1-u[j]*param[1],param[0]-2) * param[0] + pow(1-u[j]*param[1],2*param[0]-2) - pow(1-u[j]*param[1],param[0]-2)) ) / + ( pow(pow(1-u[j]*param[1],param[0])-1,2) ); + } + } + out[j]=h[j]; + } + Free(h); + } + */ ////////////////////////////////////////////////////////////// // Copula of BB1, BB6, BB7 and BB8 @@ -255,27 +255,27 @@ // out outout ////////////////////////////////////////////////////////////// /* -void copCdf(double* u, double* v, int* n, double* param, int* copula, double* out) -{ - int j; - double *out1; - double *out2; - double *out3; - out1 = Calloc(*n,double); - out2 = Calloc(*n,double); - out3 = Calloc(*n,double); - gen(u, n, param, copula, out1); - gen(v, n, param, copula, out2); - for(j=0;j<*n;j++) - { - out3[j]=out1[j]+out2[j]; - } - genInv(out3 , n, param, copula, out); - Free(out1); - Free(out2); - Free(out3); -} -*/ + void copCdf(double* u, double* v, int* n, double* param, int* copula, double* out) + { + int j; + double *out1; + double *out2; + double *out3; + out1 = Calloc(*n,double); + out2 = Calloc(*n,double); + out3 = Calloc(*n,double); + gen(u, n, param, copula, out1); + gen(v, n, param, copula, out2); + for(j=0;j<*n;j++) + { + out3[j]=out1[j]+out2[j]; + } + genInv(out3 , n, param, copula, out); + Free(out1); + Free(out2); + Free(out3); + } + */ ////////////////////////////////////////////////////////////// // Copula density of BB1, BB6, BB7 and BB8 @@ -288,183 +288,183 @@ // out outout ////////////////////////////////////////////////////////////// /* -void copPdf(double* u, double* v, int* n, double* param, int* copula, double* out) -{ - int j; - double *out1, *out2, *out3, *out4, *out5; - out1 = Calloc(*n,double); - out2 = Calloc(*n,double); - out3 = Calloc(*n,double); - out4 = Calloc(*n,double); - out5 = Calloc(*n,double); - copCdf(u,v,n,param,copula,out1); - genDrv2(out1,n,param,copula,out2); - genDrv(u,n,param,copula,out3); - genDrv(v,n,param,copula,out4); - genDrv(out1,n,param,copula,out5); - for(j=0;j<*n;j++) - { - out[j]=-(out2[j]*out3[j]*out4[j])/pow(out5[j],3); - } - Free(out1); - Free(out2); - Free(out3); - Free(out4); - Free(out5); -} -*/ + void copPdf(double* u, double* v, int* n, double* param, int* copula, double* out) + { + int j; + double *out1, *out2, *out3, *out4, *out5; + out1 = Calloc(*n,double); + out2 = Calloc(*n,double); + out3 = Calloc(*n,double); + out4 = Calloc(*n,double); + out5 = Calloc(*n,double); + copCdf(u,v,n,param,copula,out1); + genDrv2(out1,n,param,copula,out2); + genDrv(u,n,param,copula,out3); + genDrv(v,n,param,copula,out4); + genDrv(out1,n,param,copula,out5); + for(j=0;j<*n;j++) + { + out[j]=-(out2[j]*out3[j]*out4[j])/pow(out5[j],3); + } + Free(out1); + Free(out2); + Free(out3); + Free(out4); + Free(out5); + } + */ /////////////////////////////////////////////////////// // New double log1mexp(double a) { - double result; -if (aUMAX && v[j]>UMAX){ out[j]=1;} - else if(u[j]>UMAX){ out[j]=v[j];} - else if(v[j]>UMAX){ out[j]=u[j];} - else if(u[j]0) { - t1=-log1p(exp(-param[0]) * expm1(param[0]-u[j]*param[0])/expm1(-param[0])); - t2=-log1p(exp(-param[0]) * expm1(param[0]-v[j]*param[0])/expm1(-param[0])); - out[j] = -log1mexp(t1+t2-log1mexp(param[0]))/param[0]; - } else { - out[j] =-1/param[0] * log(1 + exp(-(-log((exp(-param[0] * u[j]) - 1)/(exp(-param[0]) - 1)) + -log((exp(-param[0] * v[j]) - 1)/(exp(-param[0]) - 1)))) * (exp(-param[0]) - 1)); - } - } - else if(*copula==6) //Joe - { - t1 = 1-u[j]; - t2 = 1-v[j]; - t3 = pow(t1,param[0]); - t4 = pow(t2,param[0]); - t5 = t3*t4; - out[j] = 1-pow(t3+t4-t5,1/param[0]); - } - else if(*copula==7) //BB1 - { - t1 = pow(u[j],-param[0]); - t2 = pow(v[j],-param[0]); - t3 = t1-1; - t4 = t2-1; - t5 = pow(t3,param[1]); - t6 = pow(t4,param[1]); - t7 = t5+t6; - t8 = pow(t7,1/param[1]); - out[j] = pow(1+t8,-1/param[0]); - } - else if(*copula==8) //BB6 - { - t1 = 1-u[j]; - t2 = 1-v[j]; - t3 = pow(t1,param[0]); - t4 = pow(t2,param[0]); - t5 = 1-t3; - t6 = 1-t4; - t7 = -log(t5); - t8 = -log(t6); - t9 = pow(t7,param[1]); - t10 = pow(t8,param[1]); - t11 = t9+t10; - t12 = pow(t11,1/param[1]); - t13 = exp(-t12); - t14 = 1-t13; - out[j] = 1-pow(t14,1/param[0]); - } - else if(*copula==9) //BB7 - { - t1 = 1-u[j]; - t2 = 1-v[j]; - t3 = pow(t1,param[0]); - t4 = pow(t2,param[0]); - t5 = 1-t3; - t6 = 1-t4; - t7 = pow(t5,-param[1]); - t8 = pow(t6,-param[1]); - t9 = t7+t8-1; - t10 = pow(t9,-1/param[1]); - t11 = 1-t10; - t12 = pow(t11,1/param[0]); - out[j] = 1-t12; - } - else if(*copula==10) //BB8 + int j; + double t1, t2, t3, t4, t5, t6, t7, t8, t9, t10, t11, t12, t13, t14; + + for(j=0;j<*n;j++) + { + if(u[j]>UMAX && v[j]>UMAX){ out[j]=1;} + else if(u[j]>UMAX){ out[j]=v[j];} + else if(v[j]>UMAX){ out[j]=u[j];} + else if(u[j]0) { + t1=-log1p(exp(-param[0]) * expm1(param[0]-u[j]*param[0])/expm1(-param[0])); + t2=-log1p(exp(-param[0]) * expm1(param[0]-v[j]*param[0])/expm1(-param[0])); + out[j] = -log1mexp(t1+t2-log1mexp(param[0]))/param[0]; + } else { + out[j] =-1/param[0] * log(1 + exp(-(-log((exp(-param[0] * u[j]) - 1)/(exp(-param[0]) - 1)) + -log((exp(-param[0] * v[j]) - 1)/(exp(-param[0]) - 1)))) * (exp(-param[0]) - 1)); + } + } + else if(*copula==6) //Joe + { + t1 = 1-u[j]; + t2 = 1-v[j]; + t3 = pow(t1,param[0]); + t4 = pow(t2,param[0]); + t5 = t3*t4; + out[j] = 1-pow(t3+t4-t5,1/param[0]); + } + else if(*copula==7) //BB1 + { + t1 = pow(u[j],-param[0]); + t2 = pow(v[j],-param[0]); + t3 = t1-1; + t4 = t2-1; + t5 = pow(t3,param[1]); + t6 = pow(t4,param[1]); + t7 = t5+t6; + t8 = pow(t7,1/param[1]); + out[j] = pow(1+t8,-1/param[0]); + } + else if(*copula==8) //BB6 + { + t1 = 1-u[j]; + t2 = 1-v[j]; + t3 = pow(t1,param[0]); + t4 = pow(t2,param[0]); + t5 = 1-t3; + t6 = 1-t4; + t7 = -log(t5); + t8 = -log(t6); + t9 = pow(t7,param[1]); + t10 = pow(t8,param[1]); + t11 = t9+t10; + t12 = pow(t11,1/param[1]); + t13 = exp(-t12); + t14 = 1-t13; + out[j] = 1-pow(t14,1/param[0]); + } + else if(*copula==9) //BB7 + { + t1 = 1-u[j]; + t2 = 1-v[j]; + t3 = pow(t1,param[0]); + t4 = pow(t2,param[0]); + t5 = 1-t3; + t6 = 1-t4; + t7 = pow(t5,-param[1]); + t8 = pow(t6,-param[1]); + t9 = t7+t8-1; + t10 = pow(t9,-1/param[1]); + t11 = 1-t10; + t12 = pow(t11,1/param[0]); + out[j] = 1-t12; + } + else if(*copula==10) //BB8 + { + double nu; + t1 = param[1]*u[j]; + t2 = param[1]*v[j]; + t3 = 1-t1; + t4 = 1-t2; + t5 = pow(t3,param[0]); + t6 = pow(t4,param[0]); + t7 = 1-t5; + t8 = 1-t6; + nu = 1-param[1]; + nu = pow(nu,param[0]); + nu = 1-nu; + nu = 1/nu; + t9 = 1-nu*t7*t8; + t10 = pow(t9,1/param[0]); + out[j] = 1/param[1]*(1-t10); + } + else if(*copula==41) + { + t1=qgamma(1.0-u[j],param[0],1,1,0); + t2=qgamma(1.0-v[j],param[0],1,1,0); + t3=pow(pow(t1,param[0])+pow(t2,param[0]),(1.0/param[0])); + out[j]=1.0-pgamma(t3,param[0],1,1,0); + } } - else if(*copula==41) - { - t1=qgamma(1.0-u[j],param[0],1,1,0); - t2=qgamma(1.0-v[j],param[0],1,1,0); - t3=pow(pow(t1,param[0])+pow(t2,param[0]),(1.0/param[0])); - out[j]=1.0-pgamma(t3,param[0],1,1,0); - } - } - } - + } + } @@ -473,197 +473,197 @@ void dbb1(double* u, double* v, int* n, double* param, double* out) { - int i; - double th, de; - double t1, t2, t3, t16, t17, t38, t39, t4, t5, t6, t7, t9, t10, t12, t13, t20, t24, t25, t27, t29, t32, t33, t34, t36, t43, t59; - - th = param[0]; - de = param[1]; - - for(i=0;i<*n;i++) - { - t1 = pow(u[i],(-th)); - t2 = t1-1.0; - t3 = pow(t2,de); - t16 = 1./u[i]; - t17 = 1./t2; - t38 = t1*t16; - t39 = t38*t17; - t4 = pow(v[i],(-th)); - t5 = t4-1.0; - t6 = pow(t5,de); - t7 = t3+t6; - t9 = pow(t7,(1./de)); - t10 = 1.0+t9; - t12 = pow(t10,(-1./th)); - t13 = t12*t9; - t20 = 1./t10; - t24 = t9*t9; - t25 = t12*t24; - t27 = 1./v[i]; - t29 = 1./t5; - t32 = t7*t7; - t33 = 1./t32; - t34 = t10*t10; - t36 = t33/t34; - t43 = t4*th; - t59 = t43*t27*t29; - - out[i] = t25*t6*t27*t4*t29*t36*t3*t39-t13*t6*t43*t27*t29*t33*t3*t38*t17*t20+ - t13*t3*t38*t17*t33*t20*t6*de*t59+t25*t3*t39*t36*t6*t59; - } - + int i; + double th, de; + double t1, t2, t3, t16, t17, t38, t39, t4, t5, t6, t7, t9, t10, t12, t13, t20, t24, t25, t27, t29, t32, t33, t34, t36, t43, t59; + + th = param[0]; + de = param[1]; + + for(i=0;i<*n;i++) + { + t1 = pow(u[i],(-th)); + t2 = t1-1.0; + t3 = pow(t2,de); + t16 = 1./u[i]; + t17 = 1./t2; + t38 = t1*t16; + t39 = t38*t17; + t4 = pow(v[i],(-th)); + t5 = t4-1.0; + t6 = pow(t5,de); + t7 = t3+t6; + t9 = pow(t7,(1./de)); + t10 = 1.0+t9; + t12 = pow(t10,(-1./th)); + t13 = t12*t9; + t20 = 1./t10; + t24 = t9*t9; + t25 = t12*t24; + t27 = 1./v[i]; + t29 = 1./t5; + t32 = t7*t7; + t33 = 1./t32; + t34 = t10*t10; + t36 = t33/t34; + t43 = t4*th; + t59 = t43*t27*t29; + + out[i] = t25*t6*t27*t4*t29*t36*t3*t39-t13*t6*t43*t27*t29*t33*t3*t38*t17*t20+ + t13*t3*t38*t17*t33*t20*t6*de*t59+t25*t3*t39*t36*t6*t59; + } + } void dbb6(double* u, double* v, int* n, double* param, double* out) { - int i; - double th, de; - double t1, t2, t3, t4, t5, t12, t16, t32, t38, t39, t40, t47, t50, t61, t90, t6, t7, t8, t9, t10, t11, t13, t14, t35, t36, t37, t42, t48, t53, t56, t57, t59, t78, t80, t87, t93; - - th = param[0]; - de = param[1]; - - for(i=0;i<*n;i++) - { - t1 = 1.0-u[i]; - t2 = pow(t1,th); - t3 = 1.0-t2; - t4 = log(t3); - t5 = pow(-t4,de); - t12 = 1/de; - t16 = 1/th; - t32 = de-1.0; - t38 = 2.0*de; - t39 = -1.0+t38; - t40 = pow(-t4,t39); - t47 = 3.0*de-1.0; - t50 = pow(-t4,t32); - t61 = pow(-t4,t47); - t90 = pow(-t4,t38); - t6 = 1.0-v[i]; - t7 = pow(t6,th); - t8 = 1.0-t7; - t9 = log(t8); - t10 = pow(-t9,de); - t11 = t5+t10; - t13 = pow(t11,t12); - t14 = exp(-t13); - //t15 = 1.0-t14; - //t17 = pow(t15,t16); - t35 = pow(t11,-2.0*t32*t12); - t36 = t35*th; - t37 = exp(t13); - t42 = pow(-t9,t39); - t48 = pow(-t9,t47); - t53 = t13*de; - t56 = pow(-t9,t32); - t57 = t37*t50*t56; - t59 = t13*th; - t78 = t37-1.0; - t80 = pow(t78*t14,t16); - t87 = t78*t78; - t93 = pow(-t9,t38); - - out[i] = (2.0*t36*t37*t40*t42+t36*t37*t48*t50+t53*th*t57-t59*t57+ - t36*t37*t61*t56-2.0*t35*t40*t42-t35*t61*t56-t53*th*t50*t56+t59*t50*t56- - t35*t48*t50) *t80*t7*t2/t3/t8/t87/(t90+2.0*t5*t10+t93)/t1/t6; - } - + int i; + double th, de; + double t1, t2, t3, t4, t5, t12, t16, t32, t38, t39, t40, t47, t50, t61, t90, t6, t7, t8, t9, t10, t11, t13, t14, t35, t36, t37, t42, t48, t53, t56, t57, t59, t78, t80, t87, t93; + + th = param[0]; + de = param[1]; + + for(i=0;i<*n;i++) + { + t1 = 1.0-u[i]; + t2 = pow(t1,th); + t3 = 1.0-t2; + t4 = log(t3); + t5 = pow(-t4,de); + t12 = 1/de; + t16 = 1/th; + t32 = de-1.0; + t38 = 2.0*de; + t39 = -1.0+t38; + t40 = pow(-t4,t39); + t47 = 3.0*de-1.0; + t50 = pow(-t4,t32); + t61 = pow(-t4,t47); + t90 = pow(-t4,t38); + t6 = 1.0-v[i]; + t7 = pow(t6,th); + t8 = 1.0-t7; + t9 = log(t8); + t10 = pow(-t9,de); + t11 = t5+t10; + t13 = pow(t11,t12); + t14 = exp(-t13); + //t15 = 1.0-t14; + //t17 = pow(t15,t16); + t35 = pow(t11,-2.0*t32*t12); + t36 = t35*th; + t37 = exp(t13); + t42 = pow(-t9,t39); + t48 = pow(-t9,t47); + t53 = t13*de; + t56 = pow(-t9,t32); + t57 = t37*t50*t56; + t59 = t13*th; + t78 = t37-1.0; + t80 = pow(t78*t14,t16); + t87 = t78*t78; + t93 = pow(-t9,t38); + + out[i] = (2.0*t36*t37*t40*t42+t36*t37*t48*t50+t53*th*t57-t59*t57+ + t36*t37*t61*t56-2.0*t35*t40*t42-t35*t61*t56-t53*th*t50*t56+t59*t50*t56- + t35*t48*t50) *t80*t7*t2/t3/t8/t87/(t90+2.0*t5*t10+t93)/t1/t6; + } + } void dbb7(double* u, double* v, int* n, double* param, double* out) { - int i; - double th, de; - double t1, t2, t3, t4, t5, t6, t7, t8, t9, t11, t12, t14, t15, t16, t18, t20, t23, t24, t25, t27, t30, t31, t32, t35, t37, t42, t54; - - th = param[0]; - de = param[1]; - - for(i=0;i<*n;i++) - { - t1 = 1.0-u[i]; - t2 = pow(t1,th); - t3 = 1.0-t2; - t4 = pow(t3,-de); - t5 = 1.0-v[i]; - t6 = pow(t5,th); - t7 = 1.0-t6; - t8 = pow(t7,-de); - t9 = t4+t8-1.0; - t11 = pow(t9,-1.0/de); - t12 = 1.0-t11; - t14 = pow(t12,1.0/th); - t15 = t11*t11; - t16 = t14*t15; - t18 = 1./t5; - t20 = 1./t7; - t23 = t9*t9; - t24 = 1./t23; - t25 = t12*t12; - t27 = t24/t25; - t30 = t2/t1; - t31 = 1./t3; - t32 = t30*t31; - t35 = t14*t11; - t37 = t6*th; - t42 = 1./t12; - t54 = t37*t18*t20; - - out[i] = -t16*t8*t6*t18*t20*t27*t4*t32 + t35*t8*t37*t18*t20*t24*t4*t30*t31*t42+ - t35*t4*t30*t31*t24*t42*t8*de*t54+t16*t4*t32*t27*t8*t54; - } - + int i; + double th, de; + double t1, t2, t3, t4, t5, t6, t7, t8, t9, t11, t12, t14, t15, t16, t18, t20, t23, t24, t25, t27, t30, t31, t32, t35, t37, t42, t54; + + th = param[0]; + de = param[1]; + + for(i=0;i<*n;i++) + { + t1 = 1.0-u[i]; + t2 = pow(t1,th); + t3 = 1.0-t2; + t4 = pow(t3,-de); + t5 = 1.0-v[i]; + t6 = pow(t5,th); + t7 = 1.0-t6; + t8 = pow(t7,-de); + t9 = t4+t8-1.0; + t11 = pow(t9,-1.0/de); + t12 = 1.0-t11; + t14 = pow(t12,1.0/th); + t15 = t11*t11; + t16 = t14*t15; + t18 = 1./t5; + t20 = 1./t7; + t23 = t9*t9; + t24 = 1./t23; + t25 = t12*t12; + t27 = t24/t25; + t30 = t2/t1; + t31 = 1./t3; + t32 = t30*t31; + t35 = t14*t11; + t37 = t6*th; + t42 = 1./t12; + t54 = t37*t18*t20; + + out[i] = -t16*t8*t6*t18*t20*t27*t4*t32 + t35*t8*t37*t18*t20*t24*t4*t30*t31*t42+ + t35*t4*t30*t31*t24*t42*t8*de*t54+t16*t4*t32*t27*t8*t54; + } + } void dbb8(double* u, double* v, int* n, double* param, double* out) { - int i; - double th, de; - double t2, t3, t12, t16, t6, t7, t10, t11, t33, t38, t39, t49, t59, t69, t25, t26, t29, t44, t45, t50, t54, t62, t67; - - th = param[0]; - de = param[1]; - - for(i=0;i<*n;i++) - { - t2 = 1.0-de*u[i]; - t3 = pow(t2,th); - //t4 = 1.0-t3; - t10 = 1.0-de; - t11 = pow(t10,th); - t12 = 1.0-t11; - //t13 = 1/t12; - t16 = 1/th; - t33 = th*t3; - t38 = 2.0*th; - t39 = pow(t10,t38); - t49 = pow(t2,t38); - t59 = pow(t10,3.0*th); - t69 = t12*t12; - t6 = 1.0-de*v[i]; - t7 = pow(t6,th); - //t8 = 1.0-t7; - //t15 = 1.0-(1.0-t3)*t8*t13; - //t17 = pow(t15,t16); - t25 = t3*t7; - t26 = t11-t7-t3+t25; - t29 = pow(-t26/t12,t16); - t44 = pow(t6,t38); - t45 = t3*t44; - t50 = t49*t7; - t54 = t49*t44; - t62 = -2.0*t25*t11+t25-t33*t7+3.0*t33*t7*t11-3.0*t33*t7*t39+t25*t39+ - 2.0* t45*t11-t45*t39+2.0*t50*t11-t50*t39-2.0*t54*t11+t54*t39+t54- - t50-t45+t33*t7*t59; - t67 = t26*t26; - out[i] = -de*t29*t62/t6/t2/t67/t69; - } - + int i; + double th, de; + double t2, t3, t12, t16, t6, t7, t10, t11, t33, t38, t39, t49, t59, t69, t25, t26, t29, t44, t45, t50, t54, t62, t67; + + th = param[0]; + de = param[1]; + + for(i=0;i<*n;i++) + { + t2 = 1.0-de*u[i]; + t3 = pow(t2,th); + //t4 = 1.0-t3; + t10 = 1.0-de; + t11 = pow(t10,th); + t12 = 1.0-t11; + //t13 = 1/t12; + t16 = 1/th; + t33 = th*t3; + t38 = 2.0*th; + t39 = pow(t10,t38); + t49 = pow(t2,t38); + t59 = pow(t10,3.0*th); + t69 = t12*t12; + t6 = 1.0-de*v[i]; + t7 = pow(t6,th); + //t8 = 1.0-t7; + //t15 = 1.0-(1.0-t3)*t8*t13; + //t17 = pow(t15,t16); + t25 = t3*t7; + t26 = t11-t7-t3+t25; + t29 = pow(-t26/t12,t16); + t44 = pow(t6,t38); + t45 = t3*t44; + t50 = t49*t7; + t54 = t49*t44; + t62 = -2.0*t25*t11+t25-t33*t7+3.0*t33*t7*t11-3.0*t33*t7*t39+t25*t39+ + 2.0* t45*t11-t45*t39+2.0*t50*t11-t50*t39-2.0*t54*t11+t54*t39+t54- + t50-t45+t33*t7*t59; + t67 = t26*t26; + out[i] = -de*t29*t62/t6/t2/t67/t69; + } + } @@ -681,153 +681,153 @@ ////////////////////////////////////////////////////////////// /* -void LL_mod(int* family, int* n, double* u, double* v, double* theta, double* nu, double* loglik) -{ - double* negv; - double* negu; - negv = (double *) malloc(*n*sizeof(double)); - negu = (double *) malloc(*n*sizeof(double)); - double ntheta, nnu; - int nfamily; - ntheta = -*theta; - nnu = -*nu; + void LL_mod(int* family, int* n, double* u, double* v, double* theta, double* nu, double* loglik) + { + double* negv; + double* negu; + negv = (double *) malloc(*n*sizeof(double)); + negu = (double *) malloc(*n*sizeof(double)); + double ntheta, nnu; + int nfamily; + ntheta = -*theta; + nnu = -*nu; + + for(int i=0;i<*n;i++) + { + if(u[i]UMAX) u[i]=UMAX; + if(v[i]UMAX) v[i]=UMAX; + } + + if((*family==43)) + { + nfamily=3; + if(*theta > 0){ + ntheta=2*(*theta)/(1-*theta); + LL(&nfamily, n, u, v, &ntheta, nu, loglik); + }else{ + ntheta=-2*(*theta)/(1+*theta); + for (int i = 0; i < *n; ++i) {negv[i]=1 - v[i];} + LL(&nfamily, n, u, negv, &ntheta, &nnu, loglik); + } + }else if((*family==44)) + { + nfamily=4; + if(*theta > 0){ + ntheta=1/(1-*theta); + LL(&nfamily, n, u, v, &ntheta, nu, loglik); + }else{ + ntheta=1/(1+*theta); + for (int i = 0; i < *n; ++i) {negv[i]=1 - v[i];} + LL(&nfamily, n, u, negv, &ntheta, &nnu, loglik); + } + }else{ + if((*family==23) | (*family==24) | (*family==26) | (*family==27) | (*family==28) | (*family==29) | (*family==30) | (*family==61)) // 90? rotated copulas + { + nfamily = (*family)-20; [TRUNCATED] To get the complete diff run: svnlook diff /svnroot/vinecopula -r 136 From noreply at r-forge.r-project.org Thu Sep 17 19:30:45 2015 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Thu, 17 Sep 2015 19:30:45 +0200 (CEST) Subject: [Vinecopula-commits] r137 - in pkg: R man Message-ID: <20150917173045.D1561187B7D@r-forge.r-project.org> Author: tnagler Date: 2015-09-17 19:30:45 +0200 (Thu, 17 Sep 2015) New Revision: 137 Modified: pkg/R/BiCopCheck.R pkg/R/BiCopTau2Par.r pkg/man/BiCopTau2Par.Rd Log: * added BiCopCheckTaus function * added check.taus option to BiCopTau2Par.Rd * adjusted manual accordingly Modified: pkg/R/BiCopCheck.R =================================================================== --- pkg/R/BiCopCheck.R 2015-09-17 16:50:00 UTC (rev 136) +++ pkg/R/BiCopCheck.R 2015-09-17 17:30:45 UTC (rev 137) @@ -94,4 +94,28 @@ ## return TRUE if all checks pass TRUE +} + +BiCopCheckTaus <- function(family, tau) { + ## check for family/tau consistency + checkTaus<- function(x) { + if (family %in% c(3, 13) && tau <= 0) + stop("Clayton copula cannot be used for tau<=0.") + if (family %in% c(4, 14) && tau < 0) + stop("Gumbel copula cannot be used for tau<0.") + if (family == 5 && tau == 0) + stop("Frank copula cannot be used for tau=0") + if (family %in% c(6, 16) && tau < 0) + stop("Joe copula cannot be used for tau<0.") + if (family %in% c(23, 33) && tau >= 0) + stop("Rotated Clayton copula cannot be used for tau>=0.") + if (family %in% c(24, 34) && tau > 0) + stop("Rotated Gumbel copula cannot be used for tau>0.") + if (family %in% c(26, 36) && tau > 0) + stop("Rotated Joe copula cannot be used for tau>0.") + } + apply(cbind(family, tau), 1, checkTaus) + + ## return TRUE if all checks pass + TRUE } \ No newline at end of file Modified: pkg/R/BiCopTau2Par.r =================================================================== --- pkg/R/BiCopTau2Par.r 2015-09-17 16:50:00 UTC (rev 136) +++ pkg/R/BiCopTau2Par.r 2015-09-17 17:30:45 UTC (rev 137) @@ -1,4 +1,4 @@ -BiCopTau2Par <- function(family, tau) { +BiCopTau2Par <- function(family, tau, check.taus = TRUE) { ## sanity check if (any(abs(tau) > 0.99999)) stop("some tau is too close to -1 or 1") @@ -12,6 +12,11 @@ if (!all(c(length(family), length(tau)) %in% c(1, n))) stop("Input lenghts don't match") + ## check for family/tau consistency + if (check.taus) + BiCopCheckTaus(family, tau) + + ## calculate the parameter if (length(tau) == 1) { # call for single parameters @@ -34,30 +39,18 @@ } else if (family %in% 1:2) { par <- sin(pi * tau/2) } else if (family %in% c(3, 13)) { - if (tau < 0) - stop("Clayton copula cannot be used for tau<0.") par <- 2 * tau/(1 - tau) } else if (family %in% c(4, 14)) { - if (tau < 0) - stop("Gumbel copula cannot be used for tau<0.") par <- 1/(1 - tau) } else if (family == 5) { par <- if (tau == 0) 0 else Frank.itau.JJ(tau) } else if (family %in% c(6, 16)) { - if (tau < 0) - stop("Joe copula cannot be used for tau<0.") par <- Joe.itau.JJ(tau) } else if (family %in% c(23, 33)) { - if (tau > 0) - stop("Rotated Clayton copula cannot be used for tau>0.") par <- 2 * tau/(1 + tau) } else if (family %in% c(24, 34)) { - if (tau > 0) - stop("Rotated Gumbel copula cannot be used for tau>0.") par <- -(1/(1 + tau)) } else if (family %in% c(26, 36)) { - if (tau > 0) - stop("Rotated Joe copula cannot be used for tau>0.") par <- -Joe.itau.JJ(-tau) } else if (family %in% c(41, 51)) { par <- ipsA.tau2cpar(tau) Modified: pkg/man/BiCopTau2Par.Rd =================================================================== --- pkg/man/BiCopTau2Par.Rd 2015-09-17 16:50:00 UTC (rev 136) +++ pkg/man/BiCopTau2Par.Rd 2015-09-17 17:30:45 UTC (rev 137) @@ -8,7 +8,7 @@ } \usage{ -BiCopTau2Par(family, tau) +BiCopTau2Par(family, tau, check.taus = TRUE) } \arguments{ @@ -31,6 +31,7 @@ \code{36} = rotated Joe copula (270 degrees)\cr Note that (with exception of the t-copula) two parameter bivariate copula families cannot be used.} \item{tau}{numeric; single number or vector of size \code{m}; Kendall's tau value (vector with elements in [-1,1]).} + \item{check.taus}{logical; default is \code{TRUE}; if \code{FALSE}, checks for family/tau-consistency are ommited (should only be used with care).} } \value{ From noreply at r-forge.r-project.org Thu Sep 17 20:11:05 2015 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Thu, 17 Sep 2015 20:11:05 +0200 (CEST) Subject: [Vinecopula-commits] r138 - pkg/R Message-ID: <20150917181105.7BD29180965@r-forge.r-project.org> Author: tnagler Date: 2015-09-17 20:11:04 +0200 (Thu, 17 Sep 2015) New Revision: 138 Modified: pkg/R/BiCopCDF.r pkg/R/BiCopHfunc.r pkg/R/BiCopHinv.R pkg/R/BiCopPDF.r pkg/R/BiCopPar2TailDep.r pkg/R/BiCopSim.R Log: * allow for Clayton/Frank with par = 0 in most functions (only when check.pars = FALSE) Modified: pkg/R/BiCopCDF.r =================================================================== --- pkg/R/BiCopCDF.r 2015-09-17 17:30:45 UTC (rev 137) +++ pkg/R/BiCopCDF.r 2015-09-17 18:11:04 UTC (rev 138) @@ -1,227 +1,232 @@ -BiCopCDF <- function(u1, u2, family, par, par2 = 0, obj = NULL, check.pars = TRUE) { - ## sanity checks for u1, u2 - if (is.null(u1) == TRUE || is.null(u2) == TRUE) - stop("u1 and/or u2 are not set or have length zero.") - if (any(u1 > 1) || any(u1 < 0)) - 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.") - n <- length(u1) - - ## extract family and parameters if BiCop object is provided - if (missing(family)) - family <- NA - if (missing(par)) - par <- NA - # for short hand usage extract obj from family - if (class(family) == "BiCop") - obj <- family - if (!is.null(obj)) { - stopifnot(class(obj) == "BiCop") - family <- obj$family - par <- obj$par - par2 <- obj$par2 - } - - ## check for reasonable input - if (any(is.na(family)) | any(is.na(par))) - stop("Provide either 'family' and 'par' or 'obj'") - if (any(family == 2)) - stop("The CDF of the t-copula is not implemented.") - - ## adjust length for parameter vectors; stop if not matching - if (any(c(length(family), length(par), length(par2)) == n)) { - if (length(family) == 1) - family <- rep(family, n) - if (length(par) == 1) - par <- rep(par, n) - if (length(par2) == 1) - par2 <- rep(par2, n) - } - if (!(length(family) %in% c(1, n))) - stop("'family' has to be a single number or a size n vector") - if (!(length(par) %in% c(1, n))) - stop("'par' has to be a single number or a size n vector") - if (!(length(par2) %in% c(1, n))) - stop("'par2' has to be a single number or a size n vector") - - ## check for family/parameter consistency - if (check.pars) - BiCopCheck(family, par, par2) - - ## calculate CDF - if (length(par) == 1) { - # call for single parameters - out <- calcCDF(u1, u2, family, par, par2) - } else { - # vectorized call - out <- vapply(1:length(par), - function(i) calcCDF(u1[i], - u2[i], - family[i], - par[i], - par2[i]), - numeric(1)) - } - - ## return result - out -} - -calcCDF <- function(u1, u2, family, par, par2) { - 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)) { - - if (family == 104) { - par3 <- 1 - res <- .C("TawnC", - as.double(u1), - as.double(u2), - as.integer(length(u1)), - as.double(par), - as.double(par2), - as.double(par3), - as.double(rep(0, length(u1))), - PACKAGE = "VineCopula")[[7]] - } - if (family == 114) { - par3 <- 1 - res <- u1 + u2 - 1 + .C("TawnC", - as.double(1-u1), - as.double(1-u2), - as.integer(length(u1)), - as.double(par), - as.double(par2), - as.double(par3), - as.double(rep(0, length(u1))), - PACKAGE = "VineCopula")[[7]] - } - if (family == 124) { - par3 <- 1 - res <- u2 - .C("TawnC", - as.double(1-u1), - as.double(u2), - as.integer(length(u1)), - as.double(-par), - as.double(par2), - as.double(par3), - as.double(rep(0, length(u1))), - PACKAGE = "VineCopula")[[7]] - } - if (family == 134) { - par3 <- 1 - res <- u1 - .C("TawnC", - as.double(u1), - as.double(1-u2), - as.integer(length(u1)), - as.double(-par), - as.double(par2), - as.double(par3), - as.double(rep(0, length(u1))), - PACKAGE = "VineCopula")[[7]] - } - if (family == 204) { - par3 <- par2 - par2 <- 1 - res <- .C("TawnC", - as.double(u1), - as.double(u2), - as.integer(length(u1)), - as.double(par), - as.double(par2), - as.double(par3), - as.double(rep(0, length(u1))), - PACKAGE = "VineCopula")[[7]] - } - if (family == 214) { - par3 <- par2 - par2 <- 1 - res <- u1 + u2 - 1 + .C("TawnC", - as.double(1-u1), - as.double(1-u2), - as.integer(length(u1)), - as.double(par), - as.double(par2), - as.double(par3), - as.double(rep(0, length(u1))), - PACKAGE = "VineCopula")[[7]] - } - if (family == 224) { - par3 <- par2 - par2 <- 1 - res <- u2 - .C("TawnC", - as.double(1-u1), - as.double(u2), - as.integer(length(u1)), - as.double(-par), - as.double(par2), - as.double(par3), - as.double(rep(0, length(u1))), - PACKAGE = "VineCopula")[[7]] - } - if (family == 234) { - par3 <- par2 - par2 <- 1 - res <- u1 - .C("TawnC", - as.double(u1), - as.double(1-u2), - as.integer(length(u1)), - as.double(-par), - as.double(par2), - as.double(par3), - as.double(rep(0, length(u1))), - PACKAGE = "VineCopula")[[7]] - } - } else { - res <- rep(NA, length(u1)) - } - - ## return results - res -} +BiCopCDF <- function(u1, u2, family, par, par2 = 0, obj = NULL, check.pars = TRUE) { + ## sanity checks for u1, u2 + if (is.null(u1) == TRUE || is.null(u2) == TRUE) + stop("u1 and/or u2 are not set or have length zero.") + if (any(u1 > 1) || any(u1 < 0)) + 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.") + n <- length(u1) + + ## extract family and parameters if BiCop object is provided + if (missing(family)) + family <- NA + if (missing(par)) + par <- NA + # for short hand usage extract obj from family + if (class(family) == "BiCop") + obj <- family + if (!is.null(obj)) { + stopifnot(class(obj) == "BiCop") + family <- obj$family + par <- obj$par + par2 <- obj$par2 + } + + ## check for reasonable input + if (any(is.na(family)) | any(is.na(par))) + stop("Provide either 'family' and 'par' or 'obj'") + if (any(family == 2)) + stop("The CDF of the t-copula is not implemented.") + + ## adjust length for parameter vectors; stop if not matching + if (any(c(length(family), length(par), length(par2)) == n)) { + if (length(family) == 1) + family <- rep(family, n) + if (length(par) == 1) + par <- rep(par, n) + if (length(par2) == 1) + par2 <- rep(par2, n) + } + if (!(length(family) %in% c(1, n))) + stop("'family' has to be a single number or a size n vector") + if (!(length(par) %in% c(1, n))) + stop("'par' has to be a single number or a size n vector") + if (!(length(par2) %in% c(1, n))) + stop("'par2' has to be a single number or a size n vector") + + ## sanity checks for family and parameters + if (check.pars) { + BiCopCheck(family, par, par2) + } else { + # allow zero parameter for Clayton an Frank otherwise + family[(family %in% c(3, 13, 23, 33)) & (par == 0)] <- 0 + family[(family == 5) & (par == 0)] <- 0 + } + + ## calculate CDF + if (length(par) == 1) { + # call for single parameters + out <- calcCDF(u1, u2, family, par, par2) + } else { + # vectorized call + out <- vapply(1:length(par), + function(i) calcCDF(u1[i], + u2[i], + family[i], + par[i], + par2[i]), + numeric(1)) + } + + ## return result + out +} + +calcCDF <- function(u1, u2, family, par, par2) { + 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)) { + + if (family == 104) { + par3 <- 1 + res <- .C("TawnC", + as.double(u1), + as.double(u2), + as.integer(length(u1)), + as.double(par), + as.double(par2), + as.double(par3), + as.double(rep(0, length(u1))), + PACKAGE = "VineCopula")[[7]] + } + if (family == 114) { + par3 <- 1 + res <- u1 + u2 - 1 + .C("TawnC", + as.double(1-u1), + as.double(1-u2), + as.integer(length(u1)), + as.double(par), + as.double(par2), + as.double(par3), + as.double(rep(0, length(u1))), + PACKAGE = "VineCopula")[[7]] + } + if (family == 124) { + par3 <- 1 + res <- u2 - .C("TawnC", + as.double(1-u1), + as.double(u2), + as.integer(length(u1)), + as.double(-par), + as.double(par2), + as.double(par3), + as.double(rep(0, length(u1))), + PACKAGE = "VineCopula")[[7]] + } + if (family == 134) { + par3 <- 1 + res <- u1 - .C("TawnC", + as.double(u1), + as.double(1-u2), + as.integer(length(u1)), + as.double(-par), + as.double(par2), + as.double(par3), + as.double(rep(0, length(u1))), + PACKAGE = "VineCopula")[[7]] + } + if (family == 204) { + par3 <- par2 + par2 <- 1 + res <- .C("TawnC", + as.double(u1), + as.double(u2), + as.integer(length(u1)), + as.double(par), + as.double(par2), + as.double(par3), + as.double(rep(0, length(u1))), + PACKAGE = "VineCopula")[[7]] + } + if (family == 214) { + par3 <- par2 + par2 <- 1 + res <- u1 + u2 - 1 + .C("TawnC", + as.double(1-u1), + as.double(1-u2), + as.integer(length(u1)), + as.double(par), + as.double(par2), + as.double(par3), + as.double(rep(0, length(u1))), + PACKAGE = "VineCopula")[[7]] + } + if (family == 224) { + par3 <- par2 + par2 <- 1 + res <- u2 - .C("TawnC", + as.double(1-u1), + as.double(u2), + as.integer(length(u1)), + as.double(-par), + as.double(par2), + as.double(par3), + as.double(rep(0, length(u1))), + PACKAGE = "VineCopula")[[7]] + } + if (family == 234) { + par3 <- par2 + par2 <- 1 + res <- u1 - .C("TawnC", + as.double(u1), + as.double(1-u2), + as.integer(length(u1)), + as.double(-par), + as.double(par2), + as.double(par3), + as.double(rep(0, length(u1))), + PACKAGE = "VineCopula")[[7]] + } + } else { + res <- rep(NA, length(u1)) + } + + ## return results + res +} Modified: pkg/R/BiCopHfunc.r =================================================================== --- pkg/R/BiCopHfunc.r 2015-09-17 17:30:45 UTC (rev 137) +++ pkg/R/BiCopHfunc.r 2015-09-17 18:11:04 UTC (rev 138) @@ -53,8 +53,13 @@ stop("'par2' has to be a single number or a size n vector") ## sanity checks for family and parameters - if (check.pars) + if (check.pars) { BiCopCheck(family, par, par2) + } else { + # allow zero parameter for Clayton an Frank otherwise + family[(family %in% c(3, 13, 23, 33)) & (par == 0)] <- 0 + family[(family == 5) & (par == 0)] <- 0 + } ## calculate h-functions if (length(par) == 1) { Modified: pkg/R/BiCopHinv.R =================================================================== --- pkg/R/BiCopHinv.R 2015-09-17 17:30:45 UTC (rev 137) +++ pkg/R/BiCopHinv.R 2015-09-17 18:11:04 UTC (rev 138) @@ -39,9 +39,14 @@ if (!(length(par2) %in% c(1, n))) stop("'par2' has to be a single number or a size n vector") - ## check for family/parameter consistency# - if (check.pars) + ## sanity checks for family and parameters + if (check.pars) { BiCopCheck(family, par, par2) + } else { + # allow zero parameter for Clayton an Frank otherwise + family[(family %in% c(3, 13, 23, 33)) & (par == 0)] <- 0 + family[(family == 5) & (par == 0)] <- 0 + } ## calculate inverse h-functions if (length(par) == 1) { Modified: pkg/R/BiCopPDF.r =================================================================== --- pkg/R/BiCopPDF.r 2015-09-17 17:30:45 UTC (rev 137) +++ pkg/R/BiCopPDF.r 2015-09-17 18:11:04 UTC (rev 138) @@ -1,15 +1,15 @@ -BiCopPDF <- function(u1, u2, family, par, par2 = 0, obj = NULL, check.pars = TRUE) { +BiCopPDF <- function(u1, u2, family, par, par2 = 0, obj = NULL, check.pars = TRUE) { ## sanity checks for u1, u2 - if (is.null(u1) == TRUE || is.null(u2) == TRUE) + 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)) + if (length(u1) != length(u2)) stop("Lengths of 'u1' and 'u2' do not match.") - if (any(u1 > 1) || any(u1 < 0)) + if (any(u1 > 1) || any(u1 < 0)) stop("Data has be in the interval [0,1].") - if (any(u2 > 1) || any(u2 < 0)) + if (any(u2 > 1) || any(u2 < 0)) stop("Data has be in the interval [0,1].") n <- length(u1) - + ## extract family and parameters if BiCop object is provided if (missing(family)) family <- NA @@ -24,16 +24,16 @@ par <- obj$par par2 <- obj$par2 } - + ## check for reasonable input if (any(is.na(family)) | any(is.na(par))) stop("Provide either 'family' and 'par' or 'obj'") - + ## adjust length for parameter vectors; stop if not matching if (any(c(length(family), length(par), length(par2)) == n)) { - if (length(family) == 1) + if (length(family) == 1) family <- rep(family, n) - if (length(par) == 1) + if (length(par) == 1) par <- rep(par, n) if (length(par2) == 1) par2 <- rep(par2, n) @@ -44,36 +44,41 @@ stop("'par' has to be a single number or a size n vector") if (!(length(par2) %in% c(1, n))) stop("'par2' has to be a single number or a size n vector") - - ## check for family/parameter consistency - if (check.pars) + + ## sanity checks for family and parameters + if (check.pars) { BiCopCheck(family, par, par2) - + } else { + # allow zero parameter for Clayton an Frank otherwise + family[(family %in% c(3, 13, 23, 33)) & (par == 0)] <- 0 + family[(family == 5) & (par == 0)] <- 0 + } + ## evaluate log-density if (length(par) == 1) { # unvectorized call coplik <- .C("LL_mod_seperate", as.integer(family), as.integer(n), - as.double(u1), + as.double(u1), as.double(u2), as.double(par), - as.double(par2), - as.double(rep(0, n)), + as.double(par2), + as.double(rep(0, n)), PACKAGE = "VineCopula")[[7]] } else { # vectorized call coplik <- .C("LL_mod_seperate_vec", as.integer(family), as.integer(n), - as.double(u1), + as.double(u1), as.double(u2), as.double(par), - as.double(par2), - as.double(rep(0, n)), + as.double(par2), + as.double(rep(0, n)), PACKAGE = "VineCopula")[[7]] } - + ## return density exp(coplik) } Modified: pkg/R/BiCopPar2TailDep.r =================================================================== --- pkg/R/BiCopPar2TailDep.r 2015-09-17 17:30:45 UTC (rev 137) +++ pkg/R/BiCopPar2TailDep.r 2015-09-17 18:11:04 UTC (rev 138) @@ -25,9 +25,14 @@ if (!all(c(length(family), length(par), length(par2)) %in% c(1, n))) stop("Input lenghts don't match") - ## check for family/parameter consistency - if (check.pars) + ## sanity checks for family and parameters + if (check.pars) { BiCopCheck(family, par, par2) + } else { + # allow zero parameter for Clayton an Frank otherwise + family[(family %in% c(3, 13, 23, 33)) & (par == 0)] <- 0 + family[(family == 5) & (par == 0)] <- 0 + } ## calculate tail dependence coefficient if (length(par) == 1) { Modified: pkg/R/BiCopSim.R =================================================================== --- pkg/R/BiCopSim.R 2015-09-17 17:30:45 UTC (rev 137) +++ pkg/R/BiCopSim.R 2015-09-17 18:11:04 UTC (rev 138) @@ -31,9 +31,15 @@ stop("'par2' has to be a single number or a size N vector") ## sanity checks for family and parameters - if (check.pars) + if (check.pars) { BiCopCheck(family, par, par2) + } else { + # allow zero parameter for Clayton an Frank otherwise + family[(family %in% c(3, 13, 23, 33)) & (par == 0)] <- 0 + family[(family == 5) & (par == 0)] <- 0 + } + ## start with independent uniforms (byrow for backwards compatibility) w <- matrix(runif(2*N), ncol = 2, byrow = TRUE) From noreply at r-forge.r-project.org Mon Sep 21 17:01:41 2015 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Mon, 21 Sep 2015 17:01:41 +0200 (CEST) Subject: [Vinecopula-commits] r139 - pkg/src Message-ID: <20150921150141.C57E7187BA9@r-forge.r-project.org> Author: tnagler Date: 2015-09-21 17:01:39 +0200 (Mon, 21 Sep 2015) New Revision: 139 Modified: pkg/src/likelihood.c Log: * fix typo in C code of Frank density Modified: pkg/src/likelihood.c =================================================================== --- pkg/src/likelihood.c 2015-09-17 18:11:04 UTC (rev 138) +++ pkg/src/likelihood.c 2015-09-21 15:01:39 UTC (rev 139) @@ -919,7 +919,7 @@ { for(j=0;j<*n;j++) { - if (fabs(*theta) < 10) { + if (fabs(*theta) < 1e-10) { ll = 0; } else { dat[0] = u[j]; dat[1] = v[j]; From noreply at r-forge.r-project.org Mon Sep 21 17:22:20 2015 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Mon, 21 Sep 2015 17:22:20 +0200 (CEST) Subject: [Vinecopula-commits] r140 - in pkg: . R man Message-ID: <20150921152220.7F1311845E3@r-forge.r-project.org> Author: tnagler Date: 2015-09-21 17:22:19 +0200 (Mon, 21 Sep 2015) New Revision: 140 Added: pkg/R/contour.RVineMatrix.R Modified: pkg/NAMESPACE pkg/R/plot.BiCop.R pkg/R/plot.RVineMatrix.R pkg/man/plot.BiCop.Rd Log: * add contour.BiCop * unify colors in plot functions Modified: pkg/NAMESPACE =================================================================== --- pkg/NAMESPACE 2015-09-21 15:01:39 UTC (rev 139) +++ pkg/NAMESPACE 2015-09-21 15:22:19 UTC (rev 140) @@ -5,10 +5,10 @@ import(lattice) import(network) -importFrom("grDevices", "colorRampPalette", "rgb", "terrain.colors", "col2rgb") +importFrom("grDevices", "colorRampPalette", "rgb", "terrain.colors", "col2rgb", "gray") importFrom("graphics", "abline", "box", "hist", "legend", "lines", "pairs", "par", "points", "strwidth", "text", - "plot.new", "polygon", "strheight") + "plot.new", "plot.window", "polygon", "strheight") importFrom("stats", "cor", "dexp", "dgamma", "dnorm", "dt", "integrate", "ks.test", "optim", "optimize", "pbinom", "pchisq", "pexp", "pgamma", "pnorm", "pt", "qexp", "qgamma", @@ -111,6 +111,7 @@ S3method(as.copuladata, list) S3method(pairs, copuladata) S3method(plot, BiCop) +S3method(contour, BiCop) S3method(plot, RVineMatrix) S3method(contour, RVineMatrix) Added: pkg/R/contour.RVineMatrix.R =================================================================== --- pkg/R/contour.RVineMatrix.R (rev 0) +++ pkg/R/contour.RVineMatrix.R 2015-09-21 15:22:19 UTC (rev 140) @@ -0,0 +1,158 @@ +## ----------------------------------------------------------------------------- +## contour generic for RVineMatrix objects +contour.RVineMatrix <- function(x, tree = "ALL", xylim = NULL, cex.nums = 1, ...) { + + ## check input + d <- nrow(x$Matrix) + if (all(tree == "ALL")) + tree <- seq.int(d-1) + n.tree <- length(tree) + if (!is.null(list(...)$type)) + stop("Only contour plots allowed. Don't use the type argument!") + + ## set up for plotting windows (restore settings on exit) + usr <- par(mfrow = c(n.tree, d - min(tree)), mar = rep(0, 4)) # dimensions of contour matrix + on.exit(par(usr)) + + ## default style -------------------------------------------------- + # headings: create blue color scale + TUMblue <- rgb(0, 103/255, 198/255) + tint.seq <- seq(0.5, 0.5, length.out = d - 1) + clrs <- rev(sapply(tint.seq, function(x) tint(TUMblue, x, 0.7))) + + # contours: set limits for plots + if (!is.null(list(...)$margins)) { + margins <- list(...)$margins + if (!(margins %in% c("norm", "unif"))) + stop("margins not supported") + } else { + margins <- "norm" + } + if (is.null(xylim)) + xylim <- switch(margins, + "norm" = c(-3, 3), + "unif" = c(1e-1, 1 - 1e-1)) + xlim <- ylim <- xylim + + # contours: adjust limits for headings + offs <- 0.25 + mult <- 1.5 + ylim[2] <- ylim[2] + offs*diff(ylim) + + + ## run through trees ----------------------------------------------- + # initialize check variables + cnt <- 0 + k <- d + e <- numeric(0) + class(e) <- "try-error" + + while ("try-error" %in% class(e)) { + e <- try({ + maxnums <- get_num(1, tree = max(tree), RVM = x) + for (i in tree) { + for (j in 1:(d - min(tree))) { + if (d - i >= j) { + # set up list of contour arguments + args <- list(x = BiCop(family=x$family[d-i+1,j], + par=x$par[d-i+1,j], + par2=x$par2[d-i+1,j]), + drawlabels = FALSE, + xlab = "", + ylab = "", + xlim = xlim, + ylim = ylim, + xaxt = "n", + yaxt = "n", + add = TRUE) + + # create empty plot + plot.new() + plot.window(xlim = xlim, ylim = ylim, + xaxs = "i", yaxs = "i") + + # call plot.BiCop with ... arguments + do.call(plot, modifyList(args, list(...))) + + # draw area for headings + abline(h = ylim[2] - diff(ylim)/mult*offs) + ci <- min(length(clrs) + 1 - i, 10) + polygon(x = c(xlim[1] - diff(xlim), + xlim[1] - diff(xlim), + xlim[2] + diff(xlim), + xlim[2] + diff(xlim)), + y = c(ylim[2] + diff(ylim)/mult*offs, + ylim[2] - diff(ylim)/mult*offs, + ylim[2] - diff(ylim)/mult*offs, + ylim[2] + diff(ylim)/mult*offs), + col = clrs[ci]) + + # add separating lines + abline(v = xlim) + abline(h = ylim) + + # add pair-copula ID + cx1 <- 0.95 * diff(xlim) / strwidth(maxnums) + cx1 <- cx1 + ty <- ylim[2] - diff(ylim)/mult*offs + cx2 <- 0.95 * (ylim[2] - ty) / strheight(maxnums) + cx2 <- cx2 + cx <- min(cx1, cx2) + text(x = sum(xlim)/2, + y = ty + 0.225 / cex.nums * (ylim[2] - ty), + cex = cex.nums * cx, + labels = get_num(j, tree = i, RVM = x), + pos = 3, + offset = 0) + } else { + plot.new() + } + } + } + } + , silent = TRUE) + + ## adjust to figure margins if necessary + if (length(tree) < 1) + stop("Error in plot.new() : figure margins too large") + if ("try-error" %in% class(e)) { + cnt <- cnt + 1 + tree <- tree[-which(tree == max(tree))] + par(mfrow = c(n.tree - cnt, d - min(tree))) + } + } + + ## message for the user if not all trees could be plotted ----------- + if (length(tree) != n.tree) { + nmbr.msg <- as.character(tree[1]) + if (length(tree) > 2) { + for (i in tree[-c(1, length(tree))]) { + nmbr.msg <- paste(nmbr.msg, i, sep=", ") + } + } + if (length(tree) > 1) { + s.msg <- "s " + nmbr.msg <- paste(nmbr.msg, + "and", + tree[length(tree)], + "were plotted. ") + } else { + s.msg <- " " + nmbr.msg <- paste(nmbr.msg, "was plotted. ", sep=" ") + } + msg.space <- "There is not enough space." + msg.tree <- paste("Only Tree", + s.msg, + nmbr.msg, + "Use the 'tree' argument or enlarge figure margins", + " to see the others.", + sep = "") + message(paste(msg.space, msg.tree)) + } +} + +tint <- function(x, fac, alpha = 1) { + x <- c(col2rgb(x)) + x <- (x + (255 - x) * fac) / 255 + rgb(x[1], x[2], x[3], alpha) +} Modified: pkg/R/plot.BiCop.R =================================================================== --- pkg/R/plot.BiCop.R 2015-09-21 15:01:39 UTC (rev 139) +++ pkg/R/plot.BiCop.R 2015-09-21 15:22:19 UTC (rev 140) @@ -1,4 +1,4 @@ -plot.BiCop <- function(x, type = "contour", margins, size, ...) { +plot.BiCop <- function(x, type = "surface", margins, size, ...) { ## partial matching and sanity check for type stopifnot(class(type) == "character") tpnms <- c("contour", "surface", "lambda") @@ -27,10 +27,9 @@ "contour" = 100L, "surface" = 25L) stopifnot(is.numeric(size)) + size <- round(size) - ## construct grid for evaluation of the copula density - size <- round(size) if (size < 3) { warning("size too small, set to 5") size <- 5 @@ -44,35 +43,37 @@ } else { xylim <- range(c(list(...)$xlim, list(...)$ylim)) } - sq <- seq(xylim[1L], xylim[2L], len = size) - points <- switch(margins, - "unif" = 1:size/(size + 1), - "norm" = pnorm(sq)) - g <- as.matrix(expand.grid(points, points)) - ## evaluate on grid - vals <- BiCopPDF(g[, 1L], g[, 2L], x) - cop <- matrix(vals, size, size) - ## prepare for plotting with selected margins if (margins == "unif") { + points <- switch(type, + "contour" = seq(1e-5, 1 - 1e-5, length.out = size), + "surface" = 1:size / (size + 1)) + g <- as.matrix(expand.grid(points, points)) points <- g[1L:size, 1L] adj <- 1 gu <- g[, 1L] gv <- g[, 2L] levels <- c(0.2, 0.6, 1, 1.5, 2, 3, 5, 10, 20) xlim <- ylim <- c(0, 1) - at <- c(seq(0, 6, by = 0.05), seq(7, 100, by = 1)) + at <- c(seq(0, 6, length.out = 50), seq(7, 100, length.out = 50)) } else if (margins == "norm") { + points <- pnorm(seq(xylim[1L], xylim[2L], length.out = size)) + g <- as.matrix(expand.grid(points, points)) points <- qnorm(g[1L:size, 1L]) adj <- tcrossprod(dnorm(points)) levels <- c(0.01, 0.025, 0.05, 0.1, 0.15, 0.2, 0.3, 0.4, 0.5) gu <- qnorm(g[, 1L]) gv <- qnorm(g[, 2L]) xlim <- ylim <- c(-3, 3) - at <- seq(0, 1, l = 100) + at <- c(seq(0, 0.3, length.out = 50), seq(0.3, 100, length.out = 50)) } + ## evaluate on grid + vals <- BiCopPDF(g[, 1L], g[, 2L], x) + cop <- matrix(vals, size, size) + + ## actual plotting if (type == "contour") { # set default parameters pars <- list(x = points, @@ -115,18 +116,24 @@ par.settings = list(axis.line = list(col = "transparent")), at = at, col.regions= - c(colorRampPalette( - c(TUMblue, TUMgreen, TUMorange))(121), - rep(TUMorange, 300)), + c(colorRampPalette(c(tint(TUMblue, 0.5), "white"))(50), + rep("white", 50)), xlab = switch(margins, "unif" = expression(u[1]), "norm" = expression(z[1])), ylab = switch(margins, "unif" = expression(u[2]), "norm" = expression(z[2])), - zlab = "density") + zlab = "density", + zlim = switch(margins, + "unif" = c(0, max(3, 1.1*max(lst$c))), + "norm" = c(0, max(0.4, 1.1*max(lst$c))))) # call wireframe with final parameters do.call(wireframe, modifyList(pars, list(...))) } +} + +contour.BiCop <- function(x, margins = "norm", size = 100L, ...) { + plot(x, type = "contour", margins = margins, size = size, ...) } \ No newline at end of file Modified: pkg/R/plot.RVineMatrix.R =================================================================== --- pkg/R/plot.RVineMatrix.R 2015-09-21 15:01:39 UTC (rev 139) +++ pkg/R/plot.RVineMatrix.R 2015-09-21 15:22:19 UTC (rev 140) @@ -20,17 +20,17 @@ #### set up plotting options ---------------------------- # reduce default margins of plot range - usr <- par()$mar - par(mar = c(1.1,0.1,3.1,0.1)) - on.exit(par(mar = usr)) + usr <- par(mar = c(1.1,0.1,3.1,0.1)) + on.exit(par(usr)) # set plot.network options - TUMlightblue <- rgb(red = 100, green = 160, blue = 200, maxColorValue = 255) + TUMblue <- rgb(0, 103/255, 198/255) + TUMlightblue <- tint(TUMblue, 0.5) dflt <- list(interactive = interactive, displaylabels = TRUE, pad = 1.5e-1, - edge.lwd = 0.35, - edge.col = "gray43", + edge.lwd = 0.25, + edge.col = gray(0.3), boxed.labels = TRUE, label.pad = 1.5, label.bg = TUMlightblue, @@ -90,160 +90,6 @@ } -## ----------------------------------------------------------------------------- -## contour generic for RVineMatrix objects -contour.RVineMatrix <- function(x, tree = "ALL", xylim = NULL, cex.nums = 1, ...) { - - ## check input - d <- nrow(x$Matrix) - if (all(tree == "ALL")) - tree <- seq.int(d-1) - n.tree <- length(tree) - if (!is.null(list(...)$type)) - stop("Only contour plots allowed. Don't use the type argument!") - - ## set up for plotting windows - mfrow.usr <- par()$mfrow - mar.usr <- par()$mar - par(mfrow = c(n.tree, d - min(tree))) - par(mar = rep(0, 4)) - on.exit(par(mfrow = mfrow.usr, mar = mar.usr)) - - - ## default style -------------------------------------------------- - # headings: blue color scale from dichromat pacakge - cs <- 1 / 255 * t(col2rgb(c("#E6FFFF", - "#CCFBFF", - "#B2F2FF", - "#99E6FF", - "#80D4FF", - "#66BFFF", - "#4CA6FF", - "#3388FF", - "#1A66FF", - "#0040FF"))) - # contours: set limits for plots - if (!is.null(list(...)$margins)) { - margins <- list(...)$margins - if (!(margins %in% c("norm", "unif"))) - stop("margins not supported") - } else { - margins <- "norm" - } - if (is.null(xylim)) - xylim <- switch(margins, - "norm" = c(-3, 3), - "unif" = c(1e-1, 1 - 1e-1)) - xlim <- ylim <- xylim - - # contours: adjust limits for headings - offs <- 0.25 - mult <- 1.5 - ylim[2] <- ylim[2] + offs*diff(ylim) - - - ## run through trees ----------------------------------------------- - # initialize check variables - cnt <- 0 - k <- d - e <- numeric(0) - class(e) <- "try-error" - - while ("try-error" %in% class(e)) { - e <- try({ - maxnums <- get_num(1, tree = max(tree), RVM = x) - for (i in tree) { - for (j in 1:(d - min(tree))) { - if (d - i >= j) { - # set up list of contour arguments - args <- list(x = BiCop(family=x$family[d-i+1,j], - par=x$par[d-i+1,j], - par2=x$par2[d-i+1,j]), - drawlabels = FALSE, - xlab = "", - ylab = "", - xlim = xlim, - ylim = ylim, - xaxt = "n", - yaxt = "n") - - # call plot.BiCop with ... arguments - do.call(plot, modifyList(args, list(...))) - - # draw area for headings - abline(h = ylim[2] - diff(ylim)/mult*offs) - ci <- min(nrow(cs) + 1 - i, 10) - polygon(x = c(xlim[1] - diff(xlim), - xlim[1] - diff(xlim), - xlim[2] + diff(xlim), - xlim[2] + diff(xlim)), - y = c(2*ylim[2], - ylim[2] - diff(ylim)/mult*offs, - ylim[2] - diff(ylim)/mult*offs, - 2*ylim[2]), - col = rgb(cs[ci, 1], cs[ci, 2], cs[ci, 3], 0.3)) - - # add pair-copula ID - cx1 <- 0.95 * diff(xlim) / strwidth(maxnums) - cx1 <- cx1 - ty <- ylim[2] - diff(ylim)/mult*offs - cx2 <- 0.95 * (ylim[2] - ty) / strheight(maxnums) - cx2 <- cx2 - cx <- min(cx1, cx2) - text(x = sum(xlim)/2, - y = ty + 0.225 / cex.nums * (ylim[2] - ty), - cex = cex.nums * cx, - labels = get_num(j, tree = i, RVM = x), - pos = 3, - offset = 0) - } else { - plot.new() - } - } - } - } - , silent = TRUE) - - ## adjust to figure margins if necessary - if (length(tree) < 1) - stop("Error in plot.new() : figure margins too large") - if ("try-error" %in% class(e)) { - cnt <- cnt + 1 - tree <- tree[-which(tree == max(tree))] - par(mfrow = c(n.tree - cnt, d - min(tree))) - } - } - - ## message for the user if not all trees could be plotted ----------- - if (length(tree) != n.tree) { - nmbr.msg <- as.character(tree[1]) - if (length(tree) > 2) { - for (i in tree[-c(1, length(tree))]) { - nmbr.msg <- paste(nmbr.msg, i, sep=", ") - } - } - if (length(tree) > 1) { - s.msg <- "s " - nmbr.msg <- paste(nmbr.msg, - "and", - tree[length(tree)], - "were plotted. ") - } else { - s.msg <- " " - nmbr.msg <- paste(nmbr.msg, "was plotted. ", sep=" ") - } - msg.space <- "There is not enough space." - msg.tree <- paste("Only Tree", - s.msg, - nmbr.msg, - "Use the 'tree' argument or enlarge figure margins", - " to see the others.", - sep = "") - message(paste(msg.space, msg.tree)) - } -} - - ## creates a network object for a tree in a given RVineMatrix ------------------ makeNetwork <- function(RVM, tree, use.names = FALSE) { M <- RVM$Matrix Modified: pkg/man/plot.BiCop.Rd =================================================================== --- pkg/man/plot.BiCop.Rd 2015-09-21 15:01:39 UTC (rev 139) +++ pkg/man/plot.BiCop.Rd 2015-09-21 15:22:19 UTC (rev 140) @@ -1,21 +1,23 @@ \name{plot.BiCop} \alias{plot.BiCop} +\alias{contour.BiCop} %- Also NEED an '\alias' for EACH other topic documented here. \title{ Plotting tools for BiCop objects } \description{ -There are several options for plotting BiCop objects. The density of a bivariate copula density can be visualized as contour or surface/perspective plot. Optionally, the density can be coupled with standard normal margins (default for contour plots). Furthermore, a lambda-plot is available (c.f. \code{\link{BiCopLambda}}). +There are several options for plotting BiCop objects. The density of a bivariate copula density can be visualized as surface/perspective or contour plot. Optionally, the density can be coupled with standard normal margins (default for contour plots). Furthermore, a lambda-plot is available (c.f. \code{\link{BiCopLambda}}). } \usage{ -\method{plot}{BiCop}(x, type = "contour", margins, size, ...) +\method{plot}{BiCop}(x, type = "surface", margins, size, ...) +\method{contour}{BiCop}(x, margins = "norm", size = 100L, ...) } %- maybe also 'usage' for other objects documented here. \arguments{ \item{x}{ \code{BiCop object.}} \item{type}{ -plot type; either \code{"contour"}, \code{"surface"} or \code{"lambda"} (partial matching is activated); the latter is only implemented for a few families (c.f. \code{\link{BiCopLambda}}). +plot type; either \code{"surface"}, \code{"contour"}, or \code{"lambda"} (partial matching is activated); the latter is only implemented for a few families (c.f., \code{\link{BiCopLambda}}). } \item{margins}{ only relevant for types \code{"contour"} and \code{"surface"}; either \code{"unif"} for the original copula density or \code{"norm"} for the transformed density with standard normal margins (partial matching is activated). Default is \code{"norm"} for \code{type = "contour"}, and \code{"unif"} for \code{type = "surface"}. @@ -38,9 +40,9 @@ obj <- BiCop(family = 104, par = 2.5, par2 = 0.4) ## plots -plot(obj) # (marginal normal) contour plot -plot(obj, margins = "unif") # contour plot of actual copula density -plot(obj, type = "surf") # surface plot of actual copula densityu +plot(obj) # surface plot of copula density +contour(obj) # contour plot with standard normal margins +contour(obj, margins = "unif") # contour plot of copula density } % Add one or more standard keywords, see file 'KEYWORDS' in the % R documentation directory. From noreply at r-forge.r-project.org Mon Sep 21 17:24:56 2015 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Mon, 21 Sep 2015 17:24:56 +0200 (CEST) Subject: [Vinecopula-commits] r141 - in pkg: R man Message-ID: <20150921152456.5606F186AC6@r-forge.r-project.org> Author: tnagler Date: 2015-09-21 17:24:55 +0200 (Mon, 21 Sep 2015) New Revision: 141 Modified: pkg/R/RVineMatrix.R pkg/man/RVineMatrix.Rd Log: * add check.pars option to RVineMatrix Modified: pkg/R/RVineMatrix.R =================================================================== --- pkg/R/RVineMatrix.R 2015-09-21 15:22:19 UTC (rev 140) +++ pkg/R/RVineMatrix.R 2015-09-21 15:24:55 UTC (rev 141) @@ -1,4 +1,4 @@ -RVineMatrix <- function(Matrix, family = array(0, dim = dim(Matrix)), par = array(NA, dim = dim(Matrix)), par2 = array(NA, dim = dim(Matrix)), names = NULL) { +RVineMatrix <- function(Matrix, family = array(0, dim = dim(Matrix)), par = array(NA, dim = dim(Matrix)), par2 = array(NA, dim = dim(Matrix)), names = NULL, check.pars = TRUE) { ## set NAs to zero Matrix[is.na(Matrix)] <- 0 @@ -36,10 +36,12 @@ stop("'Matrix' is not a valid R-vine matrix") ## check for family/parameter consistency - if (!all(par %in% c(0, NA))) { - for (i in 2:dim(Matrix)[1]) { - for (j in 1:(i - 1)) { - BiCopCheck(family[i, j], par[i, j], par2[i, j]) + if (check.pars) { + if (!all(par %in% c(0, NA))) { + for (i in 2:dim(Matrix)[1]) { + for (j in 1:(i - 1)) { + BiCopCheck(family[i, j], par[i, j], par2[i, j]) + } } } } Modified: pkg/man/RVineMatrix.Rd =================================================================== --- pkg/man/RVineMatrix.Rd 2015-09-21 15:22:19 UTC (rev 140) +++ pkg/man/RVineMatrix.Rd 2015-09-21 15:24:55 UTC (rev 141) @@ -1,18 +1,18 @@ -\name{RVineMatrix} +\name{RVineMatrix} \alias{RVineMatrix} \title{R-Vine Copula Model in Matrix Notation} \description{ This function creates an \code{\link{RVineMatrix}} object which encodes an R-vine copula model. -It contains the matrix identifying the R-vine tree structure, the matrix identifying the copula families +It contains the matrix identifying the R-vine tree structure, the matrix identifying the copula families utilized and two matrices for corresponding parameter values. } \usage{ RVineMatrix(Matrix, family = array(0, dim = dim(Matrix)), par = array(NA, dim = dim(Matrix)), - par2 = array(NA, dim = dim(Matrix)), names=NULL) + par2 = array(NA, dim = dim(Matrix)), names=NULL, check.pars = TRUE) } \arguments{ @@ -26,14 +26,14 @@ \code{3} = Clayton copula \cr \code{4} = Gumbel copula \cr \code{5} = Frank copula \cr - \code{6} = Joe copula \cr + \code{6} = Joe copula \cr \code{7} = BB1 copula \cr \code{8} = BB6 copula \cr \code{9} = BB7 copula \cr \code{10} = BB8 copula \cr \code{13} = rotated Clayton copula (180 degrees; ``survival Clayton'') \cr \code{14} = rotated Gumbel copula (180 degrees; ``survival Gumbel'') \cr - \code{16} = rotated Joe copula (180 degrees; ``survival Joe'') \cr + \code{16} = rotated Joe copula (180 degrees; ``survival Joe'') \cr \code{17} = rotated BB1 copula (180 degrees; ``survival BB1'')\cr \code{18} = rotated BB6 copula (180 degrees; ``survival BB6'')\cr \code{19} = rotated BB7 copula (180 degrees; ``survival BB7'')\cr @@ -67,6 +67,8 @@ \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}.} + \item{check.pars}{logical; default is \code{TRUE}; if \code{FALSE}, checks for family/parameter-consistency are ommited (should only be used with care).} + } \value{ @@ -78,7 +80,7 @@ } \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)}, +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}}). \cr Although the function allows upper triangular matrices as its input, it will always store them as lower triangular matrices. From noreply at r-forge.r-project.org Mon Sep 21 18:16:45 2015 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Mon, 21 Sep 2015 18:16:45 +0200 (CEST) Subject: [Vinecopula-commits] r142 - / tests Message-ID: <20150921161645.F3F9B187B29@r-forge.r-project.org> Author: ulf Date: 2015-09-21 18:16:45 +0200 (Mon, 21 Sep 2015) New Revision: 142 Added: tests/ tests/testCheck.r tests/testMain.r tests/testRun.r Log: New directory (not in the package) for systematic unit tests. Started with BiCopPar2Tau and BiCopPar2Beta.Rd Further tests and checks in the same style may follow. Added: tests/testCheck.r =================================================================== --- tests/testCheck.r (rev 0) +++ tests/testCheck.r 2015-09-21 16:16:45 UTC (rev 142) @@ -0,0 +1,32 @@ +##' Testsuite - Check +##' +##' Run several tests for the BiCop-functions of the VineCopula-package +##' +##' @author Dr. Ulf Schepsmeier +##' @param results list of results returned from testRun* + +testCheck <- function(results){ + ## length of results + n <- length(results) + + check <- rep(TRUE, n) + + for(i in 1:n){ + ## Check 1: is.na + if(any(is.na(results[[i]]))) check[i] <- FALSE + ## Check 2: is.nan + if(any(is.nan(results[[i]]))) check[i] <- FALSE + ## Check 3: is.infinite + if(any(is.infinite(results[[i]]))) check[i] <- FALSE + ## Check 4: in range + if(names(results)[i] %in% c(1:10,13,14,16:20,104,114,204,214)){ + if(any( results[[i]] < 0 || results[[i]] > 1 ) ) check[i] <- FALSE + } else { + if(any( results[[i]] > 0 || results[[i]] < -1 ) ) check[i] <- FALSE + } + ## check for jumps + ## TODO + } + + return(check) +} \ No newline at end of file Added: tests/testMain.r =================================================================== --- tests/testMain.r (rev 0) +++ tests/testMain.r 2015-09-21 16:16:45 UTC (rev 142) @@ -0,0 +1,35 @@ +##' Testsuite +##' +##' Tests for the VineCopula package +##' +##' @author Dr. Ulf Schepsmeier +##' + +## Main function + +library(VineCopula) + +source("../tests/testRun.r") +source("../tests/testCheck.r") + +# BiCopPar2Tau +results_BiCopPar2Tau <- testRunBiCopPar("BiCopPar2Tau") +check_BiCopPar2Tau <- testCheck(results_BiCopPar2Tau) +if(!all(check_BiCopPar2Tau)){ + print(check_BiCopPar2Tau) +} else { + rm(results_BiCopPar2Tau) + gc() +} + +# BiCopPar2Beta +results_BiCopPar2Beta <- testRunBiCopPar("BiCopPar2Beta") +check_BiCopPar2Beta <- testCheck(results_BiCopPar2Beta) +if(!all(check_BiCopPar2Beta)){ + print(check_BiCopPar2Beta) +} else { + rm(results_BiCopPar2Beta) + gc() +} + + Added: tests/testRun.r =================================================================== --- tests/testRun.r (rev 0) +++ tests/testRun.r 2015-09-21 16:16:45 UTC (rev 142) @@ -0,0 +1,100 @@ +##' Testsuite - Run +##' +##' Run several tests for the BiCop-functions of the VineCopula-package +##' +##' @author Dr. Ulf Schepsmeier +##' @param FUN function name +##' @return results list of results for each family + + +## testRun for BiCopPar2Tau, BiCopPar2Beta +## BiCopPar2TailDep geht so leider noch nicht, da lower und upper als return + +testRunBiCopPar <- function(FUN){ + ## familyset + familyset <- c(1:10,13:20,23:30,33:40,104,114,124,134,204,214,224,234) + #familyset <- c(1:10,13:20,23:30) + familyset <- familyset[-which(familyset %in% c(15,25,35,36))] + + if(FUN == "BiCopPar2Beta") familyset <- familyset[-which(familyset == 2)] + + ## parameter sets + parset3 <- seq(0, 0.999, 0.001) + parset3a <- seq(1, 1.999, 0.001) + parset1 <- c(parset3, seq(1, 10, 0.01)) + parset2 <- c(parset3a, seq(2, 10, 0.01)) + parset4 <- seq(0, 50, 1) + + ## return the results in a list + results <- list() + + k <- 1 + for(fam in familyset){ # run over all families + ## set the correct parameter set + if(fam == 1){ + res <- rep(0, length(parset3)) + par <- parset3 + } else if(fam == 2){ + res <- matrix(0, length(parset3), length(parset4)) + par <- parset3 + par2 <- parset4 + } else if(fam %in% c(3, 13, 23, 33)){ + res <- rep(0,length(parset1)-1) + par <- parset1[-1] + } else if(fam %in% c(4, 14, 24, 34)){ + res <- rep(0,length(parset2)) + par <- parset2 + } else if(fam %in% c(6, 16, 26, 36)){ + res <- rep(0,length(parset2)-1) + par <- parset2[-1] + } else if(fam %in% c(7, 17, 27, 37, 8, 18, 28, 38)){ + res <- matrix(0, length(parset1)-1, length(parset2)) + par <- parset1[-1] + par2 <- parset2 + } else if(fam %in% c(9, 19, 29, 39)){ + res <- matrix(0, length(parset2), length(parset1)-1) + par <- parset2 + par2 <- parset1[-1] + } else if(fam %in% c(10, 20, 30, 40)){ + res <- matrix(0, length(parset2), length(parset3)-1) + par <- parset2 + par2 <- parset3[-1] + } else if(fam > 100){ + res <- matrix(0, length(parset2), length(parset3)) + par <- parset2 + par2 <- parset3 + } + + ## length of results (depending on the parameter set) + n1 <- ifelse(is.null(dim(res)), length(res), nrow(res)) + n2 <- ifelse(is.null(dim(res)), 0, ncol(res)) + + ## for rotated copulas switch sign + if(fam > 20 && fam < 100){ + par <- -par + par2 <- -par2 + } else if(fam %in% c(124,134,224,234)){ + par <- -par + } + + for(i in 1:n1){ + if(n2 == 0){ + res[i] <- do.call(what=FUN, args=list(family=fam, par=par[i], par2=0)) + } else { + for(j in n2){ + res[i,j] <- do.call(what=FUN, args=list(family=fam, par=par[i], par2=par2[j])) + } + } + } + + ## save the results and give it the name of teh family + results[[k]] <- res + names(results)[[k]] <- as.character(fam) + + k <- k+1 + + } # end familyset + + return(results) +} + From noreply at r-forge.r-project.org Tue Sep 22 18:37:18 2015 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Tue, 22 Sep 2015 18:37:18 +0200 (CEST) Subject: [Vinecopula-commits] r143 - pkg pkg/R pkg/src tests Message-ID: <20150922163718.5E20D187C17@r-forge.r-project.org> Author: ulf Date: 2015-09-22 18:37:17 +0200 (Tue, 22 Sep 2015) New Revision: 143 Modified: pkg/DESCRIPTION pkg/R/BiCopPar2Tau.r pkg/R/RVineGrad.r pkg/R/RVineHessian.r pkg/R/RVineMLE.R pkg/R/RVinePIT.r pkg/R/RVinePartialcorr.R pkg/src/cdvine.c pkg/src/deriv.c pkg/src/evCopula.c pkg/src/gof.c pkg/src/hfunc.c pkg/src/incompleteBeta.c pkg/src/likelihood.c pkg/src/logderiv.c pkg/src/rvine.c pkg/src/rvinederiv.c pkg/src/rvinederiv2.c pkg/src/tcopuladeriv_new.c pkg/src/tools.c tests/testCheck.r tests/testMain.r tests/testRun.r Log: * one new test * DESCRIPTION file: Authors at R added * deleted not necessary lines in code Modified: pkg/DESCRIPTION =================================================================== --- pkg/DESCRIPTION 2015-09-21 16:16:45 UTC (rev 142) +++ pkg/DESCRIPTION 2015-09-22 16:37:17 UTC (rev 143) @@ -3,6 +3,20 @@ Title: Statistical Inference of Vine Copulas Version: 1.7 Date: 2015-08-10 +Authors at R: c( + person("Schepsmeier", "Ulf", , "ulf.schepsmeier at tum.de", c("aut")), + person("Stoeber", "Jakob", , role = "aut"), + person("Brechmann", "Eike", "Christian", role = "aut"), + person("Graeler", "Benedikt", role="aut"), + person("Nagler", "Thomas", , "thomas.nagler at tum.de", c("aut")), + person("Erhardt", "Tobias", , "tobias.erhardt at tum.de", c("aut", "cre")), + person("Almeida", "Carlos", role="ctb"), + person("Min", "Aleksey", role=c("ctb", "ths")), + person("Czado", "Claudia", role=c("ctb", "ths")), + person("Hofmann", "Mathias", role="ctb"), + person("Killiches", "Matthias", role="ctb"), + person("Joe", "Harry", role="ctb") + ) Author: Ulf Schepsmeier, Jakob Stoeber, Eike Christian Brechmann, Benedikt Graeler, Thomas Nagler, Tobias Erhardt Maintainer: Tobias Erhardt Depends: R (>= 2.11.0) Modified: pkg/R/BiCopPar2Tau.r =================================================================== --- pkg/R/BiCopPar2Tau.r 2015-09-21 16:16:45 UTC (rev 142) +++ pkg/R/BiCopPar2Tau.r 2015-09-22 16:37:17 UTC (rev 143) @@ -84,16 +84,14 @@ } else if (family == 9 || family == 19) { theta <- par delta <- par2 - # tau=1-2/(delta*(2-theta))+4/(theta^2*delta)*gamma(delta+2)*gamma((2-2*theta)/(theta)+1)/gamma(delta+3+(2-2*theta)/(theta)) + kt <- function(t, th, de) { ((1 - (1 - t)^th)^-de - 1)/(-th * de * (1 - t)^(th - 1) * (1 - (1 - t)^th)^(-de - 1)) } tau <- 1 + 4 * mapply(function(theta, delta) { integrate(function(t) kt(t, th = theta, de = delta), 0, 1)$value }, theta, delta) - # kt <- function(t) { 1/( (1-t)^(par-1) ) } kt2 <- function(t) { 1-t } kt3 <- - # function(t) { 1/( (1-t)^(par-1)*(1-(1-t)^par)^(-par2-1) ) } tau <- - # 1-4/par/par2*(integrate(kt,0,1)$value-integrate(kt2,0,1)$value-integrate(kt3,0,1)$value) + } else if (family == 10 || family == 20) { theta <- par delta <- par2 @@ -110,8 +108,7 @@ } else if (family == 24 || family == 34) { tau <- -1 - 1/par } else if (family == 26 || family == 36) { - # tau <- -1-4/par^2*integrate(function(x) log(x)*x*(1-x)^(2*(1+par)/-par), 0, - # 1)$value + theta <- -par param1 <- 2/theta + 1 tem <- digamma(2) - digamma(param1) @@ -138,8 +135,7 @@ } else if (family == 29 || family == 39) { theta <- -par delta <- -par2 - # tau <- - # 1-2/(delta*(2-theta))+4/(theta^2*delta)*gamma(delta+2)*gamma((2-2*theta)/(theta)+1)/gamma(delta+3+(2-2*theta)/(theta)) + kt <- function(t, th, de) { ((1 - (1 - t)^th)^(-de) - 1)/(-th * de * (1 - t)^(th - 1) * (1 - (1 - t)^th)^(-de - 1)) } Modified: pkg/R/RVineGrad.r =================================================================== --- pkg/R/RVineGrad.r 2015-09-21 16:16:45 UTC (rev 142) +++ pkg/R/RVineGrad.r 2015-09-22 16:37:17 UTC (rev 143) @@ -39,14 +39,12 @@ stop("'RVM' has to be an RVineMatrix object.") - # if(any(is.na(calcupdate))) { n=dim(RVM) calcupdate=array(0,dim=c(n,n,n,n)) for(i in (n-1):1){ for(k in n:(i+1)){ calcupdate[, ,k,i - # ]=RVineMatrixUpdate(RVM,k,i) } } } + o <- diag(RVM$Matrix) if (any(o != length(o):1)) { oldRVM <- RVM RVM <- normalizeRVineMatrix(RVM) - # RVM = getFromNamespace('normalizeRVineMatrix','VineCopula')(RVM) data <- data[, o[length(o):1]] } @@ -65,7 +63,6 @@ ll <- as.vector(V$value) vv <- as.vector(V$direct) vv2 <- as.vector(V$indirect) - # calcup=as.vector(calcupdate) w1 <- as.vector(RVM$family) w1[is.na(w1)] <- 0 @@ -81,7 +78,6 @@ maxmat[is.na(maxmat)] <- 0 condirect[is.na(condirect)] <- 0 conindirect[is.na(conindirect)] <- 0 - # tilde_vdirect_array=array(0,dim=c(n,n,N,n,n)) tilde_vindirect_array=array(0,dim=c(n,n,N,n,n)) tilde_value_array=array(0,dim=c(n,n,N,n,n)) out <- rep(0, sum(posParams[lower.tri(posParams, diag = FALSE)]) + sum(w1 == 2)) @@ -101,11 +97,7 @@ as.double(ll), as.double(vv), as.double(vv2), - #as.integer(calcup), as.integer(as.vector(posParams)), - #as.double(as.vector(tilde_vdirect_array)), - #as.double(as.vector(tilde_vindirect_array)), - #as.double(as.vector(tilde_value_array)), PACKAGE = 'VineCopula') @@ -122,10 +114,7 @@ gradient <- c(gradient, grad2[tt:1]) } - # tilde_vdirect=out[[16]] tilde_vindirect=out[[17]] tilde_value=out[[18]] V$tilde_direct = array(tilde_vdirect,dim=c(n,n,N,n,n)) V$tilde_indirect = - # array(tilde_vindirect,dim=c(n,n,N,n,n)) V$tilde_value = array(tilde_value,dim=c(n,n,N,n,n)) - - # out2=list(gradient=gradient,V=V) + out2 <- list(gradient = gradient) return(out2) } Modified: pkg/R/RVineHessian.r =================================================================== --- pkg/R/RVineHessian.r 2015-09-21 16:16:45 UTC (rev 142) +++ pkg/R/RVineHessian.r 2015-09-22 16:37:17 UTC (rev 143) @@ -28,7 +28,6 @@ o <- diag(RVM$Matrix) if (any(o != length(o):1)) { oldRVM <- RVM - # RVM = normalizeRVineMatrix(RVM) RVM <- getFromNamespace("normalizeRVineMatrix", "VineCopula")(RVM) data <- data[, o[length(o):1]] } @@ -62,10 +61,6 @@ der <- matrix(out[[13]], dd + tt, dd + tt) subder <- matrix(out[[14]], dd + tt, dd + tt) - # der[1:dd,1:dd]=der[dd:1,dd:1] if(tt>0) { der[(dd+1):(dd+tt),1:dd]=der[(dd+tt):(dd+1),dd:1] der[1:dd,(dd+1):(dd+tt)]=der[dd:1,(dd+tt):(dd+1)] - # der[(dd+1):(dd+tt),(dd+1):(dd+tt)]=der[(dd+tt):(dd+1),(dd+tt):(dd+1)] } hessian[1:dd,1:dd]=hessian[dd:1,dd:1] if(tt>0) { - # hessian[(dd+1):(dd+tt),1:dd]=hessian[(dd+tt):(dd+1),dd:1] hessian[1:dd,(dd+1):(dd+tt)]=hessian[dd:1,(dd+tt):(dd+1)] - # hessian[(dd+1):(dd+tt),(dd+1):(dd+tt)]=hessian[(dd+tt):(dd+1),(dd+tt):(dd+1)] } test <- apply(hessian, 2, function(x) max(abs(x))) hessian <- hessian[test > 0, test > 0] Modified: pkg/R/RVineMLE.R =================================================================== --- pkg/R/RVineMLE.R 2015-09-21 16:16:45 UTC (rev 142) +++ pkg/R/RVineMLE.R 2015-09-22 16:37:17 UTC (rev 143) @@ -285,14 +285,10 @@ ## log-likelihood function to be maximized optim_LL <- function(parm, data, posParams, posParams2, Copula.Types, start, start2, RVM, calcupdate = NA) { - # calcupdate=NA V=NA nParams <- sum(posParams, na.rm = TRUE) nParams2 <- sum(posParams2, na.rm = TRUE) - # for(k in 1:nParams) { if(Copula.Types[k]==0) { if(k==1){parm=c(0,parm)} else if(k>length(parm)){parm=c(parm,0)} else - # {parm=c(parm[1:(k-1)],0,parm[k:length(parm)])} } } - matrixParams <- start matrixParams2 <- start2 @@ -304,7 +300,6 @@ ll <- RVineLogLik(data, RVM, par = matrixParams, par2 = matrixParams2) - # V=ll$V if (is.finite(ll$loglik)) { return(ll$loglik) @@ -322,14 +317,6 @@ nParams <- sum(posParams, na.rm = TRUE) nParams2 <- sum(posParams2, na.rm = TRUE) - # outparm=parm for (i in 1:length(parm)) { handle_parm=parm handle_parm[i]=handle_parm[i]+0.000001 handle_parm2=parm - # handle_parm2[i]=handle_parm2[i]-0.000001 - # outparm[i]=(optim_LL(handle_parm,data,posParams,posParams2,Copula.Types,start,start2,RVM,calcupdate=NA)-optim_LL(handle_parm2,data,posParams,posParams2,Copula.Types,start,start2,RVM,calcupdate=NA))/(2*0.000001) - # } print('finite differences:') print(outparm) - - # for(k in 1:nParams) { if(Copula.Types[k]==0) { if(k==1){parm=c(0,parm)} else if(k>length(parm)){parm=c(parm,0)} else - # {parm=c(parm[1:(k-1)],0,parm[k:length(parm)])} } } - matrixParams <- start matrixParams2 <- start2 @@ -370,7 +357,6 @@ ## optimization if (all(Copula.Types %in% c(0, 1, 2, 3:6, 13, 14, 16, 23, 24, 26, 33, 34, 36, 43, 44)) && grad == TRUE) { - # n=dim(RVM) calcupdate=array(0,dim=c(n,n,n,n)) for(i in (n-1):1){ for(k in n:(i+1)){ calcupdate[, ,k,i ]=RVineMatrixUpdate(RVM,k,i) } } if (hessian == TRUE || se == TRUE) { out1 <- optim(par = startpar, fn = optim_LL, Modified: pkg/R/RVinePIT.r =================================================================== --- pkg/R/RVinePIT.r 2015-09-21 16:16:45 UTC (rev 142) +++ pkg/R/RVinePIT.r 2015-09-22 16:37:17 UTC (rev 143) @@ -19,34 +19,7 @@ if (is(RVM)[1] != "RVineMatrix") stop("'RVM' has to be an RVineMatrix object.") - #if(type=="CVine") type=1 - #else if(type=="DVine") type=2 - #else if(type=="RVine") type=0 - #if(!(type %in% c(0,1,2)) ) stop("Vine type not implemented.") - - #if(type==1 || type==2) - #{ - # if(type==1) - # vine=R2CVine(RVM) - # else if(type==2) - # vine=R2DVine(RVM) - - # tmp = .C("pit", - # as.integer(T), - # as.integer(d), - # as.integer(vine$family), - # as.integer(type), - # as.double(vine$par), - # as.double(vine$par2), - # as.double(data), - # as.double(rep(0,T*d)), - # PACKAGE='VineCopula')[[8]] - # - # U <- matrix(tmp,ncol=d) - #} - #else { - o <- diag(RVM$Matrix) if (any(o != length(o):1)) { oldRVM <- RVM Modified: pkg/R/RVinePartialcorr.R =================================================================== --- pkg/R/RVinePartialcorr.R 2015-09-21 16:16:45 UTC (rev 142) +++ pkg/R/RVinePartialcorr.R 2015-09-22 16:37:17 UTC (rev 143) @@ -199,96 +199,3 @@ } -####################################### -# for immeddeate testing run as well ## -####################################### - -# normalizeRVineMatrix = function(RVM){ -# -# oldOrder = diag(RVM$Matrix) -# Matrix = reorderRVineMatrix(RVM$Matrix) -# -# names <- RVM$names -# if(is.null(names)) -# names <- paste("V",1:nrow(RVM$Matrix),sep="") -# -# return(RVineMatrix(Matrix, RVM$family, RVM$par, RVM$par2, names = rev(names[oldOrder]))) -# } -# -# reorderRVineMatrix = function(Matrix){ -# oldOrder = diag(Matrix) -# -# O = apply(t(1:nrow(Matrix)),2,"==", Matrix) -# -# for(i in 1:nrow(Matrix)){ -# Matrix[O[,oldOrder[i]]] = nrow(Matrix)-i+1 -# } -# -# return(Matrix) -# } -# -# # examples/test cases -# ###################### -# -# corMat <- matrix(c(1.00, 0.17, 0.15, 0.14, 0.13, -# 0.17, 1.00, 0.30, 0.28, 0.05, -# 0.15, 0.30, 1.00, 0.17, 0.05, -# 0.14, 0.28, 0.17, 1.00, 0.04, -# 0.13, 0.05, 0.05, 0.04, 1.00),5,5) -# -# Matrix = matrix(c(5,2,3,1,4, -# 0,2,3,4,1, -# 0,0,3,4,1, -# 0,0,0,4,1, -# 0,0,0,0,1),5,5) -# family = matrix(1,5,5) -# -# par = matrix(c(0,0.2,0.9,0.5,0.8, -# 0, 0,0.1,0.6,0.9, -# 0, 0, 0,0.7,0.5, -# 0, 0, 0, 0,0.8, -# 0, 0, 0, 0, 0),5,5) -# -# # define RVineMatrix object -# RVM = RVineMatrix(Matrix,family,par) -# -# # adjust the un-ordered RVine -# newRVM <- RVineCor2pcor(RVM, corMat) -# round(cor(qnorm(RVineSim(100000, newRVM)))-corMat, 2) -# -# # normalise the RVine -# normRVM <- normalizeRVineMatrix(RVM) -# -# # adjust the normalised RVine -# newNormRVM <- RVineCor2pcor(normRVM, corMat) -# -# # newRVM and newNormRVM are the same vine using only different naming: -# newNormRVM$par - newRVM$par -# -# # the variable now do have a different ordering in the correlation matrix -# newNormCor <- cor(qnorm(RVineSim(100000, newNormRVM))) -# round(newNormCor,2) -# -# # permuted, they meet the initial correlation matrix up to +/- 0.01 -# round(newNormCor[c(1,4,3,2,5),c(1,4,3,2,5)]-corMat, 2) -# -# # re-order names of the normalised RVine generating a new RVine -# normRVM2 <- normRVM -# normRVM2$names <- c("V1", "V2", "V3", "V4", "V5") -# -# # adjust the normalised RVine -# newNormRVM2 <- RVineCor2pcor(normRVM2, corMat) -# # check whether the parameters are different beyond permutation (that's why -# # permutation does not work) -# newNormRVM2$par -# newRVM$par -# -# # adjust the normalised RVine -# newNormRVM2 <- RVineCor2pcor(normRVM2, corMat[c(1,4,3,2,5),c(1,4,3,2,5)]) -# # check whether the parameters are now identical -# round(newNormRVM2$par - newRVM$par,2) -# -# # back and forth -# RVinePcor2cor(RVineCor2pcor(RVM, corMat))-corMat -# RVinePcor2cor(RVineCor2pcor(normRVM, corMat))-corMat -# RVinePcor2cor(RVineCor2pcor(normRVM2, corMat))-corMat Modified: pkg/src/cdvine.c =================================================================== --- pkg/src/cdvine.c 2015-09-21 16:16:45 UTC (rev 142) +++ pkg/src/cdvine.c 2015-09-22 16:37:17 UTC (rev 143) @@ -1,611 +1,603 @@ -/* -** cdvine.c - C code of the package CDRVine -** -** with contributions from Carlos Almeida, Aleksey Min, -** Ulf Schepsmeier, Jakob Stoeber and Eike Brechmann -** -** A first version was based on code -** from Daniel Berg -** provided by personal communication. -** -*/ - - -// Include all the head files -#include "include/vine.h" // general one -#include "include/memoryhandling.h" // for creating two and three dimensional arrays -#include "include/likelihood.h" // formally main functionality; log-likelihood with help functions; bivariate densities -#include "include/cdvine.h" // Header file for this C-file -#include "include/hfunc.h" // h-functions, i.e. conditional densities; also inverse h-functions - -#define UMAX 1-1e-10 - -#define UMIN 1e-10 - -#define XEPS 1e-4 - - -////////////////////////////////////////////////////////////// -// Function to simulate from a C- or D-vine -// Input: -// n sample size -// d dimension (>= 2) -// type vine type (1=Canonical vine, 2=D-vine) -// family copula family (see help pages which families are now included) -// par parameter values (at least d*(d-1)/2 parameters) -// nu second parameter for t-copula, BB-copulas and Tawn -// -// Output: -// out two dimensional array of simulated data -//////////////////////////////////////////////////////////////// - -void pcc(int* n, int* d, int* family, int* type, double* par, double* nu, double* out) -{ - int i, j, in=1, k, **fam; - double *w, **v, t, **theta, **x, **ny; - - GetRNGstate(); //Init random number generator - //Allocate memory: - w = Calloc((*d+1),double); - - v = create_matrix(*d+1,2*(*d)-1); - theta = create_matrix(*d,*d); - x = create_matrix(*n+1,*d+1); - ny = create_matrix(*d,*d); - fam = create_intmatrix(*d,*d); - //Initialize dependency parameters - - // The function arguments are one-dimensional vectors; for better understanding the transform them back to matrices (see theory) - // This step may be updated in the future to optimize the algorithms - k = 0; - for(i=1;i<=*d-1;i++) - { - for(j=1;j<=*d-i;j++) - { - fam[i][j] = family[k]; - ny[i][j] = nu[k]; - theta[i][j] = par[k]; - k ++; - } - } - //Simulate: (it follows the theoretical algorithm) - if(*type==1) //Canonical vine - { - for(j=1;j<=*n;j++) // run over all observations (rows) - { - for(i=1;i<=*d;i++) w[i] = runif(0,1); - x[j][1] = w[1]; - for(i=2;i<=*d;i++) // run over all dimensions (cols) - { - t = w[i]; - for(k=i-1;k>=1;k--) - { - //Hinv1(&fam[k][i-k],&in, &v[i][1],&v[k][k],&theta[k][i-k],&ny[k][i-k],&v[i][1]); - Hinv1(&fam[k][i-k],&in, &t,&w[k],&theta[k][i-k],&ny[k][i-k],&t); - } - x[j][i] = t; - /*if(i<*d) - { - for(k=1;k=2;k--) - { - //printf("inv: %d,%d : %5.2f : %10.8f \t",k,i-k, theta[k][i-k], v[i-1][2*k-2]); - Hinv1(&fam[k][i-k],&in, &v[i][1],&v[i-1][2*k-2],&theta[k][i-k],&ny[k][i-k],&v[i][1]); - //printf("%10.8f \n",v[i][1]); - } - Hinv1(&fam[1][i-1],&in, &v[i][1],&v[i-1][1],&theta[1][i-1],&ny[1][i-1],&v[i][1]); - //printf("inv: %d,%d : %5.2f : %10.8f \t %10.8f \n",1,i-1, theta[1][i-1], v[i-1][1],v[i][1]); - // Compute conditional cdf's needed in next step: - if(i<*d) - { - Hfunc2(&fam[1][i-1],&in, &v[i-1][1],&v[i][1],&theta[1][i-1],&ny[1][i-1],&v[i][2]); - Hfunc1(&fam[1][i-1],&in, &v[i][1],&v[i-1][1],&theta[1][i-1],&ny[1][i-1],&v[i][3]); - if(i>3) - { - for(k=2;k<=(i-2);k++) - { - Hfunc2(&fam[k][i-k],&in, &v[i-1][2*k-2],&v[i][2*k-1],&theta[k][i-k],&ny[k][i-k],&v[i][2*k]); - Hfunc1(&fam[k][i-k],&in, &v[i][2*k-1],&v[i-1][2*k-2],&theta[k][i-k],&ny[k][i-k],&v[i][2*k+1]); - } - } - Hfunc2(&fam[i-1][1],&in, &v[i-1][2*i-4],&v[i][2*i-3],&theta[i-1][1],&ny[i-1][1],&v[i][2*i-2]); - } - } - for(i=1;i<=*d;i++) x[j][i] = v[i][1]; - } - } - //Write to output vector: - k = 0; - for(i=1;i<=*d;i++) - { - for(j=1;j<=*n;j++) - { - out[k] = x[j][i]; - k ++; - } - } - PutRNGstate(); // Function for the random number generator - //Free memory: - Free(w); free_matrix(v,*d+1); free_matrix(theta,*d); free_matrix(ny,*d); free_intmatrix(fam,*d); free_matrix(x,*n+1); -} - - - - -////////////////////////////////////////////////////////////// -// Function to compute -log-likelihood for C- and D-vine -// Input: -// n sample size -// d dimension (>=2) -// type vine type (1=canonical vine, 2=d-vine) -// family copula families -// par parameter values (at least d*(d-1)/2 parameters ) The second parameter is added at the end of par -// data data set for which to compute log-likelihood -// Output: -// out Log-likelihood -// ll array with the contribution to LL (for each copula) -// vv array for the transformation operated (Hfunc) -///////////////////////////////////////////////////////////// -void VineLogLikm(int* T, int* d, int* type, int* family, double* par, double* data, - double* out, double* ll, double* vv) -{ - int i, j, k, t, kk, **fam; - double loglik=0.0, sumloglik=0.0, **x, **theta, **nu, ***v; - - //Allocate memory: - x = create_matrix(*d+1,*T); - // By Ulf Schepsmeier - if(*type==1) //C-vine - { - v = create_3darray(*d-1,*d,*T); - } - else //D-vine - { - v = create_3darray(*d,2*(*d)-3,*T); - } - - theta = create_matrix(*d,*d); - nu = create_matrix(*d,*d); - fam = create_intmatrix(*d+1,*d+1); - - //Initialize: - k = 0; - for(i=1;i<=*d;i++) - { - for (t=0;t<=*T-1;t++ ) - { - x[i][t] = data[k]; //transform the data back into a 2-dim array - k++; - } - } - k = 0; - for(i=1;i<=(*d-1);i++) - { - for(j=1;j<=(*d-i);j++) - { - theta[i][j] = par[k]; - fam[i][j] = family[k]; - nu[i][j] = par[*d*(*d-1)/2+k]; // the second parameter is added at the end of par (not the best solution but was practise at the beginning) - k++; - } - } - - if(*type==1) //C-vine - { - // By Ulf Schepsmeier - kk=0; - //Compute likelihood at level 1: - for(i=1;i<*d;i++) - { - LL_mod2(&fam[1][i],T,x[1],x[i+1],&theta[1][i],&nu[1][i],&loglik); // call the bivariate log-likelihood function - //(with the correct rotation for 90, 180 and 270 degrees) - sumloglik += loglik; // sum up - ll[kk] = loglik; // store all bivariate log-likelihoods too - ++kk; - if(*d>2) - { - //Compute variables for next level: - Hfunc1(&fam[1][i],T,x[i+1],x[1],&theta[1][i],&nu[1][i],v[1][i]); - } - } - //Compute likelihood at next levels: - if(*d>2) - { - for(k=2;k<=(*d-1);k++) - { - for(i=1;i<=(*d-k);i++) - { - LL_mod2(&fam[k][i],T,v[k-1][1],v[k-1][i+1],&theta[k][i],&nu[k][i],&loglik); - sumloglik += loglik; - ll[kk] = loglik; - ++kk; - } - if(k<(*d-1)) - { - for (i=1;i<=(*d-k);i++) - { - Hfunc1(&fam[k][i],T,v[k-1][i+1],v[k-1][1],&theta[k][i],&nu[k][i],v[k][i]); - } - } - } - } - } - else if(*type==2) //D-vine - { - kk=0; - //Compute the likelihood at level 1: - for(i=1;i<*d;i++) - { - LL_mod2(&fam[1][i],T,x[i],x[i+1],&theta[1][i],&nu[1][i],&loglik); - sumloglik += loglik; - ll[kk] = loglik; - ++kk; - } - //Compute variables for next level: - if(*d>2) - { - Hfunc2(&fam[1][1],T,x[1],x[2],&theta[1][1],&nu[1][1],v[1][1]); - for(k=1;k<=(*d-3);k++) - { - Hfunc1(&fam[1][k+1],T,x[k+2],x[k+1],&theta[1][k+1],&nu[1][k+1],v[1][2*k]); - Hfunc2(&fam[1][k+1],T,x[k+1],x[k+2],&theta[1][k+1],&nu[1][k+1],v[1][2*k+1]); - } - Hfunc1(&fam[1][*d-1],T,x[*d],x[*d-1],&theta[1][*d-1],&nu[1][*d-1],v[1][2*(*d)-4]); - //Compute likelihood at next levels: - for(k=2;k<=(*d-1);k++) - { - for(i=1;i<=(*d-k);i++) - { - LL_mod2(&fam[k][i],T,v[k-1][2*i-1],v[k-1][2*i],&theta[k][i],&nu[k][i],&loglik); - sumloglik += loglik; - ll[kk] = loglik; ++kk; - } - if(k<(*d-1)) - { - Hfunc2(&fam[k][1],T,v[k-1][1],v[k-1][2],&theta[k][1],&nu[k][1],v[k][1]); - if((*d)>4) - { - for(i=1;i<=(*d-k-2);i++) - { - Hfunc1(&fam[k][i+1],T,v[k-1][2*i+2],v[k-1][2*i+1],&theta[k][i+1],&nu[k][i+1],v[k][2*i]); - Hfunc2(&fam[k][i+1],T,v[k-1][2*i+1],v[k-1][2*i+2],&theta[k][i+1],&nu[k][i+1],v[k][2*i+1]); - } - } - Hfunc1(&fam[k][*d-k],T,v[k-1][2*(*d)-2*k],v[k-1][2*(*d)-2*k-1],&theta[k][*d-k],&nu[k][*d-k],v[k][2*(*d)-2*k-2]); - } - } - } - } - //Write to output: - *out = -sumloglik; - kk=00; - // By Ulf Schepsmeier - if(*type==1) //C-Vine - { - if(*d>2) - { - for(k=1;k<(*d-1);k++) - for(i=1;i<=(*d-k);i++) - for(t=0;t<*T;t++) - { - vv[kk] = v[k][i][t]; // transformation from a 3-dim array to a vector - ++kk; - } - } - //Free memory: - free_3darray(v,*d-1,*d); - } - else //D-Vine - { - if(*d>2) - { - for(k=1;k<*d;k++) - for(i=1;i<=2*(*d-k-1);i++) - for(t=0;t<*T;t++) - { - vv[kk] = v[k][i][t]; - ++kk; - } - } - //Free memory: - free_3darray(v,*d,2*(*d)-3); - } - //Free memory: - free_matrix(x,*d+1); free_matrix(theta,*d); free_matrix(nu,*d); free_intmatrix(fam,*d+1); -} - -////////////////////////////////////////////////////////////// -// Function to compute an update of the log-likelihood for C- and D-vine -// Input: -// n sample size -// d dimension (>=2) -// type vine type (1=canonical vine, 2=d-vine) -// family copula families -// par parameter values (at least d*(d-1)/2 parameters -// mpar index of modified parameter (related to previous computation) -// data data set for which to compute log-likelihood -// ll array with the stored contribution of the likelihood in a previous computation -// vv 3d array array with the stored transformations in a previous computation -// Output: -// out log-likelihood (updated) -// ll array with the contribution to LL (for each copula) -// vv array for the transformation operated (Hfunc) -///////////////////////////////////////////////////////////// -void VineLogLikmP(int* T, int* d, int* type, int* family, double* par, int* mpar, double* data, - double* out, double* ll, double* vv) -{ - int i, j, ii, jj, k, t, kk,**fam, **ind; - double sumloglik=0.0,loglik=0.0, **x, **theta, **nu, ***v; - //Allocate memory: - x = create_matrix(*d+1,*T); - - // By Ulf Schepsmeier - if(*type==1) //C-vine - { - v = create_3darray(*d-1,*d,*T); - } - else //D-vine - { - v = create_3darray(*d,2*(*d)-3,*T); - } - - theta = create_matrix(*d,*d); - nu = create_matrix(*d,*d); - fam = create_intmatrix(*d,*d); - ind = create_intmatrix(*d,*d); - //Initialize: - k = 0; - for(i=1;i<=*d;i++) - { - for (t=0;t<=*T-1;t++ ) - { - x[i][t] = data[k]; - k++; - } - } - k = 0; - jj = *d; - ii = *d; - kk=00; - - // By Ulf Schepsmeier - if(*type==1) //C-Vine - { - for(i=1;i<=(*d-1);i++) - { - for(j=1;j<=(*d-1);j++) - { - ind[i][j] = 0; - if(j <= *d-i) - { - ++k; - if (k == *mpar) - { - ii=i; - jj=j; - } - if(ii+jj-i>0) - { - if(i>=ii && j==ii+jj-i) - { - ind[i][j]=1; - } - } - else if(ii+jj-i<=0) - { - ind[i][j]=1; - } - } - } - } - - for(k=1;k<*d-1;k++) - for(i=1;i<=*d-k;i++) - for(t=0;t<*T;t++) - { - v[k][i][t] = vv[kk]; - ++kk; - } - } - else //D-Vine - { - for(i=1;i<=(*d-1);i++) - { - for(j=1;j<=(*d-1);j++) - { - ind[i][j] = 0; - if(j <= *d-i) - { - ++k; - if (k == *mpar) - { - ii=i; - jj=j; - } - if(i >= ii && j >= ii+jj-i && j <= *d-i && j <= jj) - { - ind[i][j]=1; - } - // //printf("%d ", ind[i][j]); - } - } - // //printf("\n"); - } - - for(k=1;k<*d;k++) - for(i=1;i<=2*(*d-k-1);i++) - for(t=0;t<*T;t++) - { - v[k][i][t] = vv[kk]; - ++kk; - } - } - k=0; - for(i=1;i<=(*d-1);i++) - { - for(j=1;j<=(*d-i);j++) - { - theta[i][j] = par[k]; - fam[i][j] = family[k]; - nu[i][j] = par[*d*(*d-1)/2+k]; - k ++; - } - } - - - - if(*type==1) //C-vine - { - // By Ulf Schepsmeier - kk=0; - //Compute likelihood at level 1: - for(i=1;i<*d;i++) - { - if(ind[1][i]==1) - { - LL_mod2(&fam[1][i],T,x[1],x[i+1],&theta[1][i],&nu[1][i],&loglik); - ll[kk] = loglik; - if(*d>2) - { - //Compute variables for next level: - Hfunc1(&fam[1][i],T,x[i+1],x[1],&theta[1][i],&nu[1][i],v[1][i]); - } - } - sumloglik += ll[kk]; - ++kk; - } - //Compute likelihood at next levels: - if(*d>2) - { - for(k=2;k<=(*d-1);k++) - { - for(i=1;i<=(*d-k);i++) - { - if(ind[k][i]==1) - { - LL_mod2(&fam[k][i],T,v[k-1][1],v[k-1][i+1],&theta[k][i],&nu[k][i],&loglik); - ll[kk] = loglik; - if(k<(*d-1)) - { - Hfunc1(&fam[k][i],T,v[k-1][i+1],v[k-1][1],&theta[k][i],&nu[k][i],v[k][i]); - } - } - sumloglik += ll[kk]; - ++kk; - } - } - } - } - else if(*type==2) //D-vine - { - kk=0; - //Compute the likelihood at level 1: - for(i=1;i<*d;i++) - { - if(ind[1][i]==1) - { - LL_mod2(&fam[1][i],T,x[i],x[i+1],&theta[1][i],&nu[1][i],&loglik); - ll[kk] = loglik; - } - sumloglik += ll[kk]; - ++kk; - } - //Compute variables for next level: - if(*d>2) - { - if(ind[1][1]==1) Hfunc2(&fam[1][1],T,x[1],x[2],&theta[1][1],&nu[1][1],v[1][1]); - for(k=1;k<=(*d-3);k++) - if(ind[1][k+1]==1) - { - Hfunc1(&fam[1][k+1],T,x[k+2],x[k+1],&theta[1][k+1],&nu[1][k+1],v[1][2*k]); - Hfunc2(&fam[1][k+1],T,x[k+1],x[k+2],&theta[1][k+1],&nu[1][k+1],v[1][2*k+1]); - } - if(ind[1][*d-1]) Hfunc1(&fam[1][*d-1],T,x[*d],x[*d-1],&theta[1][*d-1],&nu[1][*d-1],v[1][2*(*d)-4]); - //Compute likelihood at next levels: - for(k=2;k<=(*d-1);k++) - { - for(i=1;i<=(*d-k);i++) - { - if(ind[k][i] == 1) - { - LL_mod2(&fam[k][i],T,v[k-1][2*i-1],v[k-1][2*i],&theta[k][i],&nu[k][i],&loglik); - ll[kk] = loglik; - } - sumloglik += ll[kk]; - ++kk; - } - if(k<(*d-1)) - { - if(ind[k][1] == 1) Hfunc2(&fam[k][1],T,v[k-1][1],v[k-1][2],&theta[k][1],&nu[k][1],v[k][1]); - if((*d)>4) - { - for(i=1;i<=(*d-k-2);i++) - { - if(ind[k][i+1]==1) - { - Hfunc1(&fam[k][i+1],T,v[k-1][2*i+2],v[k-1][2*i+1],&theta[k][i+1],&nu[k][i+1],v[k][2*i]); - Hfunc2(&fam[k][i+1],T,v[k-1][2*i+1],v[k-1][2*i+2],&theta[k][i+1],&nu[k][i+1],v[k][2*i+1]); - } - } - } - if(ind[k][*d-k]==1) Hfunc1(&fam[k][*d-k],T,v[k-1][2*(*d)-2*k],v[k-1][2*(*d)-2*k-1],&theta[k][*d-k],&nu[k][*d-k],v[k][2*(*d)-2*k-2]); - } - } - } - } - //Write to output: - *out = -sumloglik; - kk=00; - // By Ulf Schepsmeier - if(*type==1) //C-Vine - { - if(*d>2) - { - for(k=1;k<*d-1;k++) - for(i=1;i<=*d-k;i++) - for(t=0;t<*T;t++) - { - vv[kk] = v[k][i][t]; - ++kk; - } - } - //Free memory: - free_3darray(v,*d-1,*d); - } - else //D-Vine - { - if(*d>2) - { - for(k=1;k<*d;k++) - for(i=1;i<=2*(*d-k-1);i++) - for(t=0;t<*T;t++) - { - vv[kk] = v[k][i][t]; - ++kk; - } - } - //Free memory: - free_3darray(v,*d,2*(*d)-3); - } - //Free memory: - free_matrix(x,*d+1); free_matrix(theta,*d); free_matrix(nu,*d); free_intmatrix(fam,*d);free_intmatrix(ind,*d); -} +/* +** cdvine.c - C code of the package CDRVine +** +** with contributions from Carlos Almeida, Aleksey Min, +** Ulf Schepsmeier, Jakob Stoeber and Eike Brechmann +** +** A first version was based on code +** from Daniel Berg +** provided by personal communication. +** +*/ + + +// Include all the head files +#include "include/vine.h" // general one +#include "include/memoryhandling.h" // for creating two and three dimensional arrays +#include "include/likelihood.h" // formally main functionality; log-likelihood with help functions; bivariate densities +#include "include/cdvine.h" // Header file for this C-file +#include "include/hfunc.h" // h-functions, i.e. conditional densities; also inverse h-functions + +#define UMAX 1-1e-10 + +#define UMIN 1e-10 + +#define XEPS 1e-4 + + +////////////////////////////////////////////////////////////// +// Function to simulate from a C- or D-vine +// Input: +// n sample size +// d dimension (>= 2) +// type vine type (1=Canonical vine, 2=D-vine) +// family copula family (see help pages which families are now included) +// par parameter values (at least d*(d-1)/2 parameters) +// nu second parameter for t-copula, BB-copulas and Tawn +// +// Output: +// out two dimensional array of simulated data +//////////////////////////////////////////////////////////////// + +void pcc(int* n, int* d, int* family, int* type, double* par, double* nu, double* out) +{ + int i, j, in=1, k, **fam; + double *w, **v, t, **theta, **x, **ny; + + GetRNGstate(); //Init random number generator + //Allocate memory: + w = Calloc((*d+1),double); + + v = create_matrix(*d+1,2*(*d)-1); + theta = create_matrix(*d,*d); + x = create_matrix(*n+1,*d+1); + ny = create_matrix(*d,*d); + fam = create_intmatrix(*d,*d); + //Initialize dependency parameters + + // The function arguments are one-dimensional vectors; for better understanding the transform them back to matrices (see theory) + // This step may be updated in the future to optimize the algorithms + k = 0; + for(i=1;i<=*d-1;i++) + { + for(j=1;j<=*d-i;j++) + { + fam[i][j] = family[k]; + ny[i][j] = nu[k]; + theta[i][j] = par[k]; + k ++; + } + } + //Simulate: (it follows the theoretical algorithm) + if(*type==1) //Canonical vine + { + for(j=1;j<=*n;j++) // run over all observations (rows) + { + for(i=1;i<=*d;i++) w[i] = runif(0,1); + x[j][1] = w[1]; + for(i=2;i<=*d;i++) // run over all dimensions (cols) + { + t = w[i]; + for(k=i-1;k>=1;k--) + { + Hinv1(&fam[k][i-k],&in, &t,&w[k],&theta[k][i-k],&ny[k][i-k],&t); + } + x[j][i] = t; + } + } + } + else if(*type==2) //D-vine + { + for(j=1;j<=*n;j++) + { + for(i=1;i<=*d;i++) { w[i] = runif(0,1);} + v[1][1] = w[1]; + v[2][1] = w[2]; + + Hinv1(&fam[1][1],&in,&w[2],&v[1][1],&theta[1][1],&ny[1][1],&v[2][1]); + Hfunc2(&fam[1][1],&in, &v[1][1],&v[2][1],&theta[1][1],&ny[1][1],&v[2][2]); + for(i=3;i<=*d;i++) + { + v[i][1] = w[i]; + + for(k=i-1;k>=2;k--) + { + Hinv1(&fam[k][i-k],&in, &v[i][1],&v[i-1][2*k-2],&theta[k][i-k],&ny[k][i-k],&v[i][1]); + } + Hinv1(&fam[1][i-1],&in, &v[i][1],&v[i-1][1],&theta[1][i-1],&ny[1][i-1],&v[i][1]); + + // Compute conditional cdf's needed in next step: + if(i<*d) + { + Hfunc2(&fam[1][i-1],&in, &v[i-1][1],&v[i][1],&theta[1][i-1],&ny[1][i-1],&v[i][2]); + Hfunc1(&fam[1][i-1],&in, &v[i][1],&v[i-1][1],&theta[1][i-1],&ny[1][i-1],&v[i][3]); + if(i>3) + { + for(k=2;k<=(i-2);k++) + { + Hfunc2(&fam[k][i-k],&in, &v[i-1][2*k-2],&v[i][2*k-1],&theta[k][i-k],&ny[k][i-k],&v[i][2*k]); + Hfunc1(&fam[k][i-k],&in, &v[i][2*k-1],&v[i-1][2*k-2],&theta[k][i-k],&ny[k][i-k],&v[i][2*k+1]); + } + } + Hfunc2(&fam[i-1][1],&in, &v[i-1][2*i-4],&v[i][2*i-3],&theta[i-1][1],&ny[i-1][1],&v[i][2*i-2]); + } + } + for(i=1;i<=*d;i++) x[j][i] = v[i][1]; + } + } + //Write to output vector: + k = 0; + for(i=1;i<=*d;i++) + { + for(j=1;j<=*n;j++) + { [TRUNCATED] To get the complete diff run: svnlook diff /svnroot/vinecopula -r 143