R help - Jun 2018 - verInd= and HorInd= arguments to pairs() function

>>>>> 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.

Best regards,

Martin Maechler
ETH Zurich and R Core Team
> Am 06.06.2018 um 23:55 schrieb Andrews, Chris:
> > 
> > After making scatterplot matrix, I determined I only needed the first
2 columns of the matrix so I added verInd=1:2 to my pairs() call.  However, it
did not turn out as I expected.
> > 
> > Perhaps the attached pdf of the example code will make it through.  If
not, my description is "the wrong scatterplot pairs are in the wrong
places" for the last two pairs() calls.
> > 
> > Thanks,
> > Chris
> > 
> > ################################################################
> > 
> > # fake data
> > xmat <- matrix(1:28, ncol=4)
> > lim <- range(xmat)
> > 
> > # what I expected
> > pairs(xmat, xlim=lim, ylim=lim) # 4x4 matrix of scatterplots
> > pairs(xmat, xlim=lim, ylim=lim, verInd=1:2, horInd=1:2) # 2x2 matrix
of scatterplots: upper left
> > 
> > # here comes trouble
> > pairs(xmat, xlim=lim, ylim=lim, horInd=1:2) # 2x4 matrix of
scatterplots: but not the top 2 rows (or bottom 2 rows)
> > pairs(xmat, xlim=lim, ylim=lim, verInd=1:2) # 4x2 matrix of
scatterplots: but not the left 2 columns (or right 2 columns)
> > 
> > 
> > ###############################################################
> > 
> >> sessionInfo()
> > R version 3.5.0 (2018-04-23)
> > Platform: x86_64-w64-mingw32/x64 (64-bit)
> > Running under: Windows 7 x64 (build 7601) Service Pack 1
> > 
> > Matrix products: default
> > 
> > locale:
> > [1] LC_COLLATE=English_United States.1252  LC_CTYPE=English_United
States.1252    LC_MONETARY=English_United States.1252
> > [4] LC_NUMERIC=C                           LC_TIME=English_United
States.1252
> > 
> > attached base packages:
> > [1] stats     graphics  grDevices utils     datasets  methods   base
> > 
> > loaded via a namespace (and not attached):
> > [1] compiler_3.5.0 tools_3.5.0
> > **********************************************************

>>>>> 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

>>>>> Martin Maechler 
>>>>>     on Fri, 8 Jun 2018 11:13:24 +0200 writes:
[..........]

    >> 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.

Well, as I find, there are more bugs there, if you are using
'horInd' and 'verInd' creatively:

In a nice pairs(), the axis ticks (and their labels (numbers))
are always "on the outside" of the scatterplot matrix, and
nicely alternating.  This is not the case unfortunately, when using
 horInd or verInd which are *not* of the form p1:p2 (p1 <= p2)

==> even more changes are needed to make these cases "nice",
or  should we *require* horInd and verInd to be of that form??

This would not be back-compatible, but than such cases have been
"wrong" really in all versions of R anyway, *and*  at least be
reordering the matrix/data.frame columns, the restriction of

    (hor|ver)Ind =  p1:p2 (p1 <= p2)

would seem acceptable, would it ?