[R] verInd= and HorInd= arguments to pairs() function
Gerrit Eichner
gerr|t@e|chner @end|ng |rom m@th@un|-g|e@@en@de
Thu Jun 7 09:03:46 CEST 2018
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 using 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.
>
More information about the R-help
mailing list