| 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 : |
|
|
}
|
Parent Directory
| 
Revision Log
