| # File src/library/graphics/R/pairs.R |
| # Part of the R package, https://www.R-project.org |
| # |
| # Copyright (C) 1995-2018 The R Core Team |
| # Some parts Copyright (C) 1999 Dr. Jens Oehlschlaegel-Akiyoshi |
| # |
| # This program is free software; you can redistribute it and/or modify |
| # it under the terms of the GNU General Public License as published by |
| # the Free Software Foundation; either version 2 of the License, or |
| # (at your option) any later version. |
| # |
| # This program is distributed in the hope that it will be useful, |
| # but WITHOUT ANY WARRANTY; without even the implied warranty of |
| # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the |
| # GNU General Public License for more details. |
| # |
| # A copy of the GNU General Public License is available at |
| # https://www.R-project.org/Licenses/ |
| |
| pairs <- function(x, ...) UseMethod("pairs") |
| |
| pairs.formula <- |
| function(formula, data = NULL, ..., subset, na.action = stats::na.pass) |
| { |
| m <- match.call(expand.dots = FALSE) |
| if(is.matrix(eval(m$data, parent.frame()))) |
| m$data <- as.data.frame(data) |
| m$... <- NULL |
| m$na.action <- na.action # force in even if default |
| m[[1L]] <- quote(stats::model.frame) |
| mf <- eval(m, parent.frame()) |
| pairs(mf, ...) |
| } |
| |
| ################################################# |
| ## some of the changes are from code |
| ## Copyright (C) 1999 Dr. Jens Oehlschlaegel-Akiyoshi |
| ## Others are by BDR and MM |
| ## This version distributed under GPL (version 2 or later) |
| ################################################# |
| |
| pairs.default <- |
| 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 = "", |
| horOdd = !row1attop, verOdd = !row1attop) |
| { |
| 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, ...) { |
| ## Explicitly ignore any color argument passed in as |
| ## it was most likely meant for the data points and |
| ## not for the axis. |
| 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(1L <= horInd & horInd <= nc)) |
| stop("invalid argument 'horInd'") |
| if(!all(1L <= verInd & 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)), |
| 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)} |
| ni <- length(iSet <- if(row1attop) horInd else rev(horInd)) |
| nj <- length(jSet <- verInd) |
| for(j in jSet) |
| for(i in iSet) { |
| l <- paste0(if(xl[j]) "x" else "", |
| if(yl[i]) "y" else "") |
| 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() |
| j.odd <- (match(j, jSet) + horOdd) %% 2L |
| i.odd <- (match(i, iSet) + verOdd) %% 2L |
| if(i == iSet[1L] && (!j.odd || !has.upper || !has.lower)) |
| localAxis(3L, x[, j], x[, i], ...) |
| if(i == iSet[ni] && ( j.odd || !has.upper || !has.lower)) |
| localAxis(1L, x[, j], x[, i], ...) |
| if(j == jSet[1L] && (!i.odd || !has.upper || !has.lower)) |
| localAxis(2L, x[, j], x[, i], ...) |
| if(j == jSet[nj] && ( i.odd || !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, .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) |
| } |
