[Vinecopula-commits] r126 - in pkg: . R man
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Mo Aug 24 22:03:27 CEST 2015
Author: tnagler
Date: 2015-08-24 22:03:25 +0200 (Mon, 24 Aug 2015)
New Revision: 126
Added:
pkg/R/plot.RVineMatrix.R
pkg/man/plot.RVineMatrix.Rd
Modified:
pkg/DESCRIPTION
pkg/NAMESPACE
Log:
* add 'network' package to imports
* new generic for plot.RVineMatrix based on 'plot.network' (+ manual)
Modified: pkg/DESCRIPTION
===================================================================
--- pkg/DESCRIPTION 2015-08-24 19:58:54 UTC (rev 125)
+++ pkg/DESCRIPTION 2015-08-24 20:03:25 UTC (rev 126)
@@ -1,13 +1,13 @@
-Package: VineCopula
-Type: Package
-Title: Statistical Inference of Vine Copulas
-Version: 1.7
-Date: 2015-08-10
-Author: Ulf Schepsmeier, Jakob Stoeber, Eike Christian Brechmann, Benedikt Graeler, Thomas Nagler, Tobias Erhardt
-Maintainer: Tobias Erhardt <tobias.erhardt at tum.de>
-Depends: R (>= 2.11.0)
-Imports: graphics, grDevices, stats, utils, MASS, mvtnorm, igraph (>= 1.0.0), 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)
-LazyLoad: yes
+Package: VineCopula
+Type: Package
+Title: Statistical Inference of Vine Copulas
+Version: 1.7
+Date: 2015-08-10
+Author: Ulf Schepsmeier, Jakob Stoeber, Eike Christian Brechmann, Benedikt Graeler, Thomas Nagler, Tobias Erhardt
+Maintainer: Tobias Erhardt <tobias.erhardt at tum.de>
+Depends: R (>= 2.11.0)
+Imports: graphics, grDevices, stats, utils, MASS, mvtnorm, igraph (>= 1.0.0), 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)
+LazyLoad: yes
Modified: pkg/NAMESPACE
===================================================================
--- pkg/NAMESPACE 2015-08-24 19:58:54 UTC (rev 125)
+++ pkg/NAMESPACE 2015-08-24 20:03:25 UTC (rev 126)
@@ -1,14 +1,19 @@
-import("graphics")
-import("grDevices")
-import("stats")
-import("utils")
import(MASS)
import(mvtnorm)
import(copula)
import(methods)
import(lattice)
+import(network)
-importFrom(ADGofTest, ad.test)
+importFrom("grDevices", "colorRampPalette", "rgb", "terrain.colors")
+importFrom("graphics", "abline", "box", "hist", "legend", "lines",
+ "pairs", "par", "points", "strwidth", "text")
+importFrom("stats", "cor", "dexp", "dgamma", "dnorm", "dt",
+ "integrate", "ks.test", "optim", "optimize", "pbinom",
+ "pchisq", "pexp", "pgamma", "pnorm", "pt", "qexp", "qgamma",
+ "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",
@@ -110,5 +115,6 @@
S3method(as.copuladata, list)
S3method(pairs, copuladata)
S3method(plot, BiCop)
+S3method(plot, RVineMatrix)
useDynLib("VineCopula")
Added: pkg/R/plot.RVineMatrix.R
===================================================================
--- pkg/R/plot.RVineMatrix.R (rev 0)
+++ pkg/R/plot.RVineMatrix.R 2015-08-24 20:03:25 UTC (rev 126)
@@ -0,0 +1,263 @@
+plot.RVineMatrix <- function(x, tree = "ALL", type = 0, edge.labels = NULL, interactive = FALSE, ...) {
+ M <- x$Matrix
+ d <- nrow(M)
+
+ ## sanity checks
+ if (!inherits(x, "RVineMatrix"))
+ stop("'x' has to be an RVineMatrix object.")
+ if (tree != "ALL" && tree > d - 1)
+ stop("Selected tree does not exist.")
+ if (any(tree == "ALL") )
+ tree <- 1:(d - 1)
+ if (!all(type %in% c(0, 1, 2)))
+ stop("type not implemented")
+ stopifnot(is.logical(interactive))
+
+ ## set names if empty
+ if (is.null(x$names))
+ x$names <- paste("V", 1:d, sep = "")
+
+ #### set up plotting options ----------------------------
+ ## defaults (to be improved)
+ dflt <- list(interactive = interactive,
+ displaylabels = TRUE,
+ pad = 1e-1,
+ boxed.labels = TRUE,
+ label.pos = 7,
+ label.pad = 0.5)
+
+ ## overwrite defaults with ... argument
+ lst <- list(...)
+ final.args <- modifyList(dflt, lst)
+
+ #### loop through the trees -----------------------------
+ for (i in tree) {
+
+ ## create network object
+ g <- makeNetwork(x, i, !(type %in% c(0, 2)))
+ final.args$x = g$nw
+
+ ## set edge labels
+ if (!is.null(edge.labels))
+ final.args$edge.label <- set_edge_labels(tree = i,
+ RVM = x,
+ edge.labels = edge.labels,
+ type = type)
+
+ ## plot tree
+ main <- paste("Tree ", i, sep = "")
+ do.call(plot, final.args)
+
+ ## add legend
+ if (type == 2) {
+ legend("bottomleft", legend = paste(1:d, x$name, sep = "<->"),
+ bty = "n", xjust = 0)
+ }
+
+ ## wait for key stroke
+ if (i != max(tree)) {
+ par(ask = TRUE)
+ } else {
+ par(ask = FALSE)
+ }
+ }
+}
+
+## creates a network object for a tree in a given RVineMatrix ------------------
+makeNetwork <- function(RVM, tree, use.names = FALSE) {
+ M <- RVM$Matrix
+ d <- ncol(M)
+
+ I <- matrix(0, d - tree + 1, d - tree + 1)
+
+ ## extract node and edge labels as numbers
+ if (tree > 1) {
+ node.lab <- sapply(1:(d - tree + 1),
+ get_num,
+ tree = tree - 1,
+ RVM = RVM)
+ } else {
+ node.lab <- paste(diag(M))
+ }
+ edge.lab <- sapply(seq.int(d - tree),
+ get_num,
+ tree = tree,
+ RVM = RVM)
+
+ ## convert to numeric matrices V and E
+ V <- t(sapply(strsplit(node.lab, " *[,;] *"), as.numeric))
+ V <- matrix(V, ncol = tree)
+ E <- t(sapply(strsplit(edge.lab, " *[,;] *"), as.numeric))
+
+ ## build incident matrix by matching V and E
+ for (i in 1:nrow(E)) {
+ ind.i <- which(apply(V, 1, function(x) all(x %in% E[i, ])))
+ I[ind.i[1], ind.i[2]] <- I[ind.i[1], ind.i[2]] <- 1
+ }
+
+ ## convert to variable names (if asked for)
+ if (use.names) {
+ if (tree > 1) {
+ node.lab <- sapply(1:(d - tree + 1),
+ get_name,
+ tree = tree - 1,
+ RVM = RVM)
+ } else {
+ node.lab <- RVM$names
+ }
+ }
+
+ ## create network
+ colnames(I) <- rownames(I) <- node.lab
+ nw <- network(I, directed = FALSE)
+
+ ## return network and labels
+ list(nw = nw, vlabs = node.lab)
+}
+
+## finds appropriate edge labels for the plot ----------------------------------
+set_edge_labels <- function(tree, RVM, edge.labels, type) {
+ d <- nrow(RVM$Matrix)
+ if (edge.labels[1] == "family") {
+ elabel <- sapply(1:(d - tree + 1),
+ get_family,
+ tree = tree,
+ RVM = RVM)
+ elabel <- BiCopName(as.numeric(elabel))
+ } else if (edge.labels[1] == "par") {
+ elabel <- sapply(1:(d - tree + 1),
+ get_par,
+ tree = tree,
+ RVM = RVM)
+ } else if (edge.labels[1] == "tau") {
+ elabel <- sapply(1:(d - tree + 1),
+ get_tau,
+ tree = tree,
+ RVM = RVM)
+ } else if (edge.labels[1] == "family-par") {
+ elabel1 <- sapply(1:(d - tree + 1),
+ get_family,
+ tree = tree,
+ RVM = RVM)
+ elabel1 <- BiCopName(as.numeric(elabel1))
+ elabel2 <- sapply(1:(d - tree + 1),
+ get_par,
+ tree = tree,
+ RVM = RVM)
+ elabel <- paste0(elabel1, "(", elabel2, ")")
+ elabel <- sapply(elabel,
+ function(x){
+ tmp <- gsub("((", "(", x, fixed = TRUE)
+ gsub("))", ")", tmp, fixed = TRUE)
+ })
+ } else if (edge.labels[1] == "family-tau") {
+ elabel1 <- sapply(1:(d - tree + 1),
+ get_family,
+ tree = tree,
+ RVM = RVM)
+ elabel1 <- BiCopName(as.numeric(elabel1))
+ elabel2 <- sapply(1:(d - tree + 1),
+ get_tau,
+ tree = tree,
+ RVM = RVM)
+ elabel <- paste0(elabel1, "(", elabel2, ")")
+ } else if (length(edge.labels) > 1) {
+ # user may provide own labels
+ if (length(edge.labels) == d - tree) {
+ elabel <- as.character(edge.labels)
+ } else {
+ stop("length of edge.labels does not equal the number of edges in the tree")
+ }
+ } else if (edge.labels[1] == "pair"){
+ if (type %in% c(0, 2)) {
+ elabel <- sapply(1:(d - tree + 1),
+ get_num,
+ tree = tree,
+ RVM = RVM)
+ } else {
+ elabel <- sapply(1:(d - tree + 1),
+ get_name,
+ tree = tree,
+ RVM = RVM)
+ }
+ } else {
+ stop("edge.labels not implemented")
+ }
+
+ elabel
+}
+
+get_num <- function(j, tree, RVM) {
+ M <- RVM$Matrix
+ d <- nrow(M)
+ # get numbers from structure matrix
+ nums <- as.character(M[c(j, (d - tree + 1):d), j])
+ # conditioned set
+ bef <- paste(nums[2],
+ nums[1],
+ sep = ",",
+ collapse = "")
+ # conditioning set
+ aft <- if (length(nums) > 2) {
+ gsub(" ",
+ ",",
+ do.call(paste, as.list(as.character(nums[3:length(nums)]))))
+ } else ""
+ # paste together
+ sep <- if (length(nums) > 2) " ; " else ""
+ paste(bef, aft, sep = sep, collapse = "")
+}
+
+get_name <- function(j, tree, RVM) {
+ M <- RVM$Matrix
+ d <- nrow(M)
+ # variable names
+ nams <- RVM$names[M[c(j, (d - tree + 1):d), j]]
+ # conditioned set
+ bef <- paste(nams[2],
+ nams[1],
+ sep = ",",
+ collapse = "")
+ # conditioning set
+ aft <- if (length(nams) > 2) {
+ gsub(" ", ",", do.call(paste, as.list(nams[3:length(nams)])))
+ } else ""
+ # paste together
+ sep <- if (length(nams) > 2) " ; " else ""
+ paste(bef, aft, sep = sep, collapse = "")
+}
+
+get_family <- function(j, tree, RVM) {
+ d <- nrow(RVM$family)
+ M <- RVM$Matrix
+ paste(RVM$family[M[d - tree + 1, j]])
+}
+
+get_par <- function(j, tree, RVM) {
+ d <- nrow(RVM$family)
+ M <- RVM$Matrix
+ # get parameters
+ par <- round(RVM$par[M[d - tree + 1, j]], digits = 2)
+ par2 <- round(RVM$par2[M[d - tree + 1, j]], digits = 2)
+ # add brackets if par2 != 0
+ apply(cbind(par, par2), 1, join_par)
+}
+
+join_par <- function(x) {
+ if (x[2] != 0)
+ return(paste0("(", x[1], ",", x[2], ")"))
+ x[1]
+}
+
+get_tau <- function(j, tree, RVM) {
+ d <- nrow(RVM$family)
+ M <- RVM$Matrix
+ # get family and parameters
+ family <- RVM$family[M[d - tree + 1, j]]
+ par <- RVM$par[M[d - tree + 1, j]]
+ par2 <- RVM$par2[M[d - tree + 1, j]]
+ # convert to Kendall's tau
+ tau <- BiCopPar2Tau(family, par, par2, check.pars = FALSE)
+ round(tau, digits = 2)
+}
+
Added: pkg/man/plot.RVineMatrix.Rd
===================================================================
--- pkg/man/plot.RVineMatrix.Rd (rev 0)
+++ pkg/man/plot.RVineMatrix.Rd 2015-08-24 20:03:25 UTC (rev 126)
@@ -0,0 +1,75 @@
+\name{plot.RVineMatrix}
+\alias{plot.RVineMatrix}
+%- Also NEED an '\alias' for EACH other topic documented here.
+\title{
+Plotting \code{RVineMatrix} objects.
+}
+\description{
+This function plots one or all trees of a given R-vine copula model. Edges can be labeld with information about the corresponding pair-copula.
+}
+\usage{
+\method{plot}{RVineMatrix}(x, tree = "ALL", type = 0, edge.labels = NULL, interactive = FALSE, ...)
+}
+%- maybe also 'usage' for other objects documented here.
+\arguments{
+ \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{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}}.
+}
+}
+\author{
+Thomas Nagler
+}
+
+
+%% ~Make other sections like Warning with \section{Warning }{....} ~
+
+\seealso{
+\code{\link[VineCopula:RVineMatrix]{RVineMatrix}},
+\code{\link[network:plot.network]{plot.network}}
+\code{\link[VineCopula:BiCopName]{BiCopName}}
+}
+\examples{
+## build vine model
+strucmat <- matrix(c(3,1,2,0,2,1,0,0,1),3,3)
+fammat <- matrix(c(0,1,6,0,0,3,0,0,0),3,3)
+parmat <- matrix(c(0,0.3,3,0,0,1,0,0,0),3,3)
+par2mat <- matrix(c(0,0,0,0,0,0,0,0,0),3,3)
+RVM <- RVineMatrix(Matrix=strucmat, family=fammat, par=parmat, par2=par2mat)
+
+# plot trees
+plot(RVM)
+
+## build new model
+# simulate from previous model
+u <- RVineSim(500, RVM)
+colnames(u) <- c("A", "B", "C")
+
+# estimate new model
+RVM2 <- RVineStructureSelect(u)
+
+# plot new model with variable names ...
+plot(RVM2, type = 1)
+
+# annotate edge with pair-copula family and parameter
+plot(RVM2, type = 1, edge.labels = "family-par")
+
+}
+% Add one or more standard keywords, see file 'KEYWORDS' in the
+% R documentation directory.
+\keyword{plot}
\ No newline at end of file
Mehr Informationen über die Mailingliste Vinecopula-commits