R/pp3.R

Defines functions volume.box3 volume diameter.box3 unitname.pp3 plot.pp3 print.summary.pp3 summary.pp3 print.pp3 npoints.pp3 is.pp3 domain.pp3 pp3 bounding.box3 sidelengths.box3 sidelengths shortside.box3 shortside eroded.volumes.box3 eroded.volumes grow.box3 unitname.box3 print.box3 as.box3 box3

Documented in as.box3 bounding.box3 box3 diameter.box3 domain.pp3 eroded.volumes eroded.volumes.box3 grow.box3 is.pp3 npoints.pp3 plot.pp3 pp3 print.box3 print.pp3 print.summary.pp3 shortside shortside.box3 sidelengths sidelengths.box3 summary.pp3 unitname.box3 unitname.pp3 volume volume.box3

#
#   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)))
}

Try the spatstat.geom package in your browser

Any scripts or data that you put into this service are public.

spatstat.geom documentation built on Sept. 18, 2024, 9:08 a.m.