[Rd] Patch to coplot.R
Dr. Thomas Baumann
thomas.baumann@ch.tum.de
Tue, 27 Feb 2001 09:35:57 +0100 (CET)
---1149173172-1804289383-983267779=:26068
Content-Type: TEXT/plain; charset=us-ascii
Hello,
and a big thank you for providing R!
Please find attached a diff for coplot which you may want to consider
for the next release. The diff is against R 1.2.2. The reasons for this
patch are:
1. The boxes of coplot did not align very well with the panel graphs if
applied to a factor
2. Putting the levels as axis labels instead of just numbers makes the
plot more readable
I also include a sample dataset (test.asc) and a sample program to show
the differences.
Thanks for looking at the code.
Thomas
---1149173172-1804289383-983267779=:26068
Content-Type: TEXT/plain; NAME="coplot.diff"
*** /tmp/mycoplot.R Tue Feb 27 09:08:13 2001
--- /tmp/coplot.R.orig Tue Feb 27 09:08:13 2001
***************
*** 201,227 ****
...)
}
if ((i == total.rows) && (j%%2 == 0))
! if (nlevels(x) > 0)
! axis(1, labels = levels(x), xpd = NA)
! else
! axis(1, xpd = NA)
else if ((i == istart || index + columns > nplots) &&
(j%%2 == 1))
! if (nlevels(x) > 0)
! axis(3, labels = levels(x), xpd = NA)
! else
! axis(3, xpd = NA)
! if ((j == 1) && ((total.rows - i)%%2 == 0))
! if (nlevels(y) > 0)
! axis(2, labels = levels(y), xpd = NA)
! else
! axis(2, xpd = NA)
else if ((j == columns || index == nplots) && ((total.rows -
! i)%%2 == 1))
! if (nlevels(y) > 0)
! axis(4, labels = levels(y), xpd = NA)
! else
! axis(4, xpd = NA)
box()
}
if (have.b) {
--- 201,215 ----
...)
}
if ((i == total.rows) && (j%%2 == 0))
! axis(1, xpd = NA)
else if ((i == istart || index + columns > nplots) &&
(j%%2 == 1))
! axis(3, xpd = NA)
! if ((j == 1) && ((total.rows - i)%%2 == 0))
! axis(2, xpd = NA)
else if ((j == columns || index == nplots) && ((total.rows -
! i)%%2 == 1))
! axis(4, xpd = NA)
box()
}
if (have.b) {
***************
*** 255,274 ****
par(fig = c(0, f.col, f.row, 1), mar = nmar, new = TRUE)
plot.new()
nint <- nrow(a.intervals)
! pwoffs <- nint / 32
! plot.window(c(min(a.intervals[is.finite(a.intervals)] + pwoffs),
! max(a.intervals[is.finite(a.intervals)]) - pwoffs),
! 0.5 + c(0, nint), log = "")
! rect(a.intervals[, 1], 1:nint - 0.5, a.intervals[, 2],
! 1:nint + 0.5, col = gray(0.95))
! if (!is.null(a.levels)) {
mid <- apply(a.intervals, 1, mean)
text(mid, 1:nint, a.levels)
NULL
}
! axis(3, labels = FALSE, tick = FALSE, xpd = NA)
! axis(1, labels = FALSE, tick = FALSE)
! box(col = "grey")
mtext(xlab[2], side = 3, at = mean(par("usr")[1:2]),
line = 3, xpd = NA)
}
--- 243,262 ----
par(fig = c(0, f.col, f.row, 1), mar = nmar, new = TRUE)
plot.new()
nint <- nrow(a.intervals)
! plot.window(range(a.intervals[is.finite(a.intervals)]),
! 0.5 + c(0, nint), log = "")
! bg <- if (is.null(a.levels))
! gray(0.9)
! else {
mid <- apply(a.intervals, 1, mean)
text(mid, 1:nint, a.levels)
NULL
}
! rect(a.intervals[, 1], 1:nint - 0.3, a.intervals[, 2],
! 1:nint + 0.3, col = bg)
! axis(3, xpd = NA)
! axis(1, labels = FALSE)
! box()
mtext(xlab[2], side = 3, at = mean(par("usr")[1:2]),
line = 3, xpd = NA)
}
***************
*** 284,304 ****
par(fig = c(f.col, 1, 0, f.row), mar = nmar, new = TRUE)
plot.new()
nint <- nrow(b.intervals)
! pwoffs <- nint / 32
! plot.window(0.5 + c(0, nint),
! c(min(b.intervals[is.finite(b.intervals)] + pwoffs),
! max(b.intervals[is.finite(b.intervals)]) - pwoffs),
! log = "")
! rect(1:nint - 0.5, b.intervals[, 1], 1:nint + 0.5,
! b.intervals[, 2], col = gray(0.95))
! if (!is.null(b.levels)) {
mid <- apply(b.intervals, 1, mean)
text(1:nint, mid, b.levels, srt = 90)
NULL
}
! axis(4, labels = FALSE, tick = FALSE, xpd = NA)
! axis(2, labels = FALSE, tick = FALSE)
! box(col = "grey")
mtext(ylab[2], side = 4, at = mean(par("usr")[3:4]),
line = 3, xpd = NA)
}
--- 272,291 ----
par(fig = c(f.col, 1, 0, f.row), mar = nmar, new = TRUE)
plot.new()
nint <- nrow(b.intervals)
! plot.window(0.5 + c(0, nint), range(b.intervals,
! finite = TRUE), log = "")
! bg <- if (is.null(b.levels))
! gray(0.9)
! else {
mid <- apply(b.intervals, 1, mean)
text(1:nint, mid, b.levels, srt = 90)
NULL
}
! rect(1:nint - 0.3, b.intervals[, 1], 1:nint + 0.3,
! b.intervals[, 2], col = bg)
! axis(4, xpd = NA)
! axis(2, labels = FALSE)
! box()
mtext(ylab[2], side = 4, at = mean(par("usr")[3:4]),
line = 3, xpd = NA)
}
---1149173172-1804289383-983267779=:26068
Content-Type: TEXT/plain; NAME="mycoplot.R"
function (formula, data, given.values, panel = points, rows,
columns, show.given = TRUE, col = par("fg"), pch = par("pch"),
xlab = c(x.name, paste("Given :", a.name)), ylab = c(y.name,
paste("Given :", b.name)), subscripts = FALSE, number = 6,
overlap = 0.5, xlim, ylim, ...)
{
deparen <- function(expr) {
while (is.language(expr) && !is.name(expr) && deparse(expr[[1]]) ==
"(") expr <- expr[[2]]
expr
}
bad.formula <- function() stop("invalid conditioning formula")
bad.lengths <- function() stop("incompatible variable lengths")
formula <- deparen(formula)
if (!inherits(formula, "formula"))
bad.formula()
y <- deparen(formula[[2]])
rhs <- deparen(formula[[3]])
if (deparse(rhs[[1]]) != "|")
bad.formula()
x <- deparen(rhs[[2]])
rhs <- deparen(rhs[[3]])
if (is.language(rhs) && !is.name(rhs) && (deparse(rhs[[1]]) ==
"*" || deparse(rhs[[1]]) == "+")) {
have.b <- TRUE
a <- deparen(rhs[[2]])
b <- deparen(rhs[[3]])
}
else {
have.b <- FALSE
a <- rhs
}
if (missing(data))
data <- parent.frame()
x.name <- deparse(x)
x <- eval(x, data, parent.frame())
nobs <- length(x)
y.name <- deparse(y)
y <- eval(y, data, parent.frame())
if (length(y) != nobs)
bad.lengths()
a.name <- deparse(a)
a <- eval(a, data, parent.frame())
if (length(a) != nobs)
bad.lengths()
if (is.character(a))
a <- as.factor(a)
a.levels <- NULL
if (have.b) {
b.levels <- NULL
b.name <- deparse(b)
b <- eval(b, data, parent.frame())
if (length(b) != nobs)
bad.lengths()
if (is.character(b))
b <- as.factor(b)
missingrows <- which(is.na(x) | is.na(y) | is.na(a) |
is.na(b))
}
else {
missingrows <- which(is.na(x) | is.na(y) | is.na(a))
b <- NULL
b.name <- ""
}
number <- as.integer(number)
if (length(number) == 0 || any(number < 1))
stop("number must be integer >= 1")
if (any(overlap >= 1))
stop("overlap must be < 1 (and typically >= 0).")
bad.givens <- function() stop("invalid given.values")
if (missing(given.values)) {
a.intervals <- if (is.factor(a)) {
i <- 1:nlevels(a)
a.levels <- levels(a)
a <- as.numeric(a)
cbind(i - 0.5, i + 0.5)
}
else co.intervals(a, number = number[1], overlap = overlap[1])
b.intervals <- if (have.b) {
if (is.factor(b)) {
i <- 1:nlevels(b)
b.levels <- levels(b)
b <- as.numeric(b)
cbind(i - 0.5, i + 0.5)
}
else {
if (length(number) == 1)
number <- rep(number, 2)
if (length(overlap) == 1)
overlap <- rep(overlap, 2)
co.intervals(b, number = number[2], overlap = overlap[2])
}
}
}
else {
if (!is.list(given.values))
given.values <- list(given.values)
if (length(given.values) != (if (have.b)
2
else 1))
bad.givens()
a.intervals <- given.values[[1]]
if (is.factor(a)) {
if (is.character(a.intervals))
a.intervals <- match(a.intervals, levels(a))
a.intervals <- cbind(a.intervals - 0.5, a.intervals +
0.5)
a.levels <- levels(a)
a <- as.numeric(a)
}
else if (is.numeric(a)) {
if (!is.numeric(a.intervals))
bad.givens()
if (!is.matrix(a.intervals) || ncol(a.intervals) !=
2)
a.intervals <- cbind(a.intervals - 0.5, a.intervals +
0.5)
}
if (have.b) {
b.intervals <- given.values[[2]]
if (is.factor(b)) {
if (is.character(b.intervals))
b.intervals <- match(b.intervals, levels(b))
b.intervals <- cbind(b.intervals - 0.5, b.intervals +
0.5)
b.levels <- levels(b)
b <- as.numeric(b)
}
else if (is.numeric(b)) {
if (!is.numeric(b.intervals))
bad.givens()
if (!is.matrix(b.intervals) || ncol(b.intervals) !=
2)
b.intervals <- cbind(b.intervals - 0.5, b.intervals +
0.5)
}
}
}
if (any(is.na(a.intervals)) || (have.b && any(is.na(b.intervals))))
bad.givens()
if (have.b) {
rows <- nrow(b.intervals)
columns <- nrow(a.intervals)
nplots <- rows * columns
if (length(show.given) < 2)
show.given <- rep(show.given, 2)
}
else {
nplots <- nrow(a.intervals)
if (missing(rows)) {
if (missing(columns)) {
rows <- ceiling(round(sqrt(nplots)))
columns <- ceiling(nplots/rows)
}
else rows <- ceiling(nplots/columns)
}
else if (missing(columns))
columns <- ceiling(nplots/rows)
if (rows * columns < nplots)
stop("rows * columns too small")
}
total.columns <- columns
total.rows <- rows
f.col <- f.row <- 1
if (show.given[1]) {
total.rows <- rows + 1
f.row <- rows/total.rows
}
if (have.b && show.given[2]) {
total.columns <- columns + 1
f.col <- columns/total.columns
}
opar <- par(mfrow = c(total.rows, total.columns), oma = if (have.b)
rep(5, 4)
else c(5, 6, 5, 4), mar = if (have.b)
rep(0, 4)
else c(0.5, 0, 0.5, 0), new = FALSE)
on.exit(par(opar))
plot.new()
if (missing(xlim))
xlim <- range(x[is.finite(x)])
if (missing(ylim))
ylim <- range(y[is.finite(y)])
pch <- rep(pch, length = nobs)
col <- rep(col, length = nobs)
do.panel <- function(index, subscripts = FALSE) {
istart <- (total.rows - rows) + 1
i <- total.rows - ((index - 1)%/%columns)
j <- (index - 1)%%columns + 1
par(mfg = c(i, j, total.rows, total.columns))
plot.new()
plot.window(xlim, ylim, log = "")
if (any(is.na(id)))
id[is.na(id)] <- FALSE
if (any(id)) {
grid(lty = "solid")
if (subscripts)
panel(x[id], y[id], subscripts = id, col = col[id],
pch = pch[id], ...)
else panel(x[id], y[id], col = col[id], pch = pch[id],
...)
}
if ((i == total.rows) && (j%%2 == 0))
if (nlevels(x) > 0)
axis(1, labels = levels(x), xpd = NA)
else
axis(1, xpd = NA)
else if ((i == istart || index + columns > nplots) &&
(j%%2 == 1))
if (nlevels(x) > 0)
axis(3, labels = levels(x), xpd = NA)
else
axis(3, xpd = NA)
if ((j == 1) && ((total.rows - i)%%2 == 0))
if (nlevels(y) > 0)
axis(2, labels = levels(y), xpd = NA)
else
axis(2, xpd = NA)
else if ((j == columns || index == nplots) && ((total.rows -
i)%%2 == 1))
if (nlevels(y) > 0)
axis(4, labels = levels(y), xpd = NA)
else
axis(4, xpd = NA)
box()
}
if (have.b) {
count <- 1
for (i in 1:rows) {
for (j in 1:columns) {
id <- ((a.intervals[j, 1] <= a) & (a <= a.intervals[j,
2]) & (b.intervals[i, 1] <= b) & (b <= b.intervals[i,
2]))
do.panel(count, subscripts)
count <- count + 1
}
}
}
else {
for (i in 1:nplots) {
id <- ((a.intervals[i, 1] <= a) & (a <= a.intervals[i,
2]))
do.panel(i, subscripts)
}
}
mtext(xlab[1], side = 1, at = 0.5 * f.col, outer = TRUE,
line = 3.5, xpd = NA)
mtext(ylab[1], side = 2, at = 0.5 * f.row, outer = TRUE,
line = 3.5, xpd = NA)
if (length(xlab) == 1)
xlab <- c(xlab, paste("Given :", a.name))
if (show.given[1]) {
mar <- par("mar")
nmar <- mar + c(4, 0, 0, 0)
par(fig = c(0, f.col, f.row, 1), mar = nmar, new = TRUE)
plot.new()
nint <- nrow(a.intervals)
pwoffs <- nint / 32
plot.window(c(min(a.intervals[is.finite(a.intervals)] + pwoffs),
max(a.intervals[is.finite(a.intervals)]) - pwoffs),
0.5 + c(0, nint), log = "")
rect(a.intervals[, 1], 1:nint - 0.5, a.intervals[, 2],
1:nint + 0.5, col = gray(0.95))
if (!is.null(a.levels)) {
mid <- apply(a.intervals, 1, mean)
text(mid, 1:nint, a.levels)
NULL
}
axis(3, labels = FALSE, tick = FALSE, xpd = NA)
axis(1, labels = FALSE, tick = FALSE)
box(col = "grey")
mtext(xlab[2], side = 3, at = mean(par("usr")[1:2]),
line = 3, xpd = NA)
}
else {
mtext(xlab[2], side = 3, at = 0.5 * f.col, line = 3.25,
outer = TRUE, xpd = NA)
}
if (have.b) {
if (length(ylab) == 1)
ylab <- c(ylab, paste("Given :", b.name))
if (show.given[2]) {
nmar <- mar + c(0, 4, 0, 0)
par(fig = c(f.col, 1, 0, f.row), mar = nmar, new = TRUE)
plot.new()
nint <- nrow(b.intervals)
pwoffs <- nint / 32
plot.window(0.5 + c(0, nint),
c(min(b.intervals[is.finite(b.intervals)] + pwoffs),
max(b.intervals[is.finite(b.intervals)]) - pwoffs),
log = "")
rect(1:nint - 0.5, b.intervals[, 1], 1:nint + 0.5,
b.intervals[, 2], col = gray(0.95))
if (!is.null(b.levels)) {
mid <- apply(b.intervals, 1, mean)
text(1:nint, mid, b.levels, srt = 90)
NULL
}
axis(4, labels = FALSE, tick = FALSE, xpd = NA)
axis(2, labels = FALSE, tick = FALSE)
box(col = "grey")
mtext(ylab[2], side = 4, at = mean(par("usr")[3:4]),
line = 3, xpd = NA)
}
else {
mtext(ylab[2], side = 4, at = 0.5 * f.row, line = 3.25,
outer = TRUE, xpd = NA)
}
}
if (length(missingrows) > 0) {
cat("\nMissing rows:", missingrows, "\n")
invisible(missingrows)
}
}
---1149173172-1804289383-983267779=:26068
Content-Type: TEXT/plain; NAME="test.asc"
RDA1
5 0
9 row.names
5 names
5 class
6 levels
3 cxt
2 0 0
1 0 0
5
-1
19 0 1
4
13 0 1
90
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
2
2
2
2
2
2
2
2
2
2
2
2
2
2
2
2
2
2
2
2
2
2
3
3
3
3
3
3
3
3
3
3
3
3
3
3
3
3
3
3
3
4
4
4
4
4
4
4
4
4
4
4
4
4
4
4
4
5
5
5
5
5
5
5
5
5
5
5
5
5
5
5
2 0 0
1 0 0
4
-1
16 0 0
5
3 WSA
3 WSB
3 WSC
3 WSD
3 WSE
-1
2 0 0
1 0 0
3
-1
16 0 0
1
6 factor
-1
-1
-1
-1
13 0 1
90
2
2
2
2
3
4
4
4
4
5
5
5
6
6
6
6
6
6
1
2
2
2
2
2
2
4
4
4
4
5
5
5
5
5
6
6
6
6
6
6
1
2
2
2
2
2
2
4
4
4
4
5
5
6
6
6
6
6
6
1
2
2
2
4
4
4
4
5
5
6
6
6
6
6
6
1
2
2
2
3
4
4
4
5
5
6
6
6
6
6
2 0 0
1 0 0
4
-1
16 0 0
6
2 Br
2 Cr
2 Ni
3 PCP
3 SRB
3 URA
-1
2 0 0
1 0 0
3
-1
16 0 0
1
6 factor
-1
-1
-1
-1
13 0 1
90
1
2
4
4
4
1
2
3
4
1
3
4
1
1
1
1
1
1
1
1
1
2
2
4
4
1
2
3
4
1
3
3
4
4
1
1
1
1
1
1
1
1
1
2
2
4
4
1
2
3
4
3
4
1
1
1
1
1
1
1
1
2
4
1
2
3
4
3
4
1
1
1
1
1
1
1
1
2
4
4
1
3
4
3
4
1
1
1
1
1
2 0 0
1 0 0
4
-1
16 0 0
4
1 1
2 20
2 21
2 22
-1
2 0 0
1 0 0
3
-1
16 0 0
1
6 factor
-1
-1
-1
-1
14 0 0
90
0.88690446
0.88690513
-0.008582909999999999
0.84140389
0.01547746
0.82645292
0.82645427
0.76571345
0.8263521
0.37570381
0.40361484
0.40384806
0.74884711
0.94859763
0.96677452
0.97557102
0.9832513000000001
0.98572282
0.99349502
0.11416688
0.8122289
0.11418351
0.88183559
0.09723225000000001
0.88183561
0.83853386
0.83863709
0.74681656
0.83251071
0.8454432
0.75563716
0.92634558
0.84537136
0.97884589
0.73673004
0.96747265
0.97369701
0.98715169
0.9914865
0.99328531
0.99652316
0.25447211
0.30372693
0.25373806
0.30371362
0.2327828
0.25372631
0.96173564
0.97069235
0.95462282
0.95459587
0.91341539
0.98234451
0.60740805
0.77592908
0.93602096
0.9867878
0.98751514
0.99363163
0.9859177
0.83318812
0.83308551
0.95750996
0.91218418
0.91217945
0.8623662
0.90722619
0.89806433
0.546805
0.9623669500000001
0.97003306
0.97554032
0.98202711
0.98297822
0.98880629
0.99688566
0.80436417
0.88417903
0.80423433
0.45605293
0.95874106
0.56694216
0.95734593
0.87062068
0.96359899
0.9355361
0.9629377
0.96566601
0.9679529100000001
0.9834591
-1
2 0 0
1 0 0
3
-1
16 0 0
1
10 data.frame
-1
2 0 0
1 0 0
2
-1
16 0 0
4
6 loc.id
7 chem.id
4 mode
6 fitpar
-1
2 0 0
1 0 0
1
-1
16 0 0
90
1 1
1 2
1 3
1 4
1 5
1 6
1 7
1 8
1 9
2 10
2 11
2 12
2 13
2 14
2 15
2 16
2 17
2 18
2 19
2 20
2 21
2 22
2 23
2 24
2 25
2 26
2 27
2 28
2 29
2 30
2 31
2 32
2 33
2 34
2 35
2 36
2 37
2 38
2 39
2 40
2 41
2 42
2 43
2 44
2 45
2 46
2 47
2 48
2 49
2 50
2 51
2 52
2 53
2 54
2 55
2 56
2 57
2 58
2 59
2 60
2 61
2 62
2 63
2 64
2 65
2 66
2 67
2 68
2 69
2 70
2 71
2 72
2 73
2 74
2 75
2 76
2 77
2 78
2 79
2 80
2 81
2 82
2 83
2 84
2 85
2 86
2 87
2 88
2 89
2 90
-1
-1
-1
-1
-1
-1
-1
---1149173172-1804289383-983267779=:26068
Content-Type: TEXT/plain; NAME="coplot_sample.R"
load("test.asc")
mycoplot(cxt$fitpar ~ unclass(cxt$loc.id)|
cxt$chem.id * cxt$mode,
panel = points,
bg = "blue",
col = "blue",
pch = 21,
xlab = c("Location", "Contaminant"),
ylab = c(label, "CXTFit-Mode"),
ylim = c(0.6,1)
)
coplot(cxt$fitpar ~ unclass(cxt$loc.id)|
cxt$chem.id * cxt$mode,
panel = points,
bg = "blue",
col = "blue",
pch = 21,
xlab = c("Location", "Contaminant"),
ylab = c(label, "CXTFit-Mode"),
ylim = c(0.6,1)
)
---1149173172-1804289383-983267779=:26068--
-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-
r-devel mailing list -- Read http://www.ci.tuwien.ac.at/~hornik/R/R-FAQ.html
Send "info", "help", or "[un]subscribe"
(in the "body", not the subject !) To: r-devel-request@stat.math.ethz.ch
_._._._._._._._._._._._._._._._._._._._._._._._._._._._._._._._._._._._._._._._