SCM

SCM Repository

[latticeextra] Annotation of /pkg/R/panel.3dmisc.R
ViewVC logotype

Annotation of /pkg/R/panel.3dmisc.R

Parent Directory Parent Directory | Revision Log Revision Log


Revision 170 - (view) (download)

1 : deepayan 2
2 :    
3 :     ## a panel function for cloud that draws "3d bar charts" which
4 :     ## shouldn't be used except in unusual circumstances
5 :    
6 :    
7 :     panel.3dbars <-
8 :     function(x, y, z,
9 :     rot.mat = diag(4), distance,
10 :     xbase = 1, ybase = 1,
11 :     xlim, xlim.scaled,
12 :     ylim, ylim.scaled,
13 :     zlim, zlim.scaled,
14 :     zero.scaled,
15 :     col = "black",
16 :     lty = 1, lwd = 1,
17 : deepayan 170 alpha = 1,
18 : deepayan 2 ...,
19 :     col.facet = "white",
20 :     alpha.facet = 1)
21 :     {
22 : deepayan 170 n <- length(z)
23 :     col <- rep(col, length = n)
24 :     col.facet <- rep(col.facet, length = n)
25 :     alpha <- rep(alpha, length = n)
26 :     alpha.facet <- rep(alpha.facet, length = n)
27 :     lty <- rep(lty, length = n)
28 :     lwd <- rep(lwd, length = n)
29 : deepayan 2 id <-
30 :     ((x >= xlim.scaled[1]) & (x <= xlim.scaled[2]) &
31 :     (y >= ylim.scaled[1]) & (y <= ylim.scaled[2]) &
32 :     !is.na(x) & !is.na(y) & !is.na(z))
33 :     m <- ltransform3dto3d(rbind(x, y, 0), rot.mat, distance)
34 :     ord <- sort.list(m[3,])
35 :     ord <- ord[id[ord]]
36 :     zero.scaled <-
37 :     if (zero.scaled < zlim.scaled[1]) zlim.scaled[1]
38 :     else if (zero.scaled > zlim.scaled[2]) zlim.scaled[2]
39 :     else zero.scaled
40 :     inRange <- function(x, lim)
41 :     {
42 :     rng <- range(x, finite = TRUE)
43 :     rng[1] >= min(lim) && rng[2] <= max(lim)
44 :     }
45 :     ## draw bars one by one
46 :     for (i in ord)
47 :     {
48 :     ## print(i)
49 :     xbase.scaled <- diff(xlim.scaled) * xbase / diff(xlim)
50 :     ybase.scaled <- diff(ylim.scaled) * ybase / diff(ylim)
51 :     zz.sides <- matrix(c(zero.scaled, z[i]), 2, 1)[, rep(1, 5)]
52 :     xx.sides <-
53 :     c(x[i], x[i]) + xbase.scaled * 0.5 *
54 :     rbind(c(-1, 1, 1, -1, -1), c(-1, 1, 1, -1, -1))
55 :     yy.sides <-
56 :     c(y[i], y[i]) + ybase.scaled * 0.5 *
57 :     rbind(c(-1, -1, 1, 1, -1), c(-1, -1, 1, 1, -1))
58 :     zz.top <- matrix(z[i], 2, 2)
59 :     xx.top <-
60 :     c(x[i], x[i]) + xbase.scaled * 0.5 *
61 :     rbind(c(-1, 1), c(-1, 1))
62 :     yy.top <-
63 :     c(y[i], y[i]) + ybase.scaled * 0.5 *
64 :     rbind(c(-1, -1), c(1, 1))
65 :    
66 :     zz <- cbind(zz.sides, c(NA, NA), zz.top)
67 :     xx <- cbind(xx.sides, c(NA, NA), xx.top)
68 :     yy <- cbind(yy.sides, c(NA, NA), yy.top)
69 :     ## str(list(xx, yy, zz))
70 :     if (inRange(xx, xlim.scaled) &&
71 :     inRange(yy, ylim.scaled) &&
72 :     inRange(zz, zlim.scaled))
73 :     {
74 :     panel.3dwire(xx, yy, zz,
75 :     rot.mat = rot.mat, distance = distance,
76 :     xlim = xlim, xlim.scaled = xlim.scaled,
77 :     ylim = ylim, ylim.scaled = ylim.scaled,
78 :     zlim = zlim, zlim.scaled = zlim.scaled,
79 : deepayan 170 col = col[i], lty = lty[i], lwd = lwd[i],
80 :     alpha = alpha[i],
81 : deepayan 2 ...,
82 :     at = c(0, 1), # dummy
83 : deepayan 170 col.regions = col.facet[i],
84 :     alpha.regions = alpha.facet[i])
85 : deepayan 2 }
86 :     }
87 :     }
88 :    
89 :    
90 :    
91 :    
92 :     ## panel.3dpolygon <-
93 :     ## function(x, y, z, rot.mat = diag(4), distance,
94 :     ## type = 'p',
95 :     ## xlim.scaled,
96 :     ## ylim.scaled,
97 :     ## zlim.scaled,
98 :     ## zero.scaled,
99 :     ## col = "white",
100 :     ## border = "black",
101 :     ## lty = 1, lwd = 1,
102 :     ## min.sides = 3,
103 :     ## ...,
104 :     ## subscripts = TRUE)
105 :     ## {
106 :     ## m <- ltransform3dto3d(rbind(x, y, z), rot.mat, distance)
107 :     ## ## ord <- sort.list(m[3,])
108 :     ## n <- ncol(m)
109 :     ## w <- which(is.na(x) | is.na(y))
110 :     ## id.lengths <- diff(c(0, w, n))
111 :     ## cum.lengths <- c(0, cumsum(id.lengths))
112 :    
113 :     ## idlist <-
114 :     ## lapply(seq_along(id.lengths),
115 :     ## function(i) {
116 :     ## ind <- seq_len(id.lengths[i]) + cum.lengths[i]
117 :     ## ind[-id.lengths[i]]
118 :     ## })
119 :    
120 :     ## ord <-
121 :     ## order(sapply(idlist,
122 :     ## function(ind) {
123 :     ## min(m[3, ind])
124 :     ## }))
125 :    
126 :     ## for (ind in idlist[ord])
127 :     ## {
128 :     ## if (length(ind) >= min.sides)
129 :     ## panel.polygon(x = m[1, ind], y = m[2, ind],
130 :     ## col = col, border = border)
131 :     ## }
132 :    
133 :     ## }
134 :    
135 :    
136 :    
137 :    
138 :     panel.3dpolygon <-
139 :     function(x, y, z, rot.mat = diag(4), distance,
140 :     xlim.scaled,
141 :     ylim.scaled,
142 :     zlim.scaled,
143 :     zero.scaled,
144 :     col = "white",
145 :     border = "black",
146 :     ## min.sides = 3,
147 :     font, fontface, ## gpar() doesn't like these
148 :     ...)
149 :     {
150 :     if (all(is.na(x) | is.na(y) | is.na(z))) return()
151 :     border <-
152 :     if (all(is.na(border)))
153 :     "transparent"
154 :     else if (is.logical(border))
155 :     {
156 :     if (border) "black"
157 :     else "transparent"
158 :     }
159 :     else border
160 :     m <- ltransform3dto3d(rbind(x, y, z), rot.mat, distance)
161 :     ## ord <- sort.list(m[3,])
162 :     n <- ncol(m)
163 :     w <- which(is.na(x) | is.na(y))
164 :     id.lengths <- diff(c(0, w, n))
165 :    
166 :     ## need to reorder multiple polygons by some measure of "average" depth
167 :    
168 :     id.long <- rep(seq_along(id.lengths), id.lengths)
169 :     ord.depth <- order(tapply(m[3,], id.long, min, na.rm = TRUE))
170 :     id.ordered <- ord.depth[id.long]
171 :    
172 :     ord.long <- order(id.ordered)
173 :    
174 :     grid.polygon(x = m[1, ord.long], y = m[2, ord.long],
175 :     id = id.ordered[ord.long],
176 :     default.units = "native",
177 :     gp =
178 :     gpar(fill = col,
179 :     col = border,
180 :     ...))
181 :    
182 :     ## print(data.frame(x = m[1, ord.long],
183 :     ## y = m[2, ord.long],
184 :     ## id = id.ordered[ord.long]))
185 :    
186 :     return()
187 :     }
188 :    
189 :    
190 :    
191 :    
192 :     panel.3dtext <-
193 :     function(x, y, z, labels = seq_along(x),
194 :     rot.mat = diag(4), distance, ...)
195 :     {
196 :     if (all(is.na(x) | is.na(y) | is.na(z))) return()
197 :     m <- ltransform3dto3d(rbind(x, y, z), rot.mat, distance)
198 :     ord <- sort.list(m[3,])
199 : deepayan 31 panel.text(x = m[1, ord], y = m[2, ord], labels = labels, ...)
200 : deepayan 2 }
201 :    
202 :    
203 :    
204 :     ## d <- data.frame(x = rnorm(10),
205 :     ## y = rnorm(10),
206 :     ## z = rnorm(10))
207 :     ## rownames(d) <- letters[1:10]
208 :    
209 :     ## cloud(z ~ x * y, d, panel.3d.cloud = panel.3dtext)
210 :     ## cloud(z ~ x * y, d, panel.3d.cloud = panel.3dtext,
211 :     ## labels = rownames(d), col = "red")
212 :    
213 :     ## ## for multipanel plots
214 :    
215 :     ## cloud(z ~ x * y, d,
216 :     ## panel.3d.cloud = function(..., subscripts) {
217 :     ## panel.3dtext(..., labels = rownames(d)[subscripts])
218 :     ## })
219 :    

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