https://github.com/cran/spatstat
Tip revision: c9b2c621c3bff55aaa77646dc1ba7316765cd7e4 authored by Adrian Baddeley on 25 April 2013, 00:00:00 UTC
version 1.31-2
version 1.31-2
Tip revision: c9b2c62
layered.R
#
# layered.R
#
# Simple mechanism for layered plotting
#
# $Revision: 1.17 $ $Date: 2013/04/25 06:37:43 $
#
layered <- function(..., plotargs=NULL, LayerList=NULL) {
argh <- list(...)
if(length(argh) > 0 && !is.null(LayerList))
stop("LayerList is incompatible with other arguments")
out <- if(!is.null(LayerList)) LayerList else argh
n <- length(out)
if(sum(nzchar(names(out))) != n)
names(out) <- paste("Layer", seq_len(n))
if(!is.null(plotargs)) {
if(!is.list(plotargs) || !all(unlist(lapply(plotargs, is.list))))
stop("plotargs should be a list of lists")
if(length(plotargs) != length(out))
stop("plotargs should have one component for each element of the list")
} else {
plotargs <- rep.int(list(list()), length(out))
}
names(plotargs) <- names(out)
attr(out, "plotargs") <- plotargs
class(out) <- c("layered", class(out))
return(out)
}
print.layered <- function(x, ...) {
cat("Layered object\n")
for(i in seq_along(x)) {
cat(paste("\n", names(x)[i], ":\n", sep=""))
print(x[[i]])
}
pl <- layerplotargs(x)
hasplot <- (unlist(lapply(pl, length)) > 0)
if(any(hasplot))
cat(paste("\nIncludes plot arguments for",
commasep(names(pl)[hasplot]), "\n"))
invisible(NULL)
}
plot.layered <- function(x, ..., which=NULL, plotargs=NULL) {
xname <- short.deparse(substitute(x))
main <- resolve.1.default("main", list(...), list(main=xname))
xp <- if(is.null(which)) x else x[which]
if(length(xp) == 0)
return(invisible(NULL))
# validate plotting arguments
if(is.null(plotargs)) {
plotargs <- attr(x, "plotargs")
if(!is.null(plotargs) && !is.null(which)) plotargs <- plotargs[which]
} else {
if(!is.list(plotargs) || !all(unlist(lapply(plotargs, is.list))))
stop("plotargs should be a list of lists")
if(length(plotargs) != length(xp))
stop("plotargs should have one component for each layer to be plotted")
}
# determine plot frame
started <- FALSE
add <- resolve.1.default("add", list(...), list(add=FALSE))
if(add) {
started <- TRUE
} else {
# new plot
notnul <- !unlist(lapply(x, is.null))
if(sum(notnul) > 1) {
# more than one non-trivial layer.
# Determine bounding frame
boxes <- lapply(x[notnul],
function(z) { try(as.rectangle(z), silent=TRUE) })
if(!any(unlist(lapply(boxes, inherits, what="try-error")))) {
bb <- do.call("bounding.box", boxes)
plot(bb, type="n", main=main)
started <- TRUE
}
}
}
# plot the layers
out <- list()
for(i in seq_along(xp)) {
xpi <- xp[[i]]
if(length(xpi) == 0) {
# null layer - no plotting
out[[i]] <- NULL
} else {
# plot layer i on top of previous layers
iargs <- if(!started) list(main=main) else list(add=TRUE)
out[[i]] <- do.call("plot",
resolve.defaults(list(x=xpi),
list(...),
plotargs[[i]],
iargs))
started <- TRUE
}
}
return(invisible(out))
}
"[.layered" <- function(x, i, j, drop=FALSE, ...) {
if(missing(i) && missing(j))
return(x)
p <- attr(x, "plotargs")
x <- unclass(x)
nx <- length(x)
if(!missing(i) && !is.null(i)) {
x <- x[i]
p <- p[i]
nx <- length(x)
}
isnul <- (unlist(lapply(x, length)) == 0)
if(!missing(j) && !is.null(j))
x[!isnul] <- lapply(x[!isnul], "[", i=j)
if(drop && nx == 1)
return(x[[1]])
y <- layered(LayerList=x, plotargs=p)
return(y)
}
layerplotargs <- function(L) {
stopifnot(inherits(L, "layered"))
attr(L, "plotargs")
}
"layerplotargs<-" <- function(L, value) {
stopifnot(inherits(L, "layered"))
if(length(value) != length(L))
stop("Replacement value is wrong length")
if(!identical(names(value), names(L)))
stop("Mismatch in names of list elements")
attr(L, "plotargs") <- value
L
}
applytolayers <- function(L, FUN, ...) {
# Apply FUN to each **non-null** layer,
# preserving the plot arguments
pla <- layerplotargs(L)
ok <- !unlist(lapply(L, is.null))
L[ok] <- lapply(L[ok], FUN, ...)
Z <- layered(LayerList=L, plotargs=pla)
return(Z)
}
shift.layered <- function(X, ...) {
applytolayers(X, shift, ...)
}
affine.layered <- function(X, ...) {
applytolayers(X, affine, ...)
}
rotate.layered <- function(X, ...) {
applytolayers(X, rotate, ...)
}
reflect.layered <- function(X) {
applytolayers(X, reflect)
}
flipxy.layered <- function(X) {
applytolayers(X, flipxy)
}
scalardilate.layered <- function(X, ...) {
applytolayers(X, scalardilate, ...)
}
rescale.layered <- function(X, s) {
if(!missing(s)) applytolayers(X, rescale, s=s) else applytolayers(X, rescale)
}
as.owin.layered <- function(W, ..., fatal=TRUE) {
if(length(W) == 0) {
if(fatal) stop("Layered object is empty: no window data")
return(NULL)
}
# remove null layers
isnul <- unlist(lapply(W, is.null))
W <- W[!isnul]
Wlist <- lapply(unname(W), as.owin, ..., fatal=fatal)
Wlist <- lapply(Wlist, rescue.rectangle)
Z <- Wlist[[1]]
if(length(Wlist) > 1) {
same <- unlist(lapply(Wlist[-1], identical, y=Z))
if(!all(same))
Z <- do.call("union.owin", Wlist)
}
return(Z)
}