1
2## Functions to calculate a set of points around the perimeter
3## (or along the length) of a grob
4
5grobCoords <- function(x, closed, ...) {
6    UseMethod("grobCoords")
7}
8
9emptyCoords <- list(x = 0, y = 0)
10
11isEmptyCoords <- function(coords) {
12    identical(coords, emptyCoords)
13}
14
15grobCoords.grob <- function(x, closed, ...) {
16    vp <- x$vp
17    trans <- current.transform()
18    # Same set up as drawGrob()
19    dlon <- grid.Call(C_setDLon, FALSE)
20    on.exit(grid.Call(C_setDLon, dlon))
21    tempgpar <- grid.Call(C_getGPar)
22    on.exit(grid.Call(C_setGPar, tempgpar), add=TRUE)
23    # Same drawing context set up as drawGrob()
24    # including enforcing the drawing context
25    x <- preDraw(x)
26    # Same drawing content set up as drawGrob() ...
27    x <- makeContent(x)
28    ## Does this grob change the viewport ?
29    ## (including has preDraw() changed the viewport)
30    vpgrob <- !is.null(x$vp) || !identical(vp, x$vp)
31    # BUT NO DRAWING
32    ## Polygon outline in inches
33    pts <- grobPoints(x, closed, ...)
34    if (vpgrob && !isEmptyCoords(pts)) {
35        ## Calc locations on device
36        pts <- lapply(pts,
37                      function(p) {
38                          deviceLoc(unit(p$x, "in"), unit(p$y, "in"),
39                                    valueOnly=TRUE)
40                      })
41    }
42    # Same context clean up as drawGrob()
43    postDraw(x)
44    if (vpgrob && !isEmptyCoords(pts)) {
45        ## Transform back to locations
46        pts <- lapply(pts,
47                      function(p) {
48                          ptsMatrix <- cbind(p$x, p$y, 1) %*% solve(trans)
49                          list(x=ptsMatrix[,1], y=ptsMatrix[,2])
50                      })
51    }
52    pts
53}
54
55## "gList"s
56grobCoords.gList <- function(x, closed, ...) {
57    ## Some children may produce list of lists
58    coords <- lapply(x, grobCoords, closed, ...)
59    coordLists <- lapply(coords,
60                        function(p) {
61                            if ("x" %in% names(p)) {
62                                list(p)
63                            } else {
64                                p
65                            }
66                        })
67    do.call("c", coordLists)
68}
69
70## "gTree"s
71grobCoords.gTree <- function(x, closed, ...) {
72    vp <- x$vp
73    trans <- current.transform()
74    # Same set up as drawGTree()
75    dlon <- grid.Call(C_setDLon, FALSE)
76    on.exit(grid.Call(C_setDLon, dlon))
77    tempgrob <- grid.Call(C_getCurrentGrob)
78    tempgpar <- grid.Call(C_getGPar)
79    on.exit({ grid.Call(C_setGPar, tempgpar)
80              grid.Call(C_setCurrentGrob, tempgrob)
81            }, add=TRUE)
82    # Same drawing context set up as drawGTree(),
83    # including enforcing the drawing context
84    x <- preDraw(x)
85    # Same drawing content set up as drawGTree() ...
86    x <- makeContent(x)
87    ## Does this grob change the viewport ?
88    ## (including has preDraw() changed the viewport)
89    vpgrob <- !is.null(x$vp) || !identical(vp, x$vp)
90    ## Polygon outline in inches
91    pts <- grobCoords(x$children[x$childrenOrder], closed, ...)
92    if (vpgrob && !isEmptyCoords(pts)) {
93        ## Calc locations on device
94        pts <- lapply(pts,
95                      function(p) {
96                          deviceLoc(unit(p$x, "in"), unit(p$y, "in"),
97                                    valueOnly=TRUE)
98                      })
99    }
100    # Same context clean up as drawGTree()
101    postDraw(x)
102    if (vpgrob && !isEmptyCoords(pts)) {
103        ## Transform back to locations
104        pts <- lapply(pts,
105                      function(p) {
106                          ptsMatrix <- cbind(p$x, p$y, 1) %*% solve(trans)
107                          list(x=ptsMatrix[,1], y=ptsMatrix[,2])
108                      })
109    }
110    pts
111}
112
113grobPoints <- function(x, closed, ...) {
114    UseMethod("grobPoints")
115}
116
117grobPoints.move.to <- function(x, closed, ...) {
118    emptyCoords
119}
120
121grobPoints.line.to <- function(x, closed, ...) {
122    emptyCoords
123}
124
125grobPoints.circle <- function(x, closed, ..., n=100) {
126    if (closed) {
127        cx <- convertX(x$x, "in", valueOnly=TRUE)
128        cy <- convertY(x$y, "in", valueOnly=TRUE)
129        r <- min(convertWidth(x$r, "in", valueOnly=TRUE),
130                 convertHeight(x$r, "in", valueOnly=TRUE))
131        t <- seq(0, 2*pi, length.out=n+1)[-(n+1)]
132        ## Recycle via cbind()
133        circs <- cbind(cx, cy, r)
134        n <- nrow(circs)
135        lapply(1:n,
136               function(i) {
137                   list(x=circs[i, 1] + circs[i, 3]*cos(t),
138                        y=circs[i, 2] + circs[i, 3]*sin(t))
139               })
140    } else {
141        emptyCoords
142    }
143}
144
145grobPoints.lines <- function(x, closed, ..., n=100) {
146    if (closed) {
147        emptyCoords
148    } else {
149        xx <- convertX(x$x, "in", valueOnly=TRUE)
150        yy <- convertY(x$y, "in", valueOnly=TRUE)
151        list(list(x=xx, y=yy))
152    }
153}
154
155grobPoints.polyline <- function(x, closed, ...) {
156    if (closed) {
157        emptyCoords
158    } else {
159        ## polylineGrob() ensures that x/y same length
160        xx <- convertX(x$x, "in", valueOnly=TRUE)
161        yy <- convertY(x$y, "in", valueOnly=TRUE)
162        pts <- list(x=xx, y=yy)
163        if (is.null(x$id) && is.null(x$id.lengths)) {
164            list(pts)
165        } else {
166            if (is.null(x$id)) {
167                n <- length(x$id.lengths)
168                id <- rep(1L:n, x$id.lengths)
169            } else {
170                n <- length(unique(x$id))
171                id <- x$id
172            }
173            if (n > 1) {
174                split(as.data.frame(pts), id)
175            } else {
176                list(pts)
177            }
178        }
179    }
180}
181
182grobPoints.polygon <- function(x, closed, ...) {
183    if (closed) {
184        ## polygonGrob() ensures that x/y same length
185        xx <- convertX(x$x, "in", valueOnly=TRUE)
186        yy <- convertY(x$y, "in", valueOnly=TRUE)
187        pts <- list(x=xx, y=yy)
188        if (is.null(x$id) && is.null(x$id.lengths)) {
189            list(pts)
190        } else {
191            if (is.null(x$id)) {
192                n <- length(x$id.lengths)
193                id <- rep(1L:n, x$id.lengths)
194            } else {
195                n <- length(unique(x$id))
196                id <- x$id
197            }
198            if (n > 1) {
199                split(as.data.frame(pts), id)
200            } else {
201                list(pts)
202            }
203        }
204    } else {
205        emptyCoords
206    }
207}
208
209xyListFromMatrix <- function(m, xcol, ycol) {
210    n <- nrow(m)
211    lapply(1:n,
212           function(i) {
213               list(x=m[i, xcol], y=m[i, ycol])
214           })
215}
216
217grobPoints.pathgrob <- function(x, closed, ...) {
218    if (closed) {
219        ## pathGrob() ensures that x/y same length
220        xx <- convertX(x$x, "in", valueOnly=TRUE)
221        yy <- convertY(x$y, "in", valueOnly=TRUE)
222        pts <- list(x=xx, y=yy)
223        hasMultiple <- !(is.null(x$pathId) && is.null(x$pathId.lengths))
224        if (hasMultiple) {
225            if (is.null(x$pathId)) {
226                n <- length(x$pathId.lengths)
227                pathId <- rep(1L:n, x$pathId.lengths)
228            } else {
229                pathId <- x$pathId
230            }
231        }
232        if (is.null(x$id) && is.null(x$id.lengths)) {
233            if (hasMultiple) {
234                split(as.data.frame(pts), pathId)
235            } else {
236                list(pts)
237            }
238        } else {
239            if (is.null(x$id)) {
240                n <- length(x$id.lengths)
241                id <- rep(1L:n, x$id.lengths)
242            } else {
243                n <- length(unique(x$id))
244                id <- x$id
245            }
246            if (hasMultiple) {
247                split(as.data.frame(pts), list(id, pathId))
248            } else {
249                split(as.data.frame(pts), id)
250            }
251        }
252    } else {
253        emptyCoords
254    }
255}
256
257grobPoints.rect <- function(x, closed, ...) {
258    if (closed) {
259        hjust <- resolveHJust(x$just, x$hjust)
260        vjust <- resolveVJust(x$just, x$vjust)
261        w <- convertWidth(x$width, "in", valueOnly=TRUE)
262        h <- convertHeight(x$height, "in", valueOnly=TRUE)
263        left <- convertX(x$x, "in", valueOnly=TRUE) - hjust*w
264        bottom <- convertY(x$y, "in", valueOnly=TRUE) - vjust*h
265        right <- left + w
266        top <- bottom + h
267        ## Recycle via cbind()
268        rects <- cbind(left, right, bottom, top)
269        xyListFromMatrix(rects, c(1, 1, 2, 2), c(3, 4, 4, 3))
270    } else {
271        emptyCoords
272    }
273}
274
275grobPoints.segments <- function(x, closed, ...) {
276    if (closed) {
277        emptyCoords
278    } else {
279        x0 <- convertX(x$x0, "in", valueOnly=TRUE)
280        x1 <- convertX(x$x1, "in", valueOnly=TRUE)
281        y0 <- convertY(x$y0, "in", valueOnly=TRUE)
282        y1 <- convertY(x$y1, "in", valueOnly=TRUE)
283        ## Recycle via cbind()
284        xy <- cbind(x0, x1, y0, y1)
285        xyListFromMatrix(xy, 1:2, 3:4)
286    }
287}
288
289grobPoints.xspline <- function(x, closed, ...) {
290    if ((closed && !x$open) ||
291        (!closed && x$open)) {
292        ## xsplinePoints() takes care of multiple X-splines
293        trace <- xsplinePoints(x)
294        if ("x" %in% names(trace)) {
295            ## Single X-spline
296            list(list(x=as.numeric(trace$x),
297                      y=as.numeric(trace$y)))
298        } else {
299            lapply(trace,
300                   function(t) {
301                       list(x=as.numeric(t$x), y=as.numeric(t$y))
302                   })
303        }
304    } else {
305        emptyCoords
306    }
307}
308
309## beziergrob covered by splinegrob (via makeContent)
310
311## Do not treat these as open or closed shapes (for now)
312grobPoints.text <- function(x, closed, ...) {
313    emptyCoords
314}
315
316grobPoints.points <- function(x, closed, ...) {
317    emptyCoords
318}
319
320grobPoints.rastergrob <- function(x, closed, ...) {
321    emptyCoords
322}
323
324grobPoints.clip <- function(x, closed, ...) {
325    emptyCoords
326}
327
328grobPoints.null <- function(x, closed, ...) {
329    emptyCoords
330}
331
332