SCM

SCM Repository

[latticeextra] Annotation of /pkg/R/combineLimits.R
ViewVC logotype

Annotation of /pkg/R/combineLimits.R

Parent Directory Parent Directory | Revision Log Revision Log


Revision 182 - (view) (download)

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

R-Forge@R-project.org
ViewVC Help
Powered by ViewVC 1.0.0  
Thanks to:
Vienna University of Economics and Business University of Wisconsin - Madison Powered By FusionForge