#
# fii.R
#
# Class of fitted interpoint interactions
#
#
fii <- function(interaction=NULL, coefs=numeric(0),
Vnames=character(0), IsOffset=NULL) {
if(is.null(interaction))
interaction <- Poisson()
stopifnot(is.interact(interaction))
if(is.poisson.interact(interaction)) {
if(length(Vnames) > 0)
stop("Coefficients inappropriate for Poisson process")
}
if(is.null(IsOffset))
IsOffset <- rep.int(FALSE, length(Vnames))
else {
stopifnot(is.logical(IsOffset))
stopifnot(length(IsOffset) == length(Vnames))
}
out <- list(interaction=interaction,
coefs=coefs,
Vnames=Vnames,
IsOffset=IsOffset)
class(out) <- c("fii", class(out))
return(out)
}
summary.fii <- function(object, ...) {
y <- unclass(object)
INTERACT <- object$interaction
coefs <- object$coefs
Vnames <- object$Vnames
IsOffset <- object$IsOffset
y$poisson <- is.poisson.interact(INTERACT)
thumbnail <- NULL
if(y$poisson) {
thumbnail <- "Poisson()"
} else {
if(!is.null(INTERACT$interpret)) {
# invoke auto-interpretation feature
sensible <-
if(newstyle.coeff.handling(INTERACT))
(INTERACT$interpret)(coefs[Vnames[!IsOffset]], INTERACT)
else
(INTERACT$interpret)(coefs, INTERACT)
if(!is.null(sensible)) {
header <- paste("Fitted", sensible$inames)
printable <- sensible$printable
# Try to make a thumbnail description
param <- sensible$param
ipar <- INTERACT$par
if(all(unlist(lapply(param, length)) == 1) &&
all(unlist(lapply(ipar, length)) == 1)) {
allargs <- append(ipar, param)
allargs <- lapply(allargs, signif, digits=4)
thumbnail <- fakecallstring(INTERACT$creator, allargs)
}
} else {
# no fitted interaction parameters (e.g. Hard Core)
header <- NULL
printable <- NULL
thumbnail <- paste0(INTERACT$creator, "()")
}
} else {
# fallback
sensible <- NULL
VN <- Vnames[!IsOffset]
if(length(VN) > 0) {
header <- "Fitted interaction terms"
icoef <- coefs[VN]
printable <- exp(unlist(icoef))
ricoef <- lapply(icoef, signif, digits=4)
thumbnail <- fakecallstring(INTERACT$creator, ricoef)
} else {
header <- NULL
printable <- NULL
thumbnail <- paste0(INTERACT$creator, "()")
}
}
y <- append(y, list(sensible=sensible,
header=header,
printable=printable,
thumbnail=thumbnail))
}
class(y) <- c("summary.fii", class(y))
return(y)
}
print.fii <- function(x, ...) {
sx <- summary(x)
do.call(print.summary.fii,
resolve.defaults(list(x=sx, brief=TRUE), list(...)))
return(invisible(NULL))
}
print.summary.fii <- local({
#' hide internal arguments
print.summary.fii <- function(x, ...) {
PrintIt(x, ...)
}
PrintIt <- function(x, ..., prefix="Interaction: ",
banner=TRUE,
family = waxlyrical('extras'),
brief = !family,
tiny = !waxlyrical('errors')) {
if(tiny) {
#' use thumbnail if available
thumbnail <- x$thumbnail
if(!is.null(thumbnail)) {
splat(thumbnail)
return(invisible(NULL))
}
}
terselevel <- spatstat.options('terse')
if(banner && !brief)
cat(prefix)
if(x$poisson) {
splat("Poisson process")
parbreak(terselevel)
} else {
print(x$interaction, family=family, brief=TRUE, banner=banner)
if(!is.null(x$printable)) {
nvalues <- length(x$printable)
nheader <- length(x$header)
if(nvalues == 1) {
splat(paste(paste0(x$header, ":\t"), x$printable))
} else if(nvalues == nheader) {
for(i in 1:nheader) {
hdi <- x$header[i]
xpi <- x$printable[[i]]
if(!is.list(xpi) && length(xpi) == 1) {
splat(paste0(hdi, ":\t", xpi))
} else {
splat(paste0(hdi, ":"))
print(xpi)
}
}
} else {
splat(x$header)
print(x$printable)
}
}
}
if(!brief) {
co <- x$coefs[x$Vnames[!x$IsOffset]]
if(length(co) > 0) {
parbreak(terselevel)
splat("Relevant coefficients:")
print(co)
}
}
return(invisible(NULL))
}
print.summary.fii
})
parameters.fii <- function(model, ...) {
ss <- summary(model)
out <- append(ss$interaction$par, ss$sensible$param)
return(out)
}
coef.summary.fii <- function(object, ...) {
object$printable
}
reach.fii <- function(x, ..., epsilon=0) {
inte <- x$interaction
coeffs <- x$coefs
Vnames <- x$Vnames
if(is.poisson.interact(inte))
return(0)
# get 'irange' function from interaction object
irange <- inte$irange
if(is.null(irange))
return(Inf)
# apply 'irange' function using fitted coefficients
if(newstyle.coeff.handling(inte))
ir <- irange(inte, coeffs[Vnames], epsilon=epsilon)
else
ir <- irange(inte, coeffs, epsilon=epsilon)
if(is.na(ir))
ir <- Inf
return(ir)
}
plot.fii <- function(x, ...) {
inte <- x$interaction
if(is.poisson.interact(inte)) {
message("Poisson interaction; nothing plotted")
return(invisible(NULL))
}
plfun <- inte$plot %orifnull% inte$family$plot
if(is.null(plfun))
stop("Plotting not implemented for this type of interaction")
plfun(x, ...)
}
fitin <- function(object) {
UseMethod("fitin")
}
fitin.ppm <- function(object) {
f <- object$fitin
if(!is.null(f))
return(f)
# For compatibility with older versions
inte <- object$interaction
if(is.null(inte))
f <- fii() # Poisson
else {
coefs <- coef(object)
Vnames <- object$internal$Vnames
IsOffset <- object$internal$IsOffset
# Internal names of regressor variables
f <- fii(inte, coefs, Vnames, IsOffset)
}
unitname(f) <- unitname(data.ppm(object))
return(f)
}
as.interact.fii <- function(object) {
verifyclass(object, "fii")
return(object$interaction)
}
coef.fii <- function(object, ...) {
verifyclass(object, "fii")
return(object$coefs)
}