pairs(): Specifying axes limits of the subpanels

Question

Consider the following example:

data(iris)
pairs(iris[1:4],xlim=c(0,8), ylim = c(0,8)) 

As you can see, the axes limits for all subpanels have been altered.

However, the alteration required is the specification of xlim and ylim for each subpanel row/column individually.

I perused SO and could not find a suitable answer.

Answer 1

You cannot do this directly. But if you are willing to go to the source code of pairs, it can easily be done. Below you will find my version. Note that this is mostly just the original with a few lines of code changed.

my.pairs <- function (x, labels, panel = points, ..., lower.panel = panel, 
          upper.panel = panel, diag.panel = NULL, text.panel = textPanel, 
          label.pos = 0.5 + has.diag/3, line.main = 3, cex.labels = NULL, 
          font.labels = 1, row1attop = TRUE, gap = 1, log = "", xlim=NULL, ylim=NULL) 
{
  if (doText <- missing(text.panel) || is.function(text.panel)) 
    textPanel <- function(x = 0.5, y = 0.5, txt, cex, font) text(x, 
                                                                 y, txt, cex = cex, font = font)
  localAxis <- function(side, x, y, xpd, bg, col = NULL, main, 
                        oma, ...) {
    xpd <- NA
    if (side%%2L == 1L && xl[j]) 
      xpd <- FALSE
    if (side%%2L == 0L && yl[i]) 
      xpd <- FALSE
    if (side%%2L == 1L) 
      Axis(x, side = side, xpd = xpd, ...)
    else Axis(y, side = side, xpd = xpd, ...)
  }
  localPlot <- function(..., main, oma, font.main, cex.main) plot(...)
  localLowerPanel <- function(..., main, oma, font.main, cex.main) lower.panel(...)
  localUpperPanel <- function(..., main, oma, font.main, cex.main) upper.panel(...)
  localDiagPanel <- function(..., main, oma, font.main, cex.main) diag.panel(...)
  dots <- list(...)
  nmdots <- names(dots)
  if (!is.matrix(x)) {
    x <- as.data.frame(x)
    for (i in seq_along(names(x))) {
      if (is.factor(x[[i]]) || is.logical(x[[i]])) 
        x[[i]] <- as.numeric(x[[i]])
      if (!is.numeric(unclass(x[[i]]))) 
        stop("non-numeric argument to 'pairs'")
    }
  }
  else if (!is.numeric(x)) 
    stop("non-numeric argument to 'pairs'")
  panel <- match.fun(panel)
  if ((has.lower <- !is.null(lower.panel)) && !missing(lower.panel)) 
    lower.panel <- match.fun(lower.panel)
  if ((has.upper <- !is.null(upper.panel)) && !missing(upper.panel)) 
    upper.panel <- match.fun(upper.panel)
  if ((has.diag <- !is.null(diag.panel)) && !missing(diag.panel)) 
    diag.panel <- match.fun(diag.panel)
  if (row1attop) {
    tmp <- lower.panel
    lower.panel <- upper.panel
    upper.panel <- tmp
    tmp <- has.lower
    has.lower <- has.upper
    has.upper <- tmp
  }
  nc <- ncol(x)
  if (nc < 2) 
    stop("only one column in the argument to 'pairs'")
  if (doText) {
    if (missing(labels)) {
      labels <- colnames(x)
      if (is.null(labels)) 
        labels <- paste("var", 1L:nc)
    }
    else if (is.null(labels)) 
      doText <- FALSE
  }
  oma <- if ("oma" %in% nmdots) 
    dots$oma
  main <- if ("main" %in% nmdots) 
    dots$main
  if (is.null(oma)) 
    oma <- c(4, 4, if (!is.null(main)) 6 else 4, 4)
  opar <- par(mfrow = c(nc, nc), mar = rep.int(gap/2, 4), oma = oma)
  on.exit(par(opar))
  dev.hold()
  on.exit(dev.flush(), add = TRUE)
  xl <- yl <- logical(nc)
  if (is.numeric(log)) 
    xl[log] <- yl[log] <- TRUE
  else {
    xl[] <- grepl("x", log)
    yl[] <- grepl("y", log)
  }
  for (i in if (row1attop) 
    1L:nc
       else nc:1L) for (j in 1L:nc) {
         l <- paste0(ifelse(xl[j], "x", ""), ifelse(yl[i], "y", 
                                                   ""))
         if (is.null(xlim) & is.null(ylim))
         localPlot(x[, j], x[, i], xlab = "", ylab = "", axes = FALSE, 
                   type = "n", ..., log = l)
         if (is.null(xlim) & !is.null(ylim))
         localPlot(x[, j], x[, i], xlab = "", ylab = "", axes = FALSE, 
                   type = "n", ..., log = l, ylim=ylim[j,i,])
         if (!is.null(xlim) & is.null(ylim))
         localPlot(x[, j], x[, i], xlab = "", ylab = "", axes = FALSE, 
                   type = "n", ..., log = l, xlim = xlim[j,i,])
         if (!is.null(xlim) & !is.null(ylim))
         localPlot(x[, j], x[, i], xlab = "", ylab = "", axes = FALSE, 
                   type = "n", ..., log = l, xlim = xlim[j,i,], ylim=ylim[j,i,])

         if (i == j || (i < j && has.lower) || (i > j && has.upper)) {
           box()
           if (i == 1 && (!(j%%2L) || !has.upper || !has.lower)) 
             localAxis(1L + 2L * row1attop, x[, j], x[, i], 
                       ...)
           if (i == nc && (j%%2L || !has.upper || !has.lower)) 
             localAxis(3L - 2L * row1attop, x[, j], x[, i], 
                       ...)
           if (j == 1 && (!(i%%2L) || !has.upper || !has.lower)) 
             localAxis(2L, x[, j], x[, i], ...)
           if (j == nc && (i%%2L || !has.upper || !has.lower)) 
             localAxis(4L, x[, j], x[, i], ...)
           mfg <- par("mfg")
           if (i == j) {
             if (has.diag) 
               localDiagPanel(as.vector(x[, i]), ...)
             if (doText) {
               par(usr = c(0, 1, 0, 1))
               if (is.null(cex.labels)) {
                 l.wid <- strwidth(labels, "user")
                 cex.labels <- max(0.8, min(2, 0.9/max(l.wid)))
               }
               xlp <- if (xl[i]) 
                 10^0.5
               else 0.5
               ylp <- if (yl[j]) 
                 10^label.pos
               else label.pos
               text.panel(xlp, ylp, labels[i], cex = cex.labels, 
                          font = font.labels)
             }
           }
           else if (i < j) 
             localLowerPanel(as.vector(x[, j]), as.vector(x[, 
                                                            i]), ...)
           else localUpperPanel(as.vector(x[, j]), as.vector(x[, 
                                                               i]), ...)
           if (any(par("mfg") != mfg)) 
             stop("the 'panel' function made a new plot")
         }
         else par(new = FALSE)
       }
  if (!is.null(main)) {
    font.main <- if ("font.main" %in% nmdots) 
      dots$font.main
    else par("font.main")
    cex.main <- if ("cex.main" %in% nmdots) 
      dots$cex.main
    else par("cex.main")
    mtext(main, 3, line.main, outer = TRUE, at = 0.5, cex = cex.main, 
          font = font.main)
  }
  invisible(NULL)
}

With this changed pairsfunction, you can now do the following:

data(iris)
pairs(iris[1:4],xlim=c(0,8), ylim = c(0,8)) 
# xpecifying limits (now as arrays...)
# dims 1-2: panel
# dim 3: lower und upper limit
my.xlim <- array(0, dim=c(4,4,2))
my.xlim[,,2] <- 8
my.ylim <- my.xlim
my.xlim[1,,1] <- 4
my.pairs(iris[1:4], xlim=my.xlim)
# careful: the following would work, but does not adjust the labels!
my.xlim[2,3,2] <- 6 
my.pairs(iris[1:4], xlim=my.xlim)