[Vinecopula-commits] r140 - in pkg: . R man
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Mo Sep 21 17:22:20 CEST 2015
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.
Mehr Informationen über die Mailingliste Vinecopula-commits