R/plot2dgrid.R

In zenplots: Zigzag Expanded Navigation Plots

## Default 2d plot functions based on grid
## Idea: Pass through all reasonable (so doomed necessary) arguments of the grid
##       function under consideration as formal arguments. Use `...' to pass
##       through all graphical parameters (via gpar()).


##' @title Point plot in 2d
##' @param x An (n,2)-matrix of points
##' @param type The plot type
##' @param pch The plotting symbol
##' @param size The size of the plotting symbol
##' @param default.units The default units if x or y are given as numeric
##' @param name A character identifier
##' @param draw A logical indicating whether graphics output should be produced
##' @param vp The viewport
##' @param ... Additional parameters passed to gpar()
##' @return A 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
points_2d_grid <- function(x, type=c("p", "l", "o"),
                           pch=NULL, size=NULL, default.units="npc",
                           name=NULL, draw=TRUE, vp=NULL, ...)
{
    type <- match.arg(type)
    switch(type,
           "p" = {
               if(is.null(name)) name <- "points_2d"
               if(is.null(pch)) pch <- 21
               if(is.null(size)) size <- unit(0.02, "npc")
               grid.points(x=x[,1], y=x[,2], pch=pch, size=size,
                           default.units=default.units,
                           name=name, gp=gpar(...), draw=draw, vp=vp)
           },
           "l" = {
               if(is.null(name)) name <- "lines_2d"
               grid.lines(x=x[,1], y=x[,2],
                          default.units=default.units,
                          name=name, gp=gpar(...), draw=draw, vp=vp)
           },
           "o" = {
               if(is.null(pch)) pch <- 20
               if(is.null(size)) size <- unit(0.04, "npc")
               gLines <- linesGrob(x=x[,1], y=x[,2],
                                   default.units=default.units,
                                   name=if(is.null(name)) "lines_2d" else paste0(name, "_lines_2d"),
                                   gp=gpar(...), vp=vp)
               gPoints <- pointsGrob(x=x[,1], y=x[,2], pch=pch, size=size,
                                     default.units=default.units,
                                     name=if(is.null(name)) "points_2d" else paste0(name, "_points_2d"),
                                     gp=gpar(...), vp=vp)
               gt <- gTree(children=gList(gLines, gPoints), vp=vp)
               if (draw) grid.draw(gt)
               gt
           },
           stop("Wrong 'type'"))
}

##' @title Density plot in 2d
##' @param x An (n,2)-matrix of points
##' @param ngrids Number of grid points in each direction. Can be scalar or
##'        a length-2 integer vector.
##' @param ccol A vector (which is then recycled to the appropriate length)
##'        giving the color of the contours
##' @param clwd A vector (which is then recycled to the appropriate length)
##'        giving the line widths of the contours
##' @param clty A vector (which is then recycled to the appropriate length)
##'        giving the line types of the contours
##' @param xlim x limits of the plotting region (to set the scale)
##' @param ylim y limits of the plotting region (to set the scale)
##' @param plotID The plot ID as passed from zenplot()
##' @param turn The turn out of the current plot
##' @param default.units The default units if x, y, width or height are given
##'        as numeric
##' @param name A character identifier
##' @param draw A logical indicating whether graphics output should be produced
##' @param vp The viewport
##' @param ... Additional parameters passed to gpar()
##' @return invisible()
##' @author Marius Hofert and Wayne Oldford
##' @note x, plotID, turn have to be passed here
##'       as they are not valid graphical parameters (when passed on to '...')
density_2d_grid <- function(x, ngrids=25, ccol=NULL, clwd=1, clty=1,
                            xlim=c(0,1), ylim=c(0,1), plotID, turn,
                            default.units="npc", name="density_2d", draw=TRUE, vp=NULL,
                            ...)
{
    dens <- kde2d(x[,1], x[,2], 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]
    }
    ## Define the contour grobs
    contourGrobs <- lapply(1:length(contours), # go over all contours
                           function(i){
                               name <- if(is.null(name)) paste0("contour_",i,) else
                                       paste0("contour",i,"_",name)
                               contour <- contours[[i]]
                               linesGrob(x=contour$x, y=contour$y,
                                         default.units = default.units,
                                         gp=gpar(col=ccol.[i],
                                         lwd=clwd.[i], lty=clty.[i], ...),
                                         name=name, vp=NULL)
                           })
    gt <- gTree(children=do.call(gList, contourGrobs), vp=vp) # create a single grob
    if (draw) grid.draw(gt)
    gt
}

