https://github.com/cran/spatstat
Tip revision: c45b1c249447b9347cc6a2c738437bda562e74cd authored by Adrian Baddeley on 16 October 2008, 00:00:00 UTC
version 1.14-4
version 1.14-4
Tip revision: c45b1c2
split.ppp.R
#
# split.ppp.R
#
# $Revision: 1.9 $ $Date: 2008/07/22 21:15:54 $
#
# split.ppp and "split<-.ppp"
#
#########################################
split.ppp <- function(x, f = marks(x), drop=FALSE, un=NULL, ...) {
verifyclass(x, "ppp")
if(is.null(un))
un <- missing(f)
if(missing(f)) {
# f defaults to marks of x
if(!is.multitype(x))
stop("f is missing and there is no sensible default")
f <- fsplit <- marks(x)
} else{
# f was given
fsplit <- f
# if f is a tessellation or image, determine the grouping
if(inherits(f, "im"))
fsplit <- f <- tess(image=f)
if(inherits(f, "tess")) {
f <- marks(cut(x, f))
} else {
if(!is.factor(f))
stop("f must be a factor")
if(length(f) != x$n)
stop("length(f) must equal the number of points in x")
}
}
lev <- levels(f)
if(drop) {
lev <- lev[table(f) > 0]
fsplit <- fsplit[f %in% lev]
}
# split the data
out <- list()
for(l in lev)
out[[paste(l)]] <- x[f == l]
if(un)
out <- lapply(out, unmark)
if(inherits(fsplit, "tess")) {
til <- tiles(fsplit)
for(i in seq(along=out))
out[[i]]$window <- til[[i]]
}
class(out) <- c("splitppp", class(out))
attr(out, "fsplit") <- fsplit
return(out)
}
"split<-.ppp" <- function(x, f=marks(x), drop=FALSE, un=missing(f),
..., value) {
verifyclass(x, "ppp")
stopifnot(is.list(value))
if(!all(unlist(lapply(value, is.ppp))))
stop(paste("Each entry of", sQuote("value"),
"must be a point pattern"))
ismark <- unlist(lapply(value, is.marked))
if(any(ismark) && !all(ismark))
stop(paste("Some entries of",
sQuote("value"),
"are marked, and others are unmarked"))
vmarked <- all(ismark)
# evaluate `un' before assigning value of 'f'
un <- un
if(!missing(f)) {
fsplit <- f
if(inherits(f, "tess"))
f <- marks(cut(x, f))
if(!is.factor(f))
stop("f must be a factor")
if(length(f) != x$n)
stop("length(f) must equal the number of points in x")
} else {
if(is.multitype(x))
f <- fsplit <- marks(x)
else
stop("f is missing and there is no sensible default")
}
lev <- levels(f)
if(!drop)
levtype <- "levels of f"
else {
levtype <- "levels which f actually takes"
lev <- lev[table(f) > 0]
fsplit <- fsplit[f %in% lev]
}
if(length(value) != length(lev))
stop(paste("length of", sQuote("value"),
"should equal the number of",
levtype))
# ensure value[[i]] is associated with lev[i]
if(!is.null(names(value))) {
if(!all(names(value) %in% paste(levels(f))))
stop(paste("names of", sQuote("value"), "should be levels of f"))
value <- value[lev]
}
names(value) <- NULL
# restore the marks, if they were discarded
if(un && is.marked(x)) {
if(vmarked)
warning(paste(sQuote("value"), "contains marked point patterns:",
"this is inconsistent with un=TRUE; marks ignored."))
for(i in seq(value))
value[[i]] <- value[[i]] %mark% factor(lev[i], levels=levels(f))
}
out <- superimpose(value, W=x$window)
return(out)
}
print.splitppp <- function(x, ...) {
f <- attr(x, "fsplit")
cat(paste("Point pattern split by",
if(inherits(f, "tess")) "tessellation" else "factor",
"\n"))
nam <- names(x)
for(i in seq(length(x))) {
cat(paste("\n", nam[i], ":\n", sep=""))
print(x[[i]])
}
return(invisible(NULL))
}
summary.splitppp <- function(object, ...) {
x <- lapply(object, summary, ...)
class(x) <- "summary.splitppp"
x
}
print.summary.splitppp <- function(x, ...) {
class(x) <- "listof"
print(x)
invisible(NULL)
}
"[.splitppp" <- function(x, ...) {
f <- attr(x, "fsplit")
# invoke list method on x
class(x) <- "list"
y <- x[...]
# then make it a 'splitppp' object too
class(y) <- c("splitppp", class(y))
attr(y, "fsplit") <- f[...]
y
}
"[<-.splitppp" <- function(x, ..., value) {
f <- attr(x, "fsplit")
# invoke list method
class(x) <- "list"
x[...] <- value
# then make it a 'splitppp' object too
class(x) <- c("splitppp", class(x))
attr(x, "fsplit") <- f
x
}