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)
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
**********************************************************
Electronic Mail is not secure, may not be read every day, and should not be
used for urgent or sensitive issues
______________________________________________
R-help@r-project.org mailing list -- To UNSUBSCRIBE and more, see
https://stat.ethz.ch/mailman/listinfo/r-help
PLEASE do read the posting guide http://www.R-project.org/posting-guide.html
and provide commented, minimal, self-contained, reproducible code.
______________________________________________
R-help@r-project.org mailing list -- To UNSUBSCRIBE and more, see
https://stat.ethz.ch/mailman/listinfo/r-help
PLEASE do read the posting guide http://www.R-project.org/posting-guide.html
and provide commented, minimal, self-contained, reproducible code.
