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