R/pp3.R

In spatstat.geom: Geometrical Functionality of the 'spatstat' Family

#
#   pp3.R
#
#  class of three-dimensional point patterns in rectangular boxes
#
#  $Revision: 1.33 $  $Date: 2020/12/19 05:25:06 $
#

box3 <- function(xrange=c(0,1), yrange=xrange, zrange=yrange, unitname=NULL) {
  stopifnot(is.numeric(xrange) && length(xrange) == 2 && diff(xrange) > 0)
  stopifnot(is.numeric(yrange) && length(yrange) == 2 && diff(yrange) > 0)
  stopifnot(is.numeric(zrange) && length(zrange) == 2 && diff(zrange) > 0)
  out <- list(xrange=xrange, yrange=yrange, zrange=zrange,
              units=as.unitname(unitname))
  class(out) <- "box3"
  return(out)
}

as.box3 <- function(...) {
  a <- list(...)
  n <- length(a)
  if(n == 0)
    stop("No arguments given")
  if(n == 1) {
    a <- a[[1]]
    if(inherits(a, "box3"))
      return(a)
    if(inherits(a, "pp3"))
      return(a$domain)
    if(inherits(a, "boxx")){
      if(ncol(a$ranges)==3)
        return(box3(a$ranges[,1], a$ranges[,2], a$ranges[,3]))
      stop("Supplied boxx object does not have dimension three")
    }
    if(inherits(a, "ppx"))
      return(as.box3(a$domain))
    if(is.numeric(a)) {
      if(length(a) == 6)
        return(box3(a[1:2], a[3:4], a[5:6]))
      stop(paste("Don't know how to interpret", length(a), "numbers as a box"))
    }
    if(!is.list(a))
      stop("Don't know how to interpret data as a box")
  }
  return(do.call(box3, a))
}

print.box3 <- function(x, ...) {
  bracket <- function(z) paste("[",
                               paste(signif(z, 5), collapse=", "),
                               "]", sep="")
  v <- paste(unlist(lapply(x[1:3], bracket)), collapse=" x ")
  s <- summary(unitname(x))
  splat("Box:", v, s$plural, s$explain)
  invisible(NULL)
}

unitname.box3 <- function(x) { as.unitname(x$units) }

"unitname<-.box3" <- function(x, value) {
  x$units <- as.unitname(value)
  return(x)
}

grow.box3 <- function(W, left, right=left) {
  as.box3(grow.boxx(as.boxx(W), left, right))
}

eroded.volumes <- function(x, r) { UseMethod("eroded.volumes") }

eroded.volumes.box3 <- function(x, r) {
  b <- as.box3(x)
  ax <- pmax.int(0, diff(b$xrange) - 2 * r)
  ay <- pmax.int(0, diff(b$yrange) - 2 * r)
  az <- pmax.int(0, diff(b$zrange) - 2 * r)
  ax * ay * az
}

shortside <- function(x) { UseMethod("shortside") }

shortside.box3 <- function(x) {
  min(sidelengths(x))
}

sidelengths <- function(x) { UseMethod("sidelengths") }

sidelengths.box3 <- function(x) {
  with(x, c(diff(xrange), diff(yrange), diff(zrange)))
}

bounding.box3 <- function(...) {
  wins <- list(...)
  boxes <- lapply(wins, as.box3)
  xr <- range(unlist(lapply(boxes, getElement, name="xrange")))
  yr <- range(unlist(lapply(boxes, getElement, name="yrange")))
  zr <- range(unlist(lapply(boxes, getElement, name="zrange")))
  box3(xr, yr, zr)
}

pp3 <- function(x, y, z, ..., marks=NULL) {
  stopifnot(is.numeric(x))
  stopifnot(is.numeric(y))
  stopifnot(is.numeric(z)) 
  b <- as.box3(...)
  out <- ppx(data=data.frame(x=x,y=y,z=z), domain=b)
  class(out) <- c("pp3", class(out))
  if(!is.null(marks)) marks(out) <- marks
  return(out)
}

domain.pp3 <- function(X, ...) { X$domain }

is.pp3 <- function(x) { inherits(x, "pp3") }

npoints.pp3 <- function(x) { nrow(x$data) }