##' @title Axes arrows in 2d
##' @param x An (n,2)-matrix of points
##' @param angle The angle of the arrow head (see ?arrow)
##' @param length The length of the arrow head (see ?arrow)
##' @param type The type of the arrow head (see ?arrow)
##' @param eps The distance by which the axes are moved away from the plot region
##' @param default.units The default units if x or y are given as numeric
##' @param name A character identifier
##' @param draw A logical indicating whether graphics output should be produced
##' @param vp The viewport
##' @param ... Additional parameters passed to gpar()
##' @return A gTree grob containing the axes
##' @author Marius Hofert and Wayne Oldford
##' @note Inspired by https://stat.ethz.ch/pipermail/r-help/2004-October/059525.html
axes_2d_grid <- function(angle=30, length=unit(0.05, "npc"), type="open", eps=0.02,
                         default.units="npc", name=NULL, draw=TRUE, vp=NULL, ...)
{
    x.grob <- linesGrob(x=unit(c(-eps, 1+eps), "npc"),
                        y=unit(c(-eps,  -eps), "npc"),
                        default.units=default.units,
                        arrow=arrow(angle=angle, length=length, ends="last", type=type),
                        name=if(is.null(name)) "x_axis_2d" else paste0(name,"_x_axis"),
                        gp=gpar(...), vp=vp) # x axis
    y.grob <- linesGrob(x=unit(c(-eps,  -eps), "npc"),
                        y=unit(c(-eps, 1+eps), "npc"),
                        default.units=default.units,
                        arrow=arrow(angle=angle, length=length, ends="last", type=type),
                        name=if(is.null(name)) "y_axis_2d" else paste0(name,"_y_axis"),
                        gp=gpar(...), vp=vp) # y axis
    gt <- gTree(children=gList(x.grob, y.grob), vp=vp) # create a single grob
    if(draw) grid.draw(gt)
    gt
}

##' @title Label plot in 2d
##' @param loc.x x-location of the label
##' @param loc.y y-location of the label
##' @param label The label to be used
##' @param x An (n,2)-matrix of points
##' @param plotID The plot ID as passed on from zenplot()
##' @param just (x,y)-justification of the label
##' @param rot The rotation of the label
##' @param cex The font size magnification factor
##' @param check.overlap A logical indicating whether to check for and omit
##'        overlapping text
##' @param default.units The default units if x or y are given as numeric
##' @param name A character identifier
##' @param draw A logical indicating whether graphics output should be produced
##' @param vp The viewport
##' @param ... Additional parameters passed to gpar()
##' @return A grob (invisibly)
##' @author Marius Hofert and Wayne Oldford
##' @note Note that loc.x cannot be named x.loc or x as it would then be over
##'       written by the x passed via layoutpars from zenplot()
label_2d_grid <- function(loc.x=0.96, loc.y=0.04, label=NULL,
                          x, plotID,
                          just=c("right", "bottom"), rot=0, cex=0.5,
                          check.overlap=FALSE, default.units="npc",
                          name="label_2d", draw=TRUE, vp=NULL, ...)
{
    if(is.null(label))
        label <- if(is.null(colnames(x))) {
            paste0("Indices (",plotID$idx[1],", ",plotID$idx[2],")")
        } else {
            paste0("Var (",plotID$name[1],", ",plotID$name[2],")")
        }
    grid.text(label=label, x=loc.x, y=loc.y, just=just, rot=rot,
              check.overlap=check.overlap, default.units=default.units,
              name=name, gp=gpar(cex=cex, ...), draw=draw, vp=vp)
}

##' @title Arrow plot in 2d
##' @param loc The (x,y) location of the center of the arrow
##' @param length The length of the error
##' @param angle The angle from the shaft to the edge of the arrow head
##' @param turn The turn out of the current position
##' @param default.units The default units if x or y are given as numeric
##' @param name A character identifier
##' @param draw A logical indicating whether graphics output should be produced
##' @param vp The viewport
##' @param ... Additional parameters passed to gpar()
##' @return A grob (invisibly)
##' @author Marius Hofert and Wayne Oldford
##' @note Note that loc.x cannot be named x.loc or x as it would then be over
##'       written by the x passed via layoutpars from zenplot()
arrow_2d_grid <- function(loc=c(0.5, 0.5), length=0.2, angle=30, turn,
                          default.units="npc", name="arrow_2d", draw=TRUE, vp=NULL, ...)
{
    arr <- loc + zen_arrow(turn, length=length, angle=angle)
    grid.lines(x=arr[1,], y=arr[2,], default.units=default.units, name=name,
               gp=gpar(...), draw=draw, vp=vp)
}

##' @title Rectangle plot in 2d
##' @param loc.x x-location of the rectangle
##' @param loc.y y-location of the rectangle
##' @param width Rectangle width as a fraction of 1
##' @param height Rectangle height as a fraction of 1
##' @param just (x,y)-justification
##' @param default.units The default units if x, y, width or height are given
##'        as numeric
##' @param name A character identifier
##' @param draw A logical indicating whether graphics output should be produced
##' @param vp The viewport
##' @param ... Additional parameters passed to gpar()
##' @return A grob (invisibly)
##' @author Marius Hofert and Wayne Oldford
##' @note Note that loc.x cannot be named x.loc or x as it would then be over
##'       written by the x passed via layoutpars from zenplot()
rect_2d_grid <- function(loc.x=0.5, loc.y=0.5, width=1, height=1, just="centre",
                         default.units="npc", name="rect_2d", draw=TRUE, vp=NULL, ...)
{
    grid.rect(x=loc.x, y=loc.y, width=width, height=height, just=just,
              default.units=default.units, name=name,
              gp=gpar(...), draw=draw, vp=vp)
}