[Vinecopula-commits] r129 - in pkg: . R man
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Fr Aug 28 19:01:08 CEST 2015
Author: tnagler
Date: 2015-08-28 19:01:07 +0200 (Fri, 28 Aug 2015)
New Revision: 129
Modified:
pkg/NAMESPACE
pkg/R/plot.BiCop.R
pkg/R/plot.RVineMatrix.R
pkg/man/plot.RVineMatrix.Rd
Log:
* improved aesthetics of plot.RVineMatrix
* new generic contour.RVineMatrix
* minor adjustments to levels/xylim defaults in plot.BiCop
Modified: pkg/NAMESPACE
===================================================================
--- pkg/NAMESPACE 2015-08-24 20:10:56 UTC (rev 128)
+++ pkg/NAMESPACE 2015-08-28 17:01:07 UTC (rev 129)
@@ -5,9 +5,10 @@
import(lattice)
import(network)
-importFrom("grDevices", "colorRampPalette", "rgb", "terrain.colors")
+importFrom("grDevices", "colorRampPalette", "rgb", "terrain.colors", "col2rgb")
importFrom("graphics", "abline", "box", "hist", "legend", "lines",
- "pairs", "par", "points", "strwidth", "text")
+ "pairs", "par", "points", "strwidth", "text",
+ "plot.new", "polygon", "strheight")
importFrom("stats", "cor", "dexp", "dgamma", "dnorm", "dt",
"integrate", "ks.test", "optim", "optimize", "pbinom",
"pchisq", "pexp", "pgamma", "pnorm", "pt", "qexp", "qgamma",
@@ -116,5 +117,6 @@
S3method(pairs, copuladata)
S3method(plot, BiCop)
S3method(plot, RVineMatrix)
+S3method(contour, RVineMatrix)
useDynLib("VineCopula")
Modified: pkg/R/plot.BiCop.R
===================================================================
--- pkg/R/plot.BiCop.R 2015-08-24 20:10:56 UTC (rev 128)
+++ pkg/R/plot.BiCop.R 2015-08-28 17:01:07 UTC (rev 129)
@@ -39,7 +39,7 @@
stop("'margins' has to be one of 'unif' or 'norm'")
if (is.null(list(...)$xlim) & is.null(list(...)$ylim)) {
xylim <- switch(margins,
- "unif" = c(0, 1),
+ "unif" = c(1e-1, 1 - 1e-1),
"norm" = c(-3, 3))
} else {
xylim <- range(c(list(...)$xlim, list(...)$ylim))
@@ -60,15 +60,15 @@
adj <- 1
gu <- g[, 1L]
gv <- g[, 2L]
- levels <- c(0.1, 0.5, 1, 3, 5, 10, 20)
+ 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))
} else if (margins == "norm") {
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])
- levels <- c(0.02, 0.05, 0.1, 0.15, 0.2, 0.3, 0.4, 0.5)
xlim <- ylim <- c(-3, 3)
at <- seq(0, 1, l = 100)
}
Modified: pkg/R/plot.RVineMatrix.R
===================================================================
--- pkg/R/plot.RVineMatrix.R 2015-08-24 20:10:56 UTC (rev 128)
+++ pkg/R/plot.RVineMatrix.R 2015-08-28 17:01:07 UTC (rev 129)
@@ -1,4 +1,5 @@
-plot.RVineMatrix <- function(x, tree = "ALL", type = 0, edge.labels = NULL, interactive = FALSE, ...) {
+plot.RVineMatrix <- function(x, tree = "ALL", type = 0, edge.labels = NULL, legend.pos = "bottomleft", interactive = FALSE, ...) {
+
M <- x$Matrix
d <- nrow(M)
@@ -18,21 +19,44 @@
x$names <- paste("V", 1:d, sep = "")
#### set up plotting options ----------------------------
- ## defaults (to be improved)
+ # 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))
+
+ # set plot.network options
+ TUMlightblue <- rgb(red = 100, green = 160, blue = 200, maxColorValue = 255)
dflt <- list(interactive = interactive,
displaylabels = TRUE,
- pad = 1e-1,
+ pad = 1.5e-1,
+ edge.lwd = 0.35,
+ edge.col = "gray43",
boxed.labels = TRUE,
+ label.pad = 1.5,
+ label.bg = TUMlightblue,
label.pos = 7,
- label.pad = 0.5)
+ label.col = "gray97",
+ label.cex = 1.3,
+ vertex.cex = 0,
+ object.scale = 0.05)
+ # Same color for edges, edge labels and label borders
+ dflt <- append(dflt, list(label.border = dflt$edge.col,
+ edge.label.col = dflt$edge.col,
+ edge.label.cex = dflt$label.cex - 0.2))
## overwrite defaults with ... argument
lst <- list(...)
- final.args <- modifyList(dflt, lst)
+ temp.args <- modifyList(dflt, lst)
#### loop through the trees -----------------------------
for (i in tree) {
+ main <- list(main = paste("Tree ", i, sep = ""),
+ col.main = ifelse("col.main" %in% names(temp.args),
+ temp.args$col.main,
+ temp.args$edge.col))
+ final.args <- append(temp.args, main)
+
## create network object
g <- makeNetwork(x, i, !(type %in% c(0, 2)))
final.args$x = g$nw
@@ -44,14 +68,16 @@
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)
+ legend(legend.pos,
+ legend = paste(1:d, x$name, sep = " \U002194 "),
+ bty = "n",
+ xjust = 0,
+ text.col = final.args$edge.col,
+ cex = final.args$label.cex)
}
## wait for key stroke
@@ -63,6 +89,161 @@
}
}
+
+## -----------------------------------------------------------------------------
+## 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
@@ -115,6 +296,7 @@
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)
@@ -187,6 +369,8 @@
elabel
}
+
+## get info for a pair-copula from RVineMatrix object --------------------------
get_num <- function(j, tree, RVM) {
M <- RVM$Matrix
d <- nrow(M)
Modified: pkg/man/plot.RVineMatrix.Rd
===================================================================
--- pkg/man/plot.RVineMatrix.Rd 2015-08-24 20:10:56 UTC (rev 128)
+++ pkg/man/plot.RVineMatrix.Rd 2015-08-28 17:01:07 UTC (rev 129)
@@ -1,16 +1,24 @@
\name{plot.RVineMatrix}
\alias{plot.RVineMatrix}
-%- Also NEED an '\alias' for EACH other topic documented here.
+\alias{contour.RVineMatrix}
+
\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.
+There are two plotting generics for \code{RVineMatrix} objects. \code{plot.RVineMatrix} plots one or all trees of a given R-vine copula model. Edges can be labeld with information about the corresponding pair-copula. \code{contour.RVineMatrix} produces a matrix of contour plots (using \code{\link[VineCopula:plot.BiCop]{plot.BiCop}}).
}
+
+
\usage{
-\method{plot}{RVineMatrix}(x, tree = "ALL", type = 0, edge.labels = NULL, interactive = FALSE, ...)
+\method{plot}{RVineMatrix}(x, tree = "ALL", type = 0, edge.labels = NULL, legend.pos = "bottomleft",
+ interactive = FALSE, ...)
+\method{contour}{RVineMatrix}(x, tree = "ALL", xylim = NULL, cex.nums = 1, ...)
}
-%- 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.}
@@ -26,31 +34,42 @@
\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{xylim}{numeric vector of length 2; sets \code{xlim} and \code{ylim} for the contours}
+ \item{cex.nums}{numeric; expansion factor for font of the numbers.}
\item{\dots}{
-Arguments passed to \code{\link[network:plot.network]{plot.network}}.
+Arguments passed to \code{\link[network:plot.network]{plot.network}} or \code{\link[VineCopula:plot.BiCop]{plot.BiCop}} respectively.}
}
+
+
+\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.
}
+
+
\author{
-Thomas Nagler
+Thomas Nagler, Nicole Barthel
}
-%% ~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}}
+\code{\link[network:plot.network]{plot.network}},
+\code{\link[VineCopula:plot.BiCop]{plot.BiCop}},
+\code{\link[VineCopula:BiCopName]{BiCopName}},
+\code{\link[graphics:legend]{legend}}
}
+
+
\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)
+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(strucmat, fammat, parmat, par2mat)
# plot trees
plot(RVM)
@@ -58,18 +77,18 @@
## build new model
# simulate from previous model
u <- RVineSim(500, RVM)
-colnames(u) <- c("A", "B", "C")
+colnames(u) <- c("X", "Y", "Z")
# estimate new model
RVM2 <- RVineStructureSelect(u)
-# plot new model with variable names ...
+\dontrun{
+# plot new model with legend
plot(RVM2, type = 1)
-# annotate edge with pair-copula family and parameter
-plot(RVM2, type = 1, edge.labels = "family-par")
+# show contour plots
+contour(RVM2)
+}
+}
-}
-% 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