[R] verInd= and HorInd= arguments to pairs() function

[Martin Maechler]

>>>>> Martin Maechler 
>>>>>     on Thu, 7 Jun 2018 18:35:48 +0200 writes:

>>>>> Gerrit Eichner 
>>>>>     on Thu, 7 Jun 2018 09:03:46 +0200 writes:

    >> Hi, Chris, had the same problem (and first thought it was
    >> my fault), but there seems to be a typo in the code of
    >> pairs.default. Below is a workaround.  Look for two
    >> comments (starting with #####) in the code to see what I
    >> have changed to make it work at least the way I'd expect
    >> it in one of your examples.

    >> Hth -- Gerrit


> > mypairs <- function (x, labels, panel = points, ...,
> >      horInd = 1:nc, verInd = 1:nc,
> >      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 = "") {
> >      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 < 2L)
> >          stop("only one column in the argument to 'pairs'")
> >      if (!all(horInd >= 1L && horInd <= nc))
> >          stop("invalid argument 'horInd'")
> >      if (!all(verInd >= 1L && verInd <= nc))
> >          stop("invalid argument 'verInd'")
> >      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(mfcol = c(length(horInd), length(verInd)),
> > ##### Changed from mfrow to mfcol
> >                  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 (j in if (row1attop) verInd else rev(verInd))
> >       for (i in horInd) {
> > ##### Exchanged i and j. (i used to be in
> > ##### the outer and j in the inner loop!)
> >          l <- paste0(ifelse(xl[j], "x", ""), ifelse(yl[i], "y", ""))
> >          localPlot(x[, j], x[, i], xlab = "", ylab = "", axes = FALSE,
> >              type = "n", ..., log = l)
> >          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)
> > }
> > 
> > 
> > 
> > ## Example:
> > 
> > mypairs(xmat, xlim=lim, ylim=lim, verInd=1:2, horInd=1:4)
> 
> Thank you, Chris, for the report and
> Gerrit for your proposed fix !!
> 
> It looks good to me,  but I will test some more (also with
> 'row1attop=FALSE')  before committing the bug fix.

and there, another change was needed:  Instead of your

    for (j in if (row1attop) verInd else rev(verInd))
        for (i in horInd) {

we do now need

    for(j in verInd)
        for(i in if(row1attop) horInd else rev(horInd)) {

and the difference is of course only relevant for the
non-default  'row1attop = FALSE'

  (which some graphic experts argue to be clearly *better* than the default,
   as only in that case,  the upper and lower triangles of the
   matrix are nicely "mirrors of each other", and that is also
   the reason why  lattice::splom()  uses the equivalent of
   'row1attop=FALSE')

I will commit the change to R-devel today - and intend to port
to R-patched in time to make it into the upcoming R 3.5.1.

Thank you once more !
Martin