print.pp3 <- function(x, ...) {
  ism <- is.marked(x, dfok=TRUE)
  nx <- npoints(x)
  splat(if(ism) "Marked three-dimensional" else "Three-dimensional",
        "point pattern:",
        nx, ngettext(nx, "point", "points"))
  if(ism) {
    mks <- marks(x, dfok=TRUE)
    if(is.data.frame(mks) | is.hyperframe(mks)) {
      ## data frame of marks
      exhibitStringList("Mark variables:", names(mks))
    } else {
      ## vector of marks
      if(is.factor(mks)) {
        exhibitStringList("Multitype, with levels =", levels(mks))
      } else {
        ## Numeric, or could be dates
        if(inherits(mks, "Date")) {
          splat("marks are dates, of class", sQuote("Date"))
        } else if(inherits(mks, "POSIXt")) {
          splat("marks are dates, of class", sQuote("POSIXt"))
        } else {
          splat(paste0("marks are", if(is.numeric(mks)) " numeric," else NULL),
                "of storage type ", sQuote(typeof(mks)))
        }
      }
    }
  }
  print(x$domain)
  invisible(NULL)
}

summary.pp3 <- function(object, ...) {
  sd <- summary(object$data)
  np <- sd$ncases
  dom <- object$domain
  v <- volume.box3(dom)
  u <- summary(unitname(dom))
  intens <- np/v
  out <-  list(np=np, sumdat=sd, dom=dom, v=v, u=u, intensity=intens)
  class(out) <- "summary.pp3"
  return(out)
}

print.summary.pp3 <- function(x, ...) {
  splat("Three-dimensional point pattern")
  splat(x$np, ngettext(x$np, "point", "points"))
  print(x$dom)
  u <- x$u
  v <- x$v
  splat("Volume", v, "cubic",
        if(v == 1) u$singular else u$plural,
        u$explain)
  splat("Average intensity", x$intensity,
        "points per cubic", u$singular, u$explain)
  invisible(NULL)
}

plot.pp3 <- function(x, ..., eye=NULL, org=NULL, theta=25, phi=15,
                     type=c("p", "n", "h"),
                     box.back=list(col="pink"),
                     box.front=list(col="blue", lwd=2)) {
  xname <- short.deparse(substitute(x))
  type <- match.arg(type)
  # given arguments
  argh <- list(...)
  if(!missing(box.front)) argh$box.front <- box.front
  if(!missing(box.back))  argh$box.back  <- box.back
  # Now apply formal defaults above
  formaldefaults <- list(box.front=box.front, box.back=box.back)
  #'
  coo <- as.matrix(coords(x))
  xlim <- x$domain$xrange
  ylim <- x$domain$yrange
  zlim <- x$domain$zrange
  if(is.null(org)) org <- c(mean(xlim), mean(ylim), mean(zlim))
  if(is.null(eye)) {
    theta <- theta * pi/180
    phi   <- phi * pi/180
    d <- 2 * diameter(x$domain)
    eye <- org + d * c(cos(phi) * c(sin(theta), -cos(theta)), sin(phi))
  }
  deefolts <- spatstat.options('par.pp3')
  ## determine default eye position and centre of view
  dont.complain.about(coo)
  do.call(plot3Dpoints,
          resolve.defaults(list(xyz=quote(coo), eye=eye, org=org, type=type),
                           argh,
                           deefolts,
                           formaldefaults,
                           list(main=xname,
                                xlim=xlim,
                                ylim=ylim,
                                zlim=zlim)))
}

"[.pp3" <- function(x, i, drop=FALSE, ...) {
  answer <- NextMethod("[")
  if(is.ppx(answer))
    class(answer) <- c("pp3", class(answer))
  return(answer)
}
  
unitname.pp3 <- function(x) { unitname(x$domain) }

"unitname<-.pp3" <- function(x, value) {
  d <- x$domain
  unitname(d) <- value
  x$domain <- d
  return(x)
}

diameter.box3 <- function(x) {
  stopifnot(inherits(x, "box3"))
  with(x, sqrt(diff(xrange)^2+diff(yrange)^2+diff(zrange)^2))
}

volume <- function(x) { UseMethod("volume") }

volume.box3 <- function(x) {
  stopifnot(inherits(x, "box3"))
  with(x, prod(diff(xrange), diff(yrange), diff(zrange)))
}