R/tile.list.R

In deldir: Delaunay Triangulation and Dirichlet (Voronoi) Tessellation

tile.list <- local({
edgeLengths <- function(x,y) {
    n <- length(x)
    el <- numeric(n) 
    for(i in 1:n) {
        ii <- if(i < n) i+1 else 1
        el[i] <- sqrt((x[i] - x[ii])^2 + (y[i] - y[ii])^2)
    } 
    el 
}

function (object,minEdgeLength=NULL,clipp=NULL) {
  if (!inherits(object, "deldir"))
    stop("Argument \"object\" is not of class \"deldir\".\n")
  rw <- object$rw
  if(is.null(minEdgeLength)) {
    drw <- sqrt((rw[2] - rw[1])^2 + (rw[4] - rw[3])^2)
    minEdgeLength <- drw*sqrt(.Machine$double.eps)
  }
  x.crnrs <- rw[c(1, 2, 2, 1)]
  y.crnrs <- rw[c(3, 3, 4, 4)]
  ddd <- object$dirsgs
  sss <- object$summary
  npts <- nrow(sss)
  x <- sss[["x"]]
  y <- sss[["y"]]
  z <- sss[["z"]]
  id <- sss[["id"]]
  noid <- is.null(id)
  if(noid) id <- 1:nrow(sss)
  noz <- is.null(z)
  i.crnr <- get.cnrind(x, y, rw)
  ind.orig <- object$ind.orig
  rslt <- vector("list",npts)
  for (i in 1:npts) {
    filter1 <- ddd$ind1 == id[i]
    filter2 <- ddd$ind2 == id[i]
    subset  <- ddd[which(filter1 | filter2),,drop=FALSE]
    m <- matrix(unlist(subset[, 1:4]), ncol = 4)
    bp1 <- subset[, 7]
    bp2 <- subset[, 8]
    m1 <- cbind(m[, 1:2, drop = FALSE], 0 + bp1)
    m2 <- cbind(m[, 3:4, drop = FALSE], 0 + bp2)
    m <- rbind(m1, m2)
    pt <- c(x = sss$x[i], y = sss$y[i])
    theta <- atan2(m[, 2] - pt[2], m[, 1] - pt[1])
    theta.0 <- sort(unique(theta))
    mm <- m[match(theta.0, theta),,drop=FALSE]
    xx <- mm[, 1]
    yy <- mm[, 2]
    bp <- as.logical(mm[, 3])
    ii <- i.crnr %in% i
    xx <- c(xx, x.crnrs[ii])
    yy <- c(yy, y.crnrs[ii])
    bp <- c(bp, rep(TRUE, sum(ii)))
    tmp <- list(ptNum = ind.orig[i],
                pt    = pt,
                x     = unname(xx),
                y     = unname(yy),
                bp    = bp,
                area  = sss$dir.area[i])
    tmp    <- acw(tmp)
    bird   <- edgeLengths(tmp$x,tmp$y)
    ok     <- bird >= minEdgeLength
    tmp$x  <- tmp$x[ok]
    tmp$y  <- tmp$y[ok]
    tmp$bp <- tmp$bp[ok]
    rslt[[i]] <-acw(tmp)
    if(!noz) {
        rslt[[i]]["z"] <- z[i]
    }
    if(is.null(clipp)) {
        attr(rslt[[i]],"ncomp") <- 1
    }
}
if(!is.null(clipp)) {
    if(requireNamespace("polyclip",quietly=TRUE)) {
        rslt <- lapply(rslt,doClip,clipp=clipp,rw=rw)
    } else {
        stop("Cannot clip the tiles; package \"polyclip\" not available.\n")
    }
}
    ok <- !sapply(rslt,is.null)
    rslt <- rslt[ok]
    if(noid) {
        id <- paste0("pt.",id)
    }
    names(rslt) <- id[ok]
    class(rslt) <- "tile.list"
    attr(rslt, "rw") <- object$rw
    attr(rslt,"clipp") <- clipp
    return(rslt)
}

})

"[.tile.list" <- function(x,i,...){
    y <- unclass(x)[i]
    class(y) <- "tile.list"
    attr(y,"rw") <- attr(x,"rw")
    y
}