R/grob.R

In gridGeometry: Polygon Geometry in 'grid'

################################################################################
## Convert polyclip() results to grobs

## Convert (closed) 'polyclip' polygon result to 'grid' path
xyListPath <- function(x, rule="winding", name=NULL, gp=gpar()) {
    ## Remove any coordinate sets that are too short
    x <- x[sapply(x, function(c) length(c$x) > 1)]
    if (length(x) == 0) {
        nullGrob(name=name)
    } else {
        xx <- unlist(lapply(x, "[[", "x"))
        yy <- unlist(lapply(x, "[[", "y"))
        lengths <- sapply(x, function(y) length(y$x))
        pathGrob(xx, yy, default.units="in",
                 id.lengths=lengths, rule=rule,
                 name=name, gp=gp)
    }
}

xyListToPath <- xyListPath

## Convert (closed) 'polyclip' polygon result to 'grid' polygons
xyListPolygon <- function(x, name=NULL, gp=gpar()) {
    ## Remove any coordinate sets that are too short
    x <- x[sapply(x, function(c) length(c$x) > 1)]
    if (length(x) == 0) {
        nullGrob(name=name)
    } else {
        xx <- unlist(lapply(x, "[[", "x"))
        yy <- unlist(lapply(x, "[[", "y"))
        lengths <- sapply(x, function(y) length(y$x))
        polygonGrob(xx, yy, default.units="in",
                    id.lengths=lengths,
                    name=name, gp=gp)
    }
}

xyListToPolygon <- xyListPolygon

## Convert (open) 'polyclip' polygon result to 'grid' polyline
xyListLine <- function(x, name=NULL, gp=gpar()) {
    if (length(x) == 0) {
        nullGrob(name=name)
    } else {
        xx <- unlist(lapply(x, "[[", "x"))
        yy <- unlist(lapply(x, "[[", "y"))
        lengths <- sapply(x, function(y) length(y$x))
        polylineGrob(xx, yy, default.units="in",
                     id.lengths=lengths,
                     name=name, gp=gp)
    }
}

xyListToLine <- xyListLine

################################################################################
## Convert grobs to valid input for polyclip()

numShapes <- function(coords) {
    ## Coords generated by 'grid' should be named
    ## Otherwise assume each set of coords is a separate shape
    if (is.null(names(coords))) {
        length(coords)
    } else {
        length(unique(names(coords)))
    }
}

xyListFromCoords <- function(x, op, closed, rule, ...) {
    UseMethod("xyListFromCoords")
}

emptyXYlist <- list(list(x = 0, y = 0))

xyListFromCoords.GridGrobCoords <- function(x, op, closed, rule, ...) {
    if (op == "flatten") {
        attr(x, "name") <- NULL
        attr(x, "rule") <- NULL
        unclass(unname(x))
    } else {
        if (numShapes(x) == 1) {
            x
        } else {
            names <- names(x)
            unames <- sort(unique(names))
            n <- length(unames)
            A <- x[names == unames[1]]
            B <- x[names == unames[2]]
            fillrule <- convertRule(rule)
            coords <- polyclip::polyclip(A, B, op, closed,
                                         fillA = fillrule,
                                         fillB = fillrule,
                                         ...)
            ## Convert polyclip::polyclip() list() result to "emptyCoords".
            ## We try not to feed polyclip::polyclip() a list() as input.
            if (!length(coords))
                coords <- emptyXYlist
            if (n > 2) {
                for (i in 3:n) {
                    A <- coords
                    B <- x[names == unames[i]]
                    coords <- polyclip::polyclip(A, B, op, closed,
                                                 fillA = fillrule,
                                                 fillB = fillrule,
                                                 ...)
                    if (!length(coords))
                        coords <- emptyXYlist
                }
            }
            ## attr(coords, "rule") <- NULL
            coords
        }
    }
}

xyListFromCoords.GridGTreeCoords <- function(x, op, closed, rule, ...) {
    if (op == "flatten") {
        childCoords <- lapply(x, xyListFromCoords, op, closed, rule, ...)
        coords <- do.call(c, childCoords)
        attr(coords, "rule") <- NULL
    } else {
        childCoords <- lapply(x, xyListFromCoords, op, closed, rule, ...)
        fillrule <- convertRule(rule)
        coords <- Reduce(function(A, B) {
                             coords <- polyclip::polyclip(A, B, op, closed,
                                                          fillA = fillrule,
                                                          fillB = fillrule,
                                                          ...)
                             if (!length(coords))
                                 emptyXYlist
                             else
                                 coords
                         },
                         childCoords)
        attr(coords, "rule") <- rule
    }
    coords
}

xyListFromGrob <- function(x, op = "union", closed = TRUE, ...) {
    if (getRversion() < "4.2.0") {
        ## grobCoords() result became more complex in R 4.2.0
        grobCoords(x, closed)
    } else {
        coords <- grobCoords(x, closed)
        rule <- attr(coords, "rule")
        xyListFromCoords(coords, op, closed, rule, ...)
    }
}