R/plot1dgrid.R

In zenplots: Zigzag Expanded Navigation Plots

## Default 1d 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 Rug plot in 1d
##' @param x n-vector of data
##' @param width The width of the rugs as a fraction of 1
##' @param height The height of the rugs as a fraction of 1
##' @param just (x,y)-justification of the rectangles/rugs
##' @param horizontal A logical indicating whether the 1d plot is horizontal or
##'        vertical
##' @param col The default color of the rectangles/rugs
##' @param default.units 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 The choice of width and height is to leave the rugs enough space to not
##'       touch points (so to avoid points and rugs overplotting). This could also
##'       be achieved by using vp1d=viewport(width=0.96, height=0.96) in zenplot()
##'       but every time you adjust only one of plot1d() or plot2d(), you have to
##'       adjust the viewport as well as the two plots would not match anymore at
##'       the joint edges otherwise.
rug_1d_grid <- function(x, width=if(horizontal) 0.001 else 0.3,
                        height=if(horizontal) 0.3 else 0.001, just="centre",
                        col=par("fg"), horizontal=TRUE,
                        default.units="npc", name="rug_1d", draw=TRUE, vp=NULL, ...)
{
    grid.rect(x=if(horizontal) x else 0.5, y=if(horizontal) 0.5 else x,
              width=width, height=height, just=just, default.units=default.units,
              name=name, gp=gpar(fill=col, col=col, ...), draw=draw, vp=vp)
}

##' @title Dot plot in 1d
##' @param x n-vector of data
##' @param horizontal A logical indicating whether the 1d plot is horizontal or
##'        vertical
##' @param cex Character extension factor
##' @param plotAsp The fraction (in [0,1]) of the shorter side divided by the
##'        longer side of the plot region
##' @param plotID The plot ID as passed from zenpl
##' @param turn A turn ("l", "r", "d", "u")
##' @param pch The plotting symbol
##' @param size The size of the plotting symbol
##' @param default.units 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 invisible()
##' @author Marius Hofert and Wayne Oldford
##' @note x, horizontal, plotAsp, plotID, turn have to be passed here
##'       as they are not valid graphical parameters (when passed on to '...')
points_1d_grid <- function(x, horizontal=TRUE, plotAsp=0.1,
                           plotID, turn, pch=21,
                           size=unit(0.2 * if(horizontal) plotAsp else 1, "npc"),
                           default.units="npc", name="points_1d", draw=TRUE, vp=NULL, ...)
{
    if(horizontal) {
        grid.points(x=x, y=rep(0.5, length(x)),
                    pch=pch, size=size, default.units=default.units,
                    name=name, gp=gpar(...), draw=draw, vp=vp)
    } else {
        grid.points(x=rep(0.5, length(x)), y=x,
                    pch=pch, size=size, default.units=default.units,
                    name=name, gp=gpar(...), draw=draw, vp=vp)
    }
}

##' @title Jittered dot plot in 1d
##' @param x n-vector of data
##' @param cex Character extension factor
##' @param offset A number in [0,0.5] determining the distance between the
##'        1d and 2d plots (for creating space between the two)
##' @param horizontal A logical indicating whether the 1d plot is horizontal or
##'        vertical
##' @param plotAsp The fraction (in [0,1]) of the shorter side divided by the
##'        longer side of the plot region
##' @param plotID The plot ID as passed from zenpl
##' @param turn A turn ("l", "r", "d", "u")
##' @param pch The plotting symbol
##' @param size The size of the plotting symbol
##' @param default.units 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 invisible()
##' @author Marius Hofert and Wayne Oldford
##' @note x, horizontal, plotAsp, plotID, turn have to be passed here
##'       as they are not valid graphical parameters (when passed on to '...')
jitter_1d_grid <- function(x, cex=0.4, offset=0.25, horizontal=TRUE, plotAsp=0.1, plotID, turn,
                           pch=21, size=unit(0.2 * if(horizontal) plotAsp else 1, "npc"),
                           default.units="npc", name="jitter_1d", draw=TRUE, vp=NULL, ... )
{
    stopifnot(0 <= offset, offset <= 0.5)
    if(horizontal)
        grid.points(x=x, y=offset+(1-2*offset)*runif(length(x)),
                    pch=pch, size=size, default.units=default.units,
                    name=name, gp=gpar(cex=cex, ...), draw=draw, vp=vp)
    else
        grid.points(x=offset+(1-2*offset)*runif(length(x)), y=x,
                    pch=pch, size=size, default.units=default.units,
                    name=name, gp=gpar(cex=cex, ...), draw=draw, vp=vp)
}

