SCM

SCM Repository

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

Annotation of /pkg/R/dendrogramGrob.R

Parent Directory Parent Directory | Revision Log Revision Log


Revision 194 - (view) (download)

1 : deepayan 2
2 :    
3 :    
4 :     ## FIXME: want a convenience function that behaves like heatmap()
5 :    
6 :    
7 :    
8 :    
9 :    
10 :     ## Goal: create a grob that could usefully represent a dendrogram
11 :    
12 :    
13 :     ## can a dendrogram node have more than 2 children?
14 :     ## long term FIXME: use better graph layout algorithms?
15 :    
16 :    
17 :    
18 :    
19 :     ## returns a modified dendrogram object, with an extra attribute
20 :     ## 'position=c(x, y)' for each node
21 :    
22 :     ## FIXME: should have and honor 'center=FALSE' argument
23 :    
24 :     addPositions <-
25 :     function(x, order)
26 :     {
27 :     if (!is.null(attr(x, "position"))) return(x)
28 :     else if (is.leaf(x))
29 :     {
30 :     attr(x, "position") <-
31 :     list(x = which(x == order)[1],
32 :     y = attr(x, "height"))
33 :     return(x)
34 :     }
35 :     else
36 :     {
37 :     for (i in seq_along(x))
38 :     {
39 :     x[[i]] <- addPositions(x[[i]], order)
40 :     }
41 :     attr(x, "position") <-
42 :     list(x = mean(sapply(x, function(x) attr(x, "position")$x )),
43 :     y = attr(x, "height"))
44 :     return(x)
45 :     }
46 :     }
47 :    
48 :     ## returns a vector data.frame(x0, y0, x1, y1, ...), to be used in a
49 :     ## call to segmentsGrob after being combined. The possibility of
50 :     ## attaching parameters exists, but is not (or barely) tested
51 :    
52 :     edgeLocation <-
53 :     function(pos.node, pos.child, type, ...)
54 :     {
55 :     switch(type,
56 :     rectangle = {
57 :     data.frame(x0 = c(pos.node$x, pos.child$x),
58 :     y0 = c(pos.node$y, pos.node$y),
59 :     x1 = c(pos.child$x, pos.child$x),
60 :     y1 = c(pos.node$y, pos.child$y),
61 :     ..., stringsAsFactors = FALSE) ## 'col' can be strings
62 :     },
63 :     triangle = {
64 :     data.frame(x0 = pos.node$x, y0 = pos.node$y,
65 :     x1 = pos.child$x, y1 = pos.child$y,
66 :     ..., stringsAsFactors = FALSE) ## 'col' can be strings
67 :     })
68 :     }
69 :    
70 :    
71 :     dendrogramGrob <-
72 :     function(x, ord = order.dendrogram(x),
73 :     side = c("right", "top"),
74 :     add = list(),
75 :     size = 5,
76 :     size.add = 1,
77 :     type = c("rectangle", "triangle"),
78 :     ...)
79 :     {
80 : deepayan 180 ## Note: We use dendrapply() a couple of times. The return value
81 :     ## is unused (we are only interested in side-effects), but certain
82 :     ## types of return values of FUN can make dendrapply() go into an
83 :     ## infinite loop. To be safe, we return original node.
84 :    
85 : deepayan 2 if (size <= 0) return(textGrob(label = NULL))
86 :     type <- match.arg(type)
87 :     native.height <- attr(x, "height")
88 :     native.xscale <- c(1, length(ord)) + c(-1, 1) * lattice.getOption("axis.padding")$factor
89 :     xpos <- addPositions(x, ord) ## version of x with positions
90 :    
91 :     ## how many non-leaf nodes are there? For a binary tree, n-1,
92 :     ## where n is the number of leaves (join any 2 ==> nodes++,
93 :     ## leaves--), but we're more tolerant
94 :    
95 :     nnodes <- 0
96 : deepayan 180 dendrapply(xpos,
97 :     function(x) {
98 :     if (!is.leaf(x)) nnodes <<- nnodes + 1
99 :     x
100 :     })
101 : deepayan 2 xseg <- vector(mode = "list", length = nnodes)
102 :    
103 :     ## FIXME: add something similar to have nodes drawn as points
104 :     i <- 0
105 :     getSegments <- function(x, ...)
106 :     {
107 :     if (!is.leaf(x))
108 :     {
109 :     i <<- i + 1
110 :     pos.node <- attr(x, "position")
111 :     xseg[[i]] <<-
112 :     do.call(rbind,
113 :     lapply(x,
114 :     function(child) {
115 :     pos.child <- attr(child, "position")
116 :     edgeLocation(pos.node, pos.child,
117 :     type = type,
118 :     ...)
119 :     }))
120 :     }
121 : deepayan 180 x
122 : deepayan 2 }
123 :     dendrapply(xpos, getSegments)
124 :     all.segs <- do.call(rbind, xseg)
125 :     ## number of additional indicators
126 :     nadd <- length(add)
127 : deepayan 194 ## nleaf <- length(ord)
128 : deepayan 2 native.unit <- 1 / diff(native.xscale) # side of one square
129 :    
130 :     switch(side,
131 :     right = {
132 :     key.layout <-
133 :     grid.layout(nrow = 1, ncol = 1 + nadd,
134 :     heights = unit(1, "null"),
135 :     widths =
136 :     unit(c(rep(size.add, length = nadd), size),
137 :     c(rep("lines", nadd), "lines")),
138 :     respect = FALSE)
139 :     key.gf <- frameGrob(layout = key.layout)
140 :     ## key.gf <- placeGrob(key.gf, rectGrob(gp = gpar(fill = "pink")))
141 :     for (i in seq_len(nadd))
142 :     {
143 :     addi <- add[[i]]
144 :     typei <- names(add)[i]
145 :     switch(typei,
146 :     rect = {
147 :     key.gf <-
148 :     placeGrob(key.gf,
149 :     rectGrob(y = (order(ord) - native.xscale[1]) * native.unit,
150 :     height = native.unit,
151 :     gp = do.call(gpar, addi)),
152 :     row = 1, col = i)
153 :     })
154 :     }
155 :     key.gf <-
156 :     placeGrob(key.gf,
157 :     with(all.segs,
158 :     segmentsGrob((y0 / native.height),
159 :     (x0 - native.xscale[1]) * native.unit,
160 :     (y1 / native.height),
161 :     (x1 - native.xscale[1]) * native.unit)),
162 :     row = 1, col = 1 + nadd)
163 :     key.gf
164 :     },
165 :     top = {
166 :     key.layout <-
167 :     grid.layout(nrow = 1 + nadd, ncol = 1,
168 :     widths = unit(1, "null"),
169 :     heights =
170 :     unit(c(size, rep(size.add, length = nadd)),
171 :     c("lines", rep("lines", nadd))),
172 :     respect = FALSE)
173 :    
174 :     key.gf <- frameGrob(layout = key.layout)
175 :     ## key.gf <- placeGrob(key.gf, rectGrob(gp = gpar(fill = "pink")))
176 :    
177 :     for (i in seq_len(nadd))
178 :     {
179 :     addi <- add[[i]]
180 :     typei <- names(add)[i]
181 :     switch(typei,
182 :     rect = {
183 :     key.gf <-
184 :     placeGrob(key.gf,
185 :     rectGrob(x = (order(ord) - native.xscale[1]) * native.unit,
186 :     width = native.unit,
187 :     gp = do.call(gpar, addi)),
188 :     row = 1 + i, col = 1)
189 :     })
190 :     }
191 :     key.gf <-
192 :     placeGrob(key.gf,
193 :     with(all.segs,
194 :     segmentsGrob((x0 - native.xscale[1]) * native.unit,
195 :     (y0 / native.height),
196 :     (x1 - native.xscale[1]) * native.unit,
197 :     (y1 / native.height))),
198 :     row = 1, col = 1)
199 :     key.gf
200 :     })
201 :     }
202 :    
203 :    
204 :    

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