Nothing
## Default 2d plot functions based on grid
##' @title Plot of labels indicating adjacent groups using the grid package
##' @family default 2d plot functions using the grid package
##' @family default 2d plot functions
##' @name group_2d_grid
##' @aliases group_2d_grid
##' @param zargs argument list as passed from \code{\link{zenplot}()}
##' @param glabs group labels being indexed by the plot variables
##' (and thus of length as the number of variables);
##' if NULL then they are determined with extract_2d()
##' @param sep group label separator
##' @param loc (x,y)-location in [0,1]^2; 0 corresponds to left, 1 to right (in
##' the direction of the path)
##' @param draw logical indicating whether drawing should take place
##' @param ... additional arguments passed to gpar()
##' @return grob (invisibly)
##' @author Marius Hofert
##' @note For performance reasons (avoiding having to call extract_2d() twice),
##' 'glabs' is an extra argument
##' @export
group_2d_grid <- function(zargs,
glabs = NULL, sep = "\n", loc = c(0.5, 0.5),
draw = FALSE, ...)
{
check_zargs(zargs, "turns", "vars", "num", "ispace")
turns <- zargs$turns
vars <- zargs$vars
num <- zargs$num
ii <- range(vars[num,]) # variable index
ii <- if(turns[num-1] == "u" || turns[num] == "u") rev(ii) else ii
if(is.null(glabs)) {
glabs <- extract_2d(zargs)$glabs
} else {
len.groups <- length(unlist(zargs$x, recursive = FALSE))
if(length(glabs) != len.groups)
stop("length(glabs) has to equal the number ",len.groups," of variables in all groups together; consider rep()")
}
labs <- paste0(glabs[ii], collapse = sep) # labels (in the correct order for displaying the group change)
## Plotting
vp <- vport(zargs$ispace)
res <- textGrob(label = labs, x = loc[1], y = loc[2],
default.units = "npc",
name = "group_2d", gp = gpar(...), vp = vp)
if(draw) grid.draw(res)
invisible(res)
}
##' @title Point plot in 2d using the grid package
##' @family default 2d plot functions using the grid package
##' @family default 2d plot functions
##' @name points_2d_grid
##' @aliases points_2d_grid
##' @param zargs argument list as passed from \code{\link{zenplot}()}
##' @param type line type
##' @param pch plot symbol
##' @param size size of the plot symbol
##' @param box logical indicating whether a box should be drawn
##' @param box.width width of the box
##' @param box.height height of the box
##' @param group... list of arguments passed to group_2d_grid (or NULL)
##' @param draw logical indicating whether drawing should take place
##' @param ... additional arguments passed to gpar()
##' @return grob (invisibly)
##' @author Marius Hofert and Wayne Oldford
##' @note - We use names depending on the 'type' here since otherwise, if one calls it
##' once for 'p' and once for 'l', only one of them is plotted
##' - The default point size was chosen to match the default of graphics
##' @export
points_2d_grid <- function(zargs,
type = c("p", "l", "o"), pch = NULL, size = 0.02,
box = FALSE, box.width = 1, box.height = 1,
group... = list(cex = 0.66), draw = FALSE, ...)
{
r <- extract_2d(zargs)
xlim <- r$xlim
ylim <- r$ylim
x <- as.matrix(r$x) # for pointsGrob()
y <- as.matrix(r$y)
same.group <- r$same.group
check_zargs(zargs, "ispace")
res <- if(same.group) {
vp <- vport(zargs$ispace, xlim = xlim, ylim = ylim)
if(box)
gBox <- rectGrob(x = 0.5, y = 0.5,
width = box.width, height = box.height, # => plotting outside of viewport (space has been reserved by default ispace)
just = "centre", default.units = "npc",
name = "box_2d", gp = gpar(...), vp = vp)
type <- match.arg(type)
switch(type,
"p" = {
if(is.null(pch)) pch <- 21
gPoints <- pointsGrob(x = x, y = y, pch = pch,
size = unit(size, units = "npc"),
default.units = "native",
name = "points_2d", gp = gpar(...), vp = vp)
if(box) { # create a single grob
gTree(children = gList(gBox, gPoints)) # note: first box
} else {
gTree(children = gList(gPoints))
}
},
"l" = {
gLines <- linesGrob(x = x, y = y,
default.units = "native",
name = "lines_2d", gp = gpar(...), vp = vp)
if(box) { # create a single grob
gTree(children = gList(gBox, gLines)) # note: first box
} else {
gTree(children = gList(gLines))
}
},
"o" = {
if(is.null(pch)) pch <- 20
gLines <- linesGrob(x = x, y = y,
default.units = "native",
name = "lines_2d", gp = gpar(...), vp = vp)
gPoints <- pointsGrob(x = x, y = y, pch = pch,
size = unit(size, units = "npc"),
default.units = "native",
name = "points_2d", gp = gpar(...), vp = vp)
if(box) { # create a single grob
gTree(children = gList(gBox, gLines, gPoints)) # note: first box
} else {
gTree(children = gList(gLines, gPoints))
}
},
stop("Wrong 'type'"))
} else {
args <- c(list(zargs = zargs), group...)
do.call(group_2d_grid, args)
}
if(draw) grid.draw(res)
invisible(res)
}
##' @title Quantile-quantile plot in 2d using the grid package
##' @family default 2d plot functions using the grid package
##' @family default 2d plot functions
##' @name qq_2d_grid
##' @aliases qq_2d_grid
##' @param zargs argument list as passed from \code{\link{zenplot}()}
##' @param do.line logical indicating whether a line is drawn (through both
##' empirical c(0.25, 0.75)-quantiles)
##' @param lines... additional arguments passed to lines()
##' @param pch plot symbol
##' @param size size of the plot symbol
##' @param box logical indicating whether a box should be drawn
##' @param box.width width of the box
##' @param box.height height of the box
##' @param group... list of arguments passed to group_2d_grid (or NULL)
##' @param draw logical indicating whether drawing should take place
##' @param ... additional arguments passed to gpar()
##' @return grob (invisibly)
##' @author Marius Hofert and Wayne Oldford
##' @note - line iff both margins are of the same *type*
##' - The default point size was chosen to match the default of graphics
##' @export
qq_2d_grid <- function(zargs,
do.line = TRUE, lines... = NULL, pch = NULL, size = 0.02,
box = FALSE, box.width = 1, box.height = 1,
group... = list(cex = 0.66), draw = FALSE, ...)
{
r <- extract_2d(zargs)
xlim <- r$xlim
ylim <- r$ylim
x <- r$x
y <- r$y
same.group <- r$same.group
check_zargs(zargs, "ispace")
res <- if(same.group) {
vp <- vport(zargs$ispace, xlim = xlim, ylim = ylim)
## Calculation (see qqplot())
sx <- sort(x)
sy <- sort(y)
lenx <- length(sx)
leny <- length(sy)
if (leny < lenx)
sx <- approx(1L:lenx, sx, n = leny)$y
if (leny > lenx)
sy <- approx(1L:leny, sy, n = lenx)$y
## Plot
if(is.null(pch)) pch <- 21
gPoints <- pointsGrob(x = sx, y = sy, pch = pch,
size = unit(size, units = "npc"),
default.units = "native",
name = "points_2d", gp = gpar(...), vp = vp) # Q-Q plot
groblist <- list(gPoints)
if(do.line) {
qx <- quantile(x, probs = c(0.25, 0.75), na.rm = TRUE, names = FALSE)
qy <- quantile(y, probs = c(0.25, 0.75), na.rm = TRUE, names = FALSE)
slope <- diff(qy) / diff(qx)
intercept <- qy[1] - qx[1] * slope
## We can't just plot that as there is no abline() in grid. Evaluating
## the line at xlim and corresponding y-values slope * xvals + intercept
## could lie very well outside the plot region.
## We solve this here *brute force*
xvals <- seq(xlim[1], xlim[2], length.out = 1024)
yvals <- slope * xvals + intercept
ok <- (xlim[1] <= xvals) & (xvals <= xlim[2]) &
(ylim[1] <= yvals) & (yvals <= ylim[2])
vals <- cbind(xvals, yvals)[ok, ]
x0.x1 <- c(vals[1,1], vals[nrow(vals),1])
y0.y1 <- c(vals[1,2], vals[nrow(vals),2])
gLines <- linesGrob(x = x0.x1, y = y0.y1,
default.units = "native", name = "lines_2d",
gp = gpar(...), vp = vp) # Q-Q line
groblist <- c(list(gLines), groblist) # append to list
}
if(box) {
gBox <- rectGrob(x = 0.5, y = 0.5,
width = box.width, height = box.height, # => plotting outside of viewport (space has been reserved by default ispace)
just = "centre", default.units = "npc",
name = "box_2d", gp = gpar(...), vp = vp)
groblist <- c(list(gBox), groblist) # append to list
}
gTree(children = do.call(gList, groblist))
} else {
args <- c(list(zargs = zargs), group...)
do.call(group_2d_grid, args)
}
if(draw) grid.draw(res)
invisible(res)
}
##' @title Density plot in 2d using the grid package
##' @family default 2d plot functions using the grid package
##' @family default 2d plot functions
##' @name density_2d_grid
##' @aliases density_2d_grid
##' @param zargs argument list as passed from \code{\link{zenplot}()}
##' @param ngrids number of grid points in each direction. Can be scalar or
##' a length-2 integer vector.
##' @param ccol vector (which is then recycled to the appropriate length)
##' giving the color of the contours
##' @param clwd vector (which is then recycled to the appropriate length)
##' giving the line widths of the contours
##' @param clty vector (which is then recycled to the appropriate length)
##' giving the line types of the contours
##' @param box logical indicating whether a box should be drawn
##' @param box.width width of the box
##' @param box.height height of the box
##' @param group... list of arguments passed to group_2d_grid (or NULL)
##' @param draw logical indicating whether drawing should take place
##' @param ... additional arguments passed to gpar()
##' @return grob (invisibly)
##' @author Marius Hofert and Wayne Oldford
##' @note - We use names depending on the 'type' here since otherwise, if one calls it
##' once for 'p' and once for 'l', only one of them is plotted
##' - The default point size was chosen to match the default of graphics
##' @author Marius Hofert and Wayne Oldford
##' @export
density_2d_grid <- function(zargs,
ngrids = 25, ccol = NULL, clwd = 1, clty = 1,
box = FALSE, box.width = 1, box.height = 1,
group... = list(cex = 0.66), draw = FALSE, ...)
{
r <- extract_2d(zargs)
xlim <- r$xlim
ylim <- r$ylim
x <- r$x
y <- r$y
same.group <- r$same.group
check_zargs(zargs, "ispace")
res <- if(same.group) {
data <- na.omit(data.frame(x, y))
colnames(data) <- c("x", "y")
dens <- kde2d(data$x, data$y, n = ngrids, lims = c(xlim, ylim))
contours <- contourLines(dens$x, dens$y, dens$z)
levels <- sapply(contours, function(contour) contour$level) # list of contour levels
nLevels <- length(levels) # number of levels
uniqueLevels <- unique(levels) # unique levels (there could be more than one level curve with the same level)
nuLevels <- length(uniqueLevels)
if(is.null(ccol)) { # default grey scale colors
basecol <- c("grey80", "grey0")
palette <- colorRampPalette(basecol, space = "Lab")
ccol <- palette(nuLevels) # different color for each 1d plot
}
ccol <- rep_len(ccol, nuLevels)
clwd <- rep_len(clwd, nuLevels)
clty <- rep_len(clty, nuLevels)
## Match the levels in the unique levels
ccol. <- numeric(nLevels)
clwd. <- numeric(nLevels)
clty. <- numeric(nLevels)
for (i in 1:nuLevels) {
idx <- (1:nLevels)[levels == uniqueLevels[i]]
ccol.[idx] <- ccol[i]
clwd.[idx] <- clwd[i]
clty.[idx] <- clty[i]
}
## Plotting
vp <- vport(zargs$ispace, xlim = xlim, ylim = ylim, x = x, y = y)
if(box)
gBox <- rectGrob(x = 0.5, y = 0.5,
width = box.width, height = box.height, # => plotting outside of viewport (space has been reserved by default ispace)
just = "centre", default.units = "npc",
name = "box_2d", gp = gpar(...), vp = vp)
contourGrobs <- lapply(1:length(contours), # go over all contours
function(i) {
contour <- contours[[i]]
linesGrob(x = contour$x, y = contour$y,
gp = gpar(col = ccol.[i],
lwd = clwd.[i], lty = clty.[i], ...),
default.units = "native",
name = paste0("contour_",i), # note: have to be different!
vp = vp)
})
if(box) { # create a single grob
gTree(children = do.call(gList, args = c(contourGrobs, list(gBox))))
} else {
gTree(children = do.call(gList, args = contourGrobs))
}
} else {
args <- c(list(zargs = zargs), group...)
do.call(group_2d_grid, args)
}
if(draw) grid.draw(res)
invisible(res)
}
##' @title Axes arrow using the grid package
##' @family default 2d plot functions using the grid package
##' @family default 2d plot functions
##' @name axes_2d_grid
##' @aliases axes_2d_grid
##' @param zargs argument list as passed from \code{\link{zenplot}()}
##' @param angle angle of the arrow head (see ?arrow)
##' @param length length of the arrow in [0,1] from tip to base
##' @param type type of the arrow head (see ?arrow)
##' @param eps distance by which the axes are moved away from the plot region
##' @param group... list of arguments passed to group_2d_grid (or NULL)
##' @param draw logical indicating whether drawing should take place
##' @param ... additional arguments passed to gpar()
##' @return grob (invisibly)
##' @author Marius Hofert and Wayne Oldford
##' @note Inspired by https://stat.ethz.ch/pipermail/r-help/2004-October/059525.html
##' @export
axes_2d_grid <- function(zargs,
angle = 30, length = unit(0.05, "npc"), type = "open", eps = 0.02,
group... = list(cex = 0.66), draw = FALSE, ...)
{
r <- extract_2d(zargs)
xlim <- r$xlim
ylim <- r$ylim
x <- r$x
y <- r$y
same.group <- r$same.group
check_zargs(zargs, "ispace")
res <- if(same.group) {
vp <- vport(zargs$ispace, xlim = xlim, ylim = ylim, x = x, y = y)
x.grob <- linesGrob(x = unit(c(-eps, 1+eps), "npc"),
y = unit(c(-eps, -eps), "npc"),
arrow = arrow(angle = angle, length = length,
ends = "last", type = type),
name = "x_axis_2d",
gp = gpar(...), vp = vp) # x axis
y.grob <- linesGrob(x = unit(c(-eps, -eps), "npc"),
y = unit(c(-eps, 1+eps), "npc"),
arrow = arrow(angle = angle, length = length,
ends = "last", type = type),
name = "y_axis_2d",
gp = gpar(...), vp = vp) # y axis
gTree(children = gList(x.grob, y.grob)) # create a single grob
} else {
args <- c(list(zargs = zargs), group...)
do.call(group_2d_grid, args)
}
if(draw) grid.draw(res)
invisible(res)
}
##' @title Arrow plot in 2d using the grid package
##' @family default 2d plot functions using the grid package
##' @family default 2d plot functions
##' @name arrow_2d_grid
##' @aliases arrow_2d_grid
##' @param zargs argument list as passed from \code{\link{zenplot}()}
##' @param loc (x,y)-location of the center of the arrow
##' @param angle angle from the shaft to the edge of the arrow head
##' @param length length of the arrow in [0,1] from tip to base
##' @param group... list of arguments passed to group_2d_grid (or NULL)
##' @param draw logical indicating whether drawing should take place
##' @param ... additional arguments passed to gpar()
##' @return grob (invisibly)
##' @author Marius Hofert and Wayne Oldford
##' @export
arrow_2d_grid <- function(zargs,
loc = c(0.5, 0.5), angle = 60, length = 0.2,
group... = list(cex = 0.66), draw = FALSE, ...)
{
r <- extract_2d(zargs)
same.group <- r$same.group
check_zargs(zargs, "num", "turns", "ispace")
turn.out <- zargs$turns[zargs$num]
res <- if(same.group) {
vp <- vport(zargs$ispace)
arrow <- zenarrow(turn.out, angle = angle, length = length,
coord.scale = 1)
arr <- loc + arrow
## Plotting
linesGrob(x = arr[1,], y = arr[2,], default.units = "npc",
name = "arrow_2d", gp = gpar(...), vp = vp)
} else {
args <- c(list(zargs = zargs), group...)
do.call(group_2d_grid, args)
}
if(draw) grid.draw(res)
invisible(res)
}
##' @title Rectangle plot in 2d using the grid package
##' @family default 2d plot functions using the grid package
##' @family default 2d plot functions
##' @name rect_2d_grid
##' @aliases rect_2d_grid
##' @param zargs argument list as passed from \code{\link{zenplot}()}
##' @param loc (x,y)-location of the rectangle
##' @param width rectangle width as a fraction of 1
##' @param height rectangle height as a fraction of 1
##' @param group... list of arguments passed to group_2d_grid (or NULL)
##' @param draw logical indicating whether drawing should take place
##' @param ... additional arguments passed to gpar()
##' @return grob (invisibly)
##' @author Marius Hofert and Wayne Oldford
##' @export
rect_2d_grid <- function(zargs,
loc = c(0.5, 0.5), width = 1, height = 1,
group... = list(cex = 0.66), draw = FALSE, ...)
{
r <- extract_2d(zargs)
same.group <- r$same.group
check_zargs(zargs, "ispace")
res <- if(same.group) {
vp <- vport(zargs$ispace)
rectGrob(x = loc[1], y = loc[2], width = width, height = height,
default.units = "npc", name = "rect_2d",
gp = gpar(...), vp = vp)
} else {
args <- c(list(zargs = zargs), group...)
do.call(group_2d_grid, args)
}
if(draw) grid.draw(res)
invisible(res)
}
##' @title Label plot in 2d using the grid package
##' @family default 2d plot functions using the grid package
##' @family default 2d plot functions
##' @name label_2d_grid
##' @aliases label_2d_grid
##' @param zargs argument list as passed from \code{\link{zenplot}()}
##' @param loc (x,y)-location in [0,1]^2; 0 corresponds to left, 1 to right (in
##' the direction of the path)
##' @param label label to be used
##' @param cex character expansion factor
##' @param just (x,y)-justification of the label
##' @param rot rotation of the label
##' @param box logical indicating whether a box should be drawn
##' @param box.width width of the box
##' @param box.height height of the box
##' @param group... list of arguments passed to group_2d_grid (or NULL)
##' @param draw logical indicating whether drawing should take place
##' @param ... additional arguments passed to gpar()
##' @return grob (invisibly)
##' @author Marius Hofert and Wayne Oldford
##' @export
label_2d_grid <- function(zargs,
loc = c(0.98, 0.05), label = NULL, cex = 0.66,
just = c("right", "bottom"), rot = 0,
box = FALSE, box.width = 1, box.height = 1,
group... = list(cex = cex), draw = FALSE, ...)
{
r <- extract_2d(zargs)
same.group <- r$same.group
vlabs <- r$vlabs
check_zargs(zargs, "vars", "num", "ispace")
vars <- zargs$vars
num <- zargs$num
res <- if(same.group) {
xlab <- vlabs[vars[num, 1]]
ylab <- vlabs[vars[num, 2]]
if(is.null(label)) label <- paste0("(",xlab,", ",ylab,")")
vp <- vport(zargs$ispace)
gText <- textGrob(label = label,
x = loc[1], y = loc[2], just = just, rot = rot,
default.units = "npc",
name = "label_2d", gp = gpar(cex = cex, ...), vp = vp)
if(box) {
gBox <- rectGrob(x = 0.5, y = 0.5,
width = box.width, height = box.height, # => plotting outside of viewport (space has been reserved by default ispace)
default.units = "npc",
name = "box_2d", gp = gpar(...), vp = vp)
gTree(children = gList(gBox, gText)) # note: first box
} else {
gTree(children = gList(gText))
}
} else {
args <- c(list(zargs = zargs), group...)
do.call(group_2d_grid, args)
}
if(draw) grid.draw(res)
invisible(res)
}
##' @title Layout plot in 2d using the grid package
##' @param zargs argument list as passed from \code{\link{zenplot}()}
##' @param ... additional arguments passed to label_2d_grid()
##' @return grob (invisibly)
##' @author Marius Hofert and Wayne Oldford
##' @note Here we also pass '...' to group_2d_grid() (to easily adjust
##' font size etc.)
layout_2d_grid <- function(zargs, ...)
label_2d_grid(zargs, loc = c(0.5, 0.5),
just = "centre", box = TRUE, group... = list(...),
...)
Any scripts or data that you put into this service are public.
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.