SCM

SCM Repository

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

Annotation of /pkg/R/tileplot.R

Parent Directory Parent Directory | Revision Log Revision Log


Revision 194 - (view) (download)

1 : felix 34 ##
2 :     ## Copyright (c) 2008 Felix Andrews <felix@nfrac.org>
3 :     ## GPL version 2 or newer
4 :    
5 :     tileplot <-
6 :     function(x, data = NULL, aspect = "iso",
7 :     prepanel = "prepanel.default.xyplot",
8 :     panel = "panel.voronoi", ...)
9 :     {
10 :     foo <- levelplot(x, data = data, aspect = aspect,
11 :     panel = panel, prepanel = prepanel, ...)
12 : felix 107 foo$call <- sys.call(sys.parent())
13 : felix 34 foo
14 :     }
15 :    
16 :     ## panel function to draw Voronoi mosaic
17 :     panel.voronoi <-
18 :     function(x, y, z, subscripts = TRUE, at = pretty(z),
19 :     points = TRUE, border = "transparent",
20 :     na.rm = FALSE, win.expand = 0.07, use.tripack = FALSE,
21 :     ...,
22 :     col.regions = regions$col, alpha.regions = regions$alpha)
23 :     {
24 : deepayan 194 ## We need either tripack (better? but weird license) or
25 :     ## deldir. Go with deldir unless explicitly requested.
26 : felix 34 if (use.tripack) {
27 : deepayan 194 if (!requireNamespace("tripack", quietly = TRUE))
28 :     stop("The 'use.tripack=TRUE' option requires the 'tripack' package to be installed.")
29 : felix 34 } else {
30 : deepayan 194 if (!requireNamespace("deldir", quietly = TRUE))
31 :     stop("This function requires the 'deldir' package to be installed.")
32 : felix 34 }
33 :     ## find subset of points to use
34 :     x0 <- x[subscripts]
35 :     y0 <- y[subscripts]
36 :     z0 <- z[subscripts]
37 :     ## throw away NAs, but keep originals for panel.xyplot()
38 :     ok <- complete.cases(x0, y0)
39 :     if (na.rm) ok <- ok & !is.na(z0)
40 :     x <- x0[ok]
41 :     y <- y0[ok]
42 :     z <- z0[ok]
43 :     if (!any(is.finite(z))) return()
44 :     ## strip duplicated locations, with warning
45 :     dup <- duplicated(cbind(x, y))
46 :     if (any(dup)) {
47 :     warning(paste("Ignoring", sum(dup),
48 :     "cases of duplicated locations"))
49 :     x <- x[!dup]
50 :     y <- y[!dup]
51 :     z <- z[!dup]
52 :     }
53 :     ## compute bounds
54 :     data.rg <- list(x = extendrange(x, f = win.expand),
55 :     y = extendrange(y, f = win.expand))
56 :     bounds <- c(data.rg$x, data.rg$y)
57 :     #panel.rg <- lapply(current.panel.limits(), sort)
58 :     #bounds <- c(max(panel.rg$x[1], data.rg$x[1]),
59 :     # min(panel.rg$x[2], data.rg$x[2]),
60 :     # max(panel.rg$y[1], data.rg$y[1]),
61 :     # min(panel.rg$y[2], data.rg$y[2]))
62 :     ## check if any points in visible plot region
63 :     #if (is.unsorted(bounds[1:2]))
64 :     # bounds[1:2] <- panel.rg$x
65 :     #if (is.unsorted(bounds[3:4]))
66 :     # bounds[3:4] <- panel.rg$y
67 :     if (use.tripack) {
68 :     xy <- data.frame(x = x, y = y)
69 :     ## add dummy points to ensure that voronoi polygons are finite
70 :     dummies <- data.frame(x = c(-1,-1,1,1), y = c(-1,1,-1,1)) * 10 * max(abs(xy))
71 :     xy <- rbind(xy, dummies)
72 : deepayan 194 tiles <- tripack::voronoi.polygons(tripack::voronoi.mosaic(xy, duplicate = "error"))
73 : felix 34 } else {
74 :     ## NB: the 'rw' argument as subset of data is bad because
75 :     ## need to take corresponding subset of z !
76 :     ## (but not easy to work out what that is)
77 :    
78 :     #set <- ((bounds[1] < x) & (x < bounds[2]) &
79 :     # (bounds[3] < y) & (y < bounds[4]))
80 :     #x <- x[set]
81 :     #y <- y[set]
82 :     #z <- z[set]
83 : deepayan 194 tiles <- deldir::tile.list(deldir::deldir(x, y, rw = bounds))
84 : felix 34 tiles <- lapply(tiles, function(p) as.data.frame(p[c("x", "y")]))
85 :     }
86 :     ## draw it as one composite polygon
87 :     polydata <- do.call("rbind", tiles)
88 :     regions <- trellis.par.get("regions")
89 :     zcol <- level.colors(z, at, col.regions, colors = TRUE)
90 :     grid.polygon(polydata[,1], polydata[,2],
91 :     id.lengths = sapply(tiles, nrow),
92 :     default.units = "native",
93 :     gp = gpar(fill = zcol, col = border,
94 :     alpha = alpha.regions))
95 :     if (points) {
96 :     panel.xyplot(x0, y0, ...)
97 :     }
98 :     }
99 :    
100 :     panel.levelplot.points <-
101 :     function(x, y, z, subscripts = TRUE, at = pretty(z),
102 :     shrink, labels, label.style, contour, region, ## (all ignored)
103 :     pch = 21, col.symbol = "#00000044",
104 :     ...,
105 :     col.regions = regions$col,
106 :     fill = NULL) ## (ignored)
107 :     {
108 :     regions <- trellis.par.get("regions")
109 :     zcol <- level.colors(z, at, col.regions, colors = TRUE)
110 :     x <- x[subscripts]
111 :     y <- y[subscripts]
112 :     zcol <- zcol[subscripts]
113 :     ## panel.xyplot does the work (can handle 'type' argument, etc)
114 :     panel.xyplot(x, y, fill = zcol, pch = pch,
115 :     col.symbol = col.symbol, ...)
116 :     }

root@r-forge.r-project.org
ViewVC Help
Powered by ViewVC 1.0.0  
Thanks to:
Vienna University of Economics and Business Powered By FusionForge