##' @title Density plot in 1d
##' @param x n-vector of data
##' @param density.args A list of arguments for density()
##' @param offset A number in [0,0.5] determining the distance between the
##'        1d and 2d plots (for creating space between the two)
##' @param method A character specifying the type of density used
##' @param horizontal A logical indicating whether the 1d plot is horizontal or
##'        vertical
##' @param default.units 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
density_1d_grid <- function(x, density.args=list(), offset=0.25,
                            method=c("single", "double"), horizontal=TRUE,
                            default.units="npc", name="density_1d",
                            draw=TRUE, vp=NULL, ...)
{
    stopifnot(0 <= offset, offset <= 0.5)
    dens <- do.call(density, args=c(list(x), density.args))
    xvals <- dens$x
    keepers <- xvals >= min(x) & xvals <= max(x)
    xvals <- xvals[keepers]
    xrange <- range(xvals)
    xvals <- (xvals - min(xrange))/diff(xrange)
    yvals <- dens$y[keepers]
    method <- match.arg(method)
    switch(method,
           "single" = {
               yvals <- yvals/max(yvals)
               if(horizontal) {
                   x <- c(min(xvals), xvals, max(xvals))
                   y <- c(0, yvals, 0)
               } else {
                   x <- c(0, yvals,0)
                   y <- c(min(xvals), xvals, max(xvals))
               }
           },
           "double" = {
               xvals <- rep(xvals, 2)
               yvals <- c(-yvals, yvals)
               yrange <- range(yvals)
               yvals <- (yvals - min(yrange))/diff(yrange)
               if(horizontal) {
                   x <- xvals
                   y <- yvals
               } else {
                   x <- yvals
                   y <- xvals
               }
           },
           stop("Wrong 'method'"))
    ## Scaling to avoid overplotting of plot2d()
    if(horizontal) {
        min.y <- min(y)
        max.y <- max(y)
        y <- (1-2*offset) * (y-min.y)/(max.y-min.y) + offset # scale to [offset, 1-offset]
    } else {
        min.x <- min(x)
        max.x <- max(x)
        x <- (1-2*offset) * (x-min.x)/(max.x-min.x) + offset # scale to [offset, 1-offset]
    }
    grid.polygon(x=x, y=y, default.units=default.units, name=name,
                 gp=gpar(...), draw=draw, vp=vp)
}

##' @title Boxplot in 1d
##' @param x n-vector of data
##' @param horizontal A logical indicating whether the 1d plot is horizontal or
##'        vertical
##' @param cex Character extension factor
##' @param plotAsp The fraction (in [0,1]) of the shorter side divided by the
##'        longer side of the plot region
##' @param plotID The plot ID as passed from zenpl
##' @param turn A turn ("l", "r", "d", "u")
##' @param pch The plotting symbol
##' @param size The size of the plotting symbol
##' @param default.units Default units if x or y are given as numeric
##' @param col colour for boxplot
##' @param lwd The graphical parameter line width for whiskers and median
##' @param bpwidth The width of boxplot on scale of default.units
##' @param range numerical value used to determine how far the plot whiskers extend. If
##'        NULL, the whiskers (range) grows with sample size.
##' @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 gTree grob containing the boxplot components as grobs
##' @author Marius Hofert and Wayne Oldford
##' @note x, horizontal, plotAsp, plotID, turn have to be passed here
##'       as they are not valid graphical parameters (when passed on to '...')
boxplot_1d_grid <- function (x, horizontal=TRUE, plotAsp=0.1,
                             plotID, turn, pch=21,
                             size=unit(0.2 * if(horizontal) plotAsp else 1, "npc"),
                             default.units="npc",
                             col=NULL, lwd=2, bpwidth=0.5, range=NULL,
                             name="boxplot_1d", draw=TRUE, vp=NULL, ...)
{
  if(is.null(range)) { # choose 'range' depending on sample size
      n <- length(x)
      q25 <- qnorm(0.25)
      iqr <- qnorm(0.75) - q25
      range <- (q25 - qnorm(0.35/(2*n)))/iqr
  }

  if(is.null(col)) col <- "grey" # hcl(h=210, alpha=0.5)
  medianCol <- if(col=="black") "white" else "black"

  ## Summary statistics
  median <- median(x, na.rm=TRUE)
  Q1 <- quantile(x, 0.25, na.rm=TRUE)
  Q3 <- quantile(x, 0.75, na.rm=TRUE)
  IQR <- Q3 - Q1
  upper.fence <- Q3 + (range * IQR)
  lower.fence <- Q1 - (range * IQR)
  upper.adjacent.value <- max(x[x <= upper.fence])
  lower.adjacent.value <- min(x[x >= lower.fence])
  ## upper.outliers <- x[x>upper.adjacent.value]
  ## lower.outliers <- x[x <lower.adjacent.value]
  outliers <- x[(x < lower.adjacent.value) | (x > upper.adjacent.value)]
  existOutliers <- length(outliers) !=0

  ## Draw the boxplot
  if(horizontal) {

      ## Build the box
      highbox <-  grid.rect(x=median, width=Q3-median, height=bpwidth,
                            default.units=default.units,
                            draw= FALSE, just=c("left", "center"),
                            gp=gpar(fill=col, col=col, ...), vp=NULL)
      medianLine <- linesGrob(x=c(median, median), y=c(0.5-bpwidth/2, 0.5+bpwidth/2),
                              default.units=default.units, gp=gpar(fill=medianCol,
                                                                   col=medianCol, lwd=lwd, ...))
      lowbox <-  grid.rect(x=median, width=median-Q1, height=bpwidth,
                           default.units=default.units, draw=FALSE, just=c("right", "center"),
                           gp=gpar(fill=col, col=col, ...), vp=NULL)

      ## Build the whiskers
      highadjacent <- linesGrob(x=c(upper.adjacent.value,upper.adjacent.value),
                                y=c(0.5 - bpwidth/5, 0.5 + bpwidth/5),
                                default.units = default.units,
                                gp=gpar(fill=col, col=col, lwd=lwd, ...))
      highwhisker <- linesGrob(x=c(Q3,upper.adjacent.value),
                               y=c(0.5, 0.5),
                               default.units = default.units,
                               gp=gpar(fill=col, col=col, lwd=lwd, ...))
      lowadjacent <- linesGrob(x=c(lower.adjacent.value,lower.adjacent.value),
                               y=c(0.5 - bpwidth/5, 0.5 + bpwidth/5),
                               default.units = default.units,
                               gp=gpar(fill=col, col=col,lwd=lwd, ...))
      lowwhisker <- linesGrob(x=c(Q1,lower.adjacent.value),
                              y=c(0.5, 0.5),
                              default.units = default.units,
                              gp=gpar(fill=col, col=col, lwd=lwd, ...))

      ## Gather the outliers (if any)
      if (existOutliers)
          outlierpoints <- grid.points(x=outliers, y=rep(0.5, length(outliers)),
                                       pch=pch, size=size, default.units=default.units,
                                       gp=gpar(fill=col, col=col, ...),
                                       draw=FALSE, vp=NULL)

  } else { # !horizontal

      ## Build the box
      highbox <-  grid.rect(y=median, height=Q3-median, width=bpwidth,
                            default.units=default.units, just=c("center", "bottom"),
                            gp=gpar(fill=col, col=col, ...), draw= FALSE, vp=NULL)
      medianLine <- linesGrob(x=c(0.5-bpwidth/2, 0.5+bpwidth/2),
                              y=c(median, median), default.units=default.units,
                              gp=gpar(fill=medianCol, col=medianCol, lwd=lwd, ...))
      lowbox <-  grid.rect(y=median, height=median-Q1, width=bpwidth,
                           default.units=default.units, draw= FALSE,
                           just=c("center", "top"), gp=gpar(fill=col, col=col, ...),
                           vp=NULL)

      ## Build the whiskers
      highadjacent <- linesGrob(x=c(0.5 - bpwidth/5, 0.5 + bpwidth/5),
                                y=c(upper.adjacent.value,upper.adjacent.value),
                                default.units = default.units,
                                gp=gpar(fill=col, col=col,lwd=lwd, ...))
      highwhisker <- linesGrob(x=c(0.5, 0.5),
                               y=c(Q3,upper.adjacent.value),
                               default.units = default.units,
                               gp=gpar(fill=col, col=col,lwd=lwd, ...))
      lowadjacent <- linesGrob(x=c(0.5 - bpwidth/5, 0.5 + bpwidth/5),
                               y=c(lower.adjacent.value,lower.adjacent.value),
                               default.units = default.units,
                               gp=gpar(fill=col, col=col,lwd=lwd, ...))
      lowwhisker <- linesGrob(x=c(0.5, 0.5),
                              y=c(Q1,lower.adjacent.value),
                              default.units = default.units,
                              gp=gpar(fill=col, col=col,lwd=lwd, ...))

      ## Gather the outliers (if any)
      if(existOutliers)
          outlierpoints <- grid.points(x=rep(0.5, length(outliers)), y=outliers,
                                       pch=pch, size=size, default.units=default.units,
                                       gp=gpar(fill=col, col=col, ...),
                                       draw=FALSE, vp=NULL)
  }

  ## Put it all together
  boxplotGrobs <- if(existOutliers)
                      list(lowadjacent, lowwhisker, lowbox, highbox,
                           ## medianPoint, # median must come after the boxes
                           medianLine, highwhisker, highadjacent, outlierpoints)
                  else
                      list(lowadjacent, lowwhisker, lowbox, highbox,
                           ## medianPoint, # median must come after the boxes
                           medianLine, highwhisker, highadjacent)
  gt <- gTree(children=do.call(gList, boxplotGrobs), name=name, vp=vp)
  if (draw) grid.draw(gt)
  gt
}

##' @title Histogram in 1d
##' @param x n-vector of data
##' @param offset A number in [0,0.5] determining the distance between the
##'        1d and 2d plots (for creating space between the two)
##' @param method A character specifying the type of density used
##' @param breaks Argument passed to hist() to get information on bins. Default
##'        is 20 equi-width bins covering the range of x
##' @param col colour of the histogram bar interiors, unless fill is specified, then
##'        this is the colour of the border
##' @param fill colour of the histogram bar interior if given
##' @param horizontal A logical indicating whether the 1d plot is horizontal or
##'        vertical
##' @param default.units 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
hist_1d_grid <- function(x, offset=0.25, method=c("single", "double"),
                         breaks=NULL, col=NULL, fill=NULL, horizontal=TRUE,
                         default.units="npc", name="hist_1d",
                         draw=TRUE, vp=NULL, ...)
{
    stopifnot(0 <= offset, offset <= 0.5)
    if(is.null(fill)) {
        fill <- if(is.null(col)) "grey" else "black"
        if(is.null(col)) col <- "black"
    } else if(is.null(col)) { col <- "black"}

    xRange <- range(x)
    if(is.null(breaks))
        breaks <- seq(from=xRange[1], to=xRange[2], length.out=21)
    binInfo <- hist(x, breaks=breaks, plot=FALSE)
    binBoundaries <- (binInfo$breaks - min(xRange))/(diff(xRange))
    heights <- binInfo$counts
    heights <- (1-2*offset) * heights/max(heights)

    ## Set values for single or double methods
    method <- match.arg(method)
    switch(method,
           "single" = {
               binLoc <- offset
               just <- c("left", "bottom")
           },
           "double" = {
               binLoc <- 0.5
               just <- if(horizontal) c("left", "centre") else c("centre", "bottom")
           },
           stop("Wrong 'method'"))

    ## Build the bins
    binGrobs <- lapply(1:length(heights), # bins,
                       function(i){
                           left <- binBoundaries[i]
                           right <- binBoundaries[i+1]
                           height <- heights[i]
                           rectGrob(x=if(horizontal) left else binLoc,
                                    y=if(horizontal) binLoc else left,
                                    width=if(horizontal) (right-left) else height,
                                    height=if(horizontal) height else (right-left),
                                    just=just, default.units=default.units,
                                    name=paste(name, "bin",i, sep="_"),
                                    gp=gpar(fill=fill, col=col, ...))})
    gt <- gTree(children=do.call(gList, binGrobs), vp=vp)
    if(draw) grid.draw(gt)
    gt
}

##' @title Label plot in 1d
##' @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 n-vector of data
##' @param horizontal A logical indicating whether the 1d plot is horizontal or
##'        vertical
##' @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 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
label_1d_grid <- function(loc.x=0.5, loc.y=0.5, label=NULL,
                          x, horizontal=TRUE, plotID,
                          just=c("centre", "centre"), rot=if(horizontal) 0 else 90, cex=0.4,
                          check.overlap=FALSE, default.units="npc", name="label_1d",
                          draw=TRUE, vp=NULL, ...)
{
    if(is.null(label))
        label <- if(is.null(colnames(x))) { # also applies to a vector (colnames == NULL)
            paste0("Index ",plotID$idx)
        } else {
            paste0("Var ",plotID$name)
        }
    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 1d
##' @param loc The (x,y) location of the center of the arrow
##' @param length The length of the arrow
##' @param angle The angle from the shaft to the edge of the arrow head
##' @param plotAsp The fraction (in [0,1]) of the shorter side divided by the
##'        longer side of the plot region
##' @param turn A turn ("l", "r", "d", "u")
##' @param default.units 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
arrow_1d_grid <- function(loc=c(0.5, 0.5), length=0.5, angle=plotAsp*30,
                          plotAsp=0.1, turn, default.units="npc", name="arrow_1d",
                          draw=TRUE, vp=NULL, ...)
{
    arrow_2d_grid(loc=loc, length=length, angle=angle,
                  turn=turn, default.units=default.units, name=name,
                  vp=vp, draw=draw, ...)
}

##' @title Rectangle plot in 1d
##' @param loc.x x-location of rectangle
##' @param loc.y y-location of rectangle
##' @param horizontal A logical indicating whether the 1d plot is horizontal or
##'        vertical
##' @param width The width of the rugs as a fraction of 1
##' @param height The height of the rugs as a fraction of 1
##' @param just (x,y)-justification of the rectangles/rugs
##' @param default.units 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
rect_1d_grid <- function(loc.x=0.5, loc.y=0.5, horizontal=TRUE,
                         width=if(horizontal) 1 else 0.4,
                         height=if(horizontal) 0.4 else 1,
                         just="centre", default.units="npc",
                         name="rect_1d", 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)
}

##' @title Lines plot in 1d
##' @param loc.x x-coordinates of the points combined by lines
##' @param loc.y y-coordinates of the points combined by lines
##' @param horizontal A logical indicating whether the 1d plot is horizontal or
##'        vertical
##' @param default.units Default units if x or y are given as numeric
##' @param arrow A list describing the arrow head
##' @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()
lines_1d_grid <- function(loc.x=NULL, loc.y=NULL, horizontal=TRUE,
                          default.units="npc", arrow=NULL,
                          name="lines_1d", draw=TRUE, vp=NULL, ...)
{
    if(is.null(loc.x)) loc.x <- if(horizontal) c(0, 1) else c(0.5, 0.5)
    if(is.null(loc.y)) loc.y <- if(horizontal) c(0.5, 0.5) else c(0, 1)
    grid.lines(x=loc.x, y=loc.y, default.units=default.units, arrow=arrow, name=name,
               gp=gpar(...), draw=draw, vp=vp)
}