R/plot.tile.list.R

In deldir: Delaunay Triangulation and Dirichlet (Voronoi) Tessellation

plot.tile.list <- function (x, verbose = FALSE, close = FALSE, pch = 1,
                            fillcol = getCol(x,warn=warn), col.pts=NULL,
                            col.lbls=NULL,border=NULL, showpoints = !labelPts,
                            add = FALSE, asp = 1, clipp=NULL, xlab = "x",
                            ylab = "y", main = "", warn=TRUE,
                            labelPts=FALSE,adj=NULL,...) {
# Check for use of the defunct argument name "number".
ccc <- match.call()
i   <- match("number",names(ccc))
if(!is.na(i)) {
    if("labelPts" %in% names(ccc)) {
        whinge <- paste0("Both \"labelPts\" and the defunct argument",
                         " \"number\" have been\n  specified.  Do not use",
                         " the defunct argument \"number\".  Use\n",
                         "  \"labelPts\" only.\n")
        stop(whinge)
    }
    whinge <- paste0("The argument name \"number\" is defunct. Please",
                     " use \"labelPts\"\n  instead.\n")
    warning(whinge)
    names(ccc)[i] <- "labelPts"
    return(eval(ccc))
}

# Carry on.
    object <- x
    if (!inherits(object, "tile.list")) 
        stop("Argument \"object\" is not of class tile.list.\n")
    clip  <- !is.null(clipp)
    if(clip) {
        if(!is.null(attr(object,"clipp"))) {
            whinge <- paste0("Argument \"x\" is already clipped.  Re-clip it\n",
                             "  if you want a different clipping polygon.\n")
            stop(whinge)
            if(!requireNamespace("polyclip",quietly=TRUE)) {
                stop("Cannot clip the tiles; package \"polyclip\" not available.\n")
            }
        }
    }
    n     <- length(object)
    rw    <- attr(object, "rw")
    rx    <- rw[1:2]
    ry    <- rw[3:4]
    x.pts <- unlist(lapply(object, function(w) {
        w$pt[1]
    }))
    y.pts <- unlist(lapply(object, function(w) {
        w$pt[2]
    }))
    if (!add) 
        plot(0, 0, type = "n", asp = asp, xlim = rx, ylim = ry, 
            xlab = xlab, ylab = ylab, main = main)
    fillcol <- apply(col2rgb(fillcol, TRUE), 2, function(x) {
        do.call(rgb, as.list(x/255))
    })
    fillcol <- rep(fillcol, length = length(object))
    hexbla <- do.call(rgb, as.list(col2rgb("black", TRUE)/255))
    hexwhi <- do.call(rgb, as.list(col2rgb("white", TRUE)/255))
    if(is.null(col.pts)){
        col.pts <- ifelse(fillcol == hexbla, hexwhi, hexbla)
    } else {
        col.pts <- apply(col2rgb(col.pts, TRUE), 2, function(x) {
            do.call(rgb, as.list(x/255))
        })
        col.pts <- rep(col.pts, length = length(object))
    }
    if(is.null(col.lbls)){
        col.lbls <- ifelse(fillcol == hexbla, hexwhi, hexbla)
    } else {
        col.lbls <- apply(col2rgb(col.lbls, TRUE), 2, function(x) {
            do.call(rgb, as.list(x/255))
        })
        col.lbls <- rep(col.lbls, length = length(object))
    }
    if(is.null(border)) {
        border <- if(all(fillcol == hexbla)) hexwhi else hexbla
    } else if(length(border) > 1) border <- border[1]
    lnwid <- if(all(fillcol == hexbla)) 2 else 1
    ptNms <- names(x)
    Adj <- adj
    if(is.null(Adj)) Adj <- if(showpoints) -1 else 0
    pch <- rep(pch,n)
    pgons <- vector("list",n)
    icol <- 0
    for(i in 1:n) {
        pgon <- if(clip) doClip(object[[i]],clipp,rw) else object[[i]]
        pgons[[i]] <- pgon
        if(is.null(pgon)) next
        icol <- icol+1
        if(is.null(attr(pgon,"ncomp"))) attr(pgon,"ncomp") <- 1
        if(attr(pgon,"ncomp") > 1) {
            pgon <- pgon$tileParts
        } else pgon <- list(pgon)
        for(ii in seq(along=pgon)){
            ptmp <- pgon[[ii]]
            inner <- !any(ptmp$bp)
            polygon(ptmp,col=fillcol[icol],border=NA)
            if (close | inner) { 
                polygon(ptmp,col = NA, border = border, lwd = lnwid)
            } else {
                x <- ptmp$x
                y <- ptmp$y
                ni <- length(x)
                for (j in 1:ni) {
                    jnext <- if (j < ni) j + 1 else 1
                    do.it <- mid.in(x[c(j, jnext)], y[c(j, jnext)], rx, ry)
                    if (do.it) 
                        segments(x[j], y[j], x[jnext], y[jnext],
                                 col = border, lwd = lnwid)
                }
            }
         }
         if(verbose) {
             if(showpoints) points(object[[i]]$pt[1], object[[i]]$pt[2],
                                   pch = pch[i], col = col.pts[i],...)
             if(labelPts) text(object[[i]]$pt[1], object[[i]]$pt[2],
                             labels=ptNms[i], col = col.lbls[i],adj=Adj,...)
             if(i < n) readline(paste("i = ",i,"; Go? ",sep=""))
             if(i == n) cat("i = ",i,"\n",sep="")
         }
    }
    ok <- !sapply(pgons,is.null)
    if(showpoints & !verbose)
        points(x.pts[ok], y.pts[ok], pch = pch[ok], col = col.pts[ok],...)
    if (labelPts & !verbose) 
        text(x.pts[ok], y.pts[ok], labels = ptNms[ok], col = col.lbls[ok],
             adj=Adj,...)
    pgons <- pgons[ok]
    pgons <- if(length(pgons)) pgons else NULL
    invisible(pgons)
}