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

Parent Directory | 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 :

---

root@r-forge.r-project.org	ViewVC Help
Powered by ViewVC 1.0.0