https://github.com/cran/spatstat
Tip revision: faf8864bb7a1236c2b27fd63c8abb76be20e9386 authored by Adrian Baddeley on 19 October 2006, 22:36:34 UTC
version 1.10-1
version 1.10-1
Tip revision: faf8864
marks.R
#
# marks.R
#
# stuff for handling marks
#
#
.Spatstat.Forbids.Df <- TRUE
marks <- function(x, ...) {
UseMethod("marks")
}
# The 'dfok' switch is temporary
# while we convert the code to accept data frames of marks
marks.ppp <- function(x, ..., dfok=FALSE) {
ma <- x$marks
if(is.data.frame(ma) && !dfok)
stop("Sorry, not implemented when the marks are a data frame")
return(ma)
}
# ------------------------------------------------------------------
"marks<-" <- function(x, ..., value) {
UseMethod("marks<-")
}
"marks<-.ppp" <- function(x, dfok=FALSE, ..., value) {
if(is.data.frame(value) && !dfok)
stop("Sorry, data frames of marks are not yet implemented")
x <- setmarks(x, value)
return(x)
}
# -------------------------------------------------
markformat <- function(x) {
UseMethod("markformat")
}
markformat.ppp <- function(x) {
mf <- x$markformat
if(is.null(mf)) {
x <- as.ppp(x)
mf <- x$markformat
if(is.null(mf))
stop("Internal error: markformat.ppp failed")
}
return(mf)
}
# ------------------------------------------------------------------
"is.marked" <-
function(X, ...) {
UseMethod("is.marked")
}
"is.marked.ppp" <-
function(X, na.action="warn", ...) {
marx <- marks(X, ...)
if(is.null(marx))
return(FALSE)
if(any(is.na(marx)))
switch(na.action,
warn = {
warning(paste("some mark values are NA in the point pattern",
deparse(substitute(X))))
},
fatal = {
return(FALSE)
},
ignore = {}
)
return(TRUE)
}
"is.marked.default" <-
function(...) { return(FALSE) }
# ------------------------------------------------------------------
is.multitype <- function(X, ...) {
UseMethod("is.multitype")
}
is.multitype.default <- function(...) { return(FALSE) }
is.multitype.ppp <- function(X, na.action="warn", ...) {
marx <- marks(X, ...)
if(is.null(marx))
return(FALSE)
if(any(is.na(marx)))
switch(na.action,
warn = {
warning(paste("some mark values are NA in the point pattern",
deparse(substitute(X))))
},
fatal = {
return(FALSE)
},
ignore = {}
)
return(!is.data.frame(marx) && is.factor(marx))
}
# ------------------------------------------------------------------
"unmark" <-
function(X) {
if(inherits(X, "ppp")) {
X$marks <- NULL
return(X)
} else if(inherits(X, "splitppp")) {
Y <- lapply(X, unmark)
class(Y) <- c("splitppp", class(Y))
return(Y)
} else
stop(paste("X must be a point pattern (class", dQuote("ppp"), ") ",
"or a list of point patterns (class", dQuote("splitppp"), ")",
sep=""))
}
##### utility functions for subsetting & combining marks #########
findmarktype <- function(x) {
if(is.null(x)) return("none")
if(is.vector(x)) return("vector")
if(is.data.frame(x)) return("dataframe")
if(inherits(x, "listof")) return("listof")
stop("Internal error: unrecognised mark format")
}
marksubset <- function(x, index, format=NULL) {
if(is.null(format)) format <- findmarktype(x)
switch(format,
none={return(NULL)},
vector={return(x[index])},
dataframe={return(x[index,,drop=FALSE])},
listof={return(x[index])},
stop("Internal error: unrecognised format of marks"))
}
"%msub%" <- marksubsetop <- function(x,i) { marksubset(x, i) }
"%mrep%" <- markreplicateop <- function(x,n) {
format <- findmarktype(x)
switch(format,
none={return(NULL)},
listof=,
vector={ return(rep(x,n))},
dataframe={
return(as.data.frame(lapply(x, function(z, k) rep(z, k), k=n)))
},
stop("Internal error: unrecognised format of marks"))
}
"%mapp%" <- markappendop <- function(x,y) {
format <- findmarktype(x)
switch(format,
none={return(NULL)},
vector={ return(c(x,y)) },
dataframe={ return(rbind(x,y)) },
listof = {
z <- append(x,y)
if(!inherits(z, "listof"))
class(z) <- c("listof", class(z))
return(z)
},
stop("Internal error: unrecognised format of marks"))
}