1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
|
.arrayIndices <- function(d, i)
## Suppose we have an array 'x' with dimension 'd'. We can index
## 'x' in two different ways: x[i] or x[i_1, i_2, ..., i_d].
## Here, we are given 'i', and want to compute i_1, i_2, ..., i_d.
{
## Here's what we are doing:
## For length(d) == 3, note that (for 0-based indexing)
##
## i1 = (i mod d[1])
## i2 = (i mod d[1] * d[2]) div d[1]
## i3 = (i mod d[1] * d[2] * d[3]) div d[1] * d[2]
n <- length(d)
ans <- vector(mode = "list", length = n)
for (k in seq_along(ans))
{
ans[[k]] <- 1L + (((i-1L) %% prod(head(d, k)))
%/%
prod(head(d, k-1L)))
}
ans
}
combineLimits <-
function(x, margin.x = 2L, margin.y = 1L,
extend = TRUE, adjust.labels = TRUE)
{
if (length(dim(x)) == 1L)
warning("Only one conditioning variable; nothing interesting will happen.")
indices <- .arrayIndices(dim(x), seq_len(prod(dim(x))))
modifyLimits <- function(limits, margin)
{
limits <- array(limits, dim = dim(x))
for (i in seq_len(prod(dim(x))))
{
## index.combine <- index.entry <- Rows(indices, i)
index.combine <- Rows(indices, i)
index.combine[margin] <- list(TRUE)
## limits[[i]] <-
## range(do.call("[", c(list(limits), index.combine)), finite = TRUE)
li <- unlist(do.call("[", c(list(limits), index.combine)))
limits[[i]] <- if(all(is.na(li))) li else range(li, finite = TRUE)
}
if (extend) lapply(limits, lattice:::extend.limits)
else limits
}
if (x$x.scales$relation != "free" && x$y.scales$relation != "free")
warning("Function only has effect for scales with 'relation=\"free\"'.")
if (x$x.scales$relation == "free" && length(margin.x))
{
x$x.limits <- modifyLimits(x$x.limits, margin.x)
}
if (x$y.scales$relation == "free" && length(margin.y))
{
x$y.limits <- modifyLimits(x$y.limits, margin.y)
}
if (adjust.labels)
{
## Drop all but left/bottom-most labels, and set space to 0
## for those. Needs to know layout, and will set it unless
## already set.
npackets <- prod(dim(x))
par.settings <- if (is.null(x$par.settings)) list() else x$par.settings
if (is.null(x$layout))
x$layout <-
if (length(dim(x)) == 1L) c(dim(x), 1)
else dim(x)[1:2]
else if (!isTRUE(all.equal(x$layout[1:2], dim(x)[1:2])))
{
warning("'layout' does not match dimensions; displayed scales may be wrong.")
}
if (any(is.na(x$layout) | x$layout == 0))
stop("'layout' must explicitly determine number of rows and columns")
if (x$x.scales$relation == "free" && length(margin.x))
{
## change x-scales
if (is.list(x$x.scales$at))
{
warning("Explicit per-panel tick mark locations ignored")
x$x.scales$at <- FALSE
}
page.at <-
if (x$as.table)
rep(list(NULL, x$x.scales$at),
c(x$layout[1] * (x$layout[2]-1), x$layout[1]))
else
rep(list(x$x.scales$at, NULL),
c(x$layout[1], x$layout[1] * (x$layout[2]-1)))
x$x.scales$at <- rep(page.at, length.out = npackets)
par.settings <-
if (x$as.table)
modifyList(par.settings,
list(layout.heights =
list(axis.panel = rep(c(0, 1), c(x$layout[2]-1, 1)))))
else
modifyList(par.settings,
list(layout.heights =
list(axis.panel = rep(c(1, 0), c(1, x$layout[2]-1)))))
}
if (x$y.scales$relation == "free" && length(margin.y))
{
## change y-scales
if (is.list(x$y.scales$at))
{
warning("Explicit per-panel tick mark locations ignored")
x$y.scales$at <- FALSE
}
page.at <- rep(list(TRUE, NULL), c(1, x$layout[1]-1))
x$y.scales$at <- rep(page.at, length.out = npackets)
par.settings <-
modifyList(par.settings,
list(layout.widths =
list(axis.panel = rep(c(1, 0), c(1, x$layout[1]-1)))))
}
x$par.settings <- par.settings
}
x
}
|