first hack at grid.minkowski()

NAMESPACE

@@ -18,16 +18,19 @@ export("xyListPath",
        "trim",
        "polylineoffset",
        "polyoffset",
+       "polyminkowski",
 
        "grid.polyclip",
        "grid.reduce",
        "grid.trim",
        "grid.polyoffset",
        "grid.polylineoffset",
-       "polyclipGrob",
+       "grid.minkowski",
 
+       "polyclipGrob",
        "polylineoffsetGrob",
        "polyoffsetGrob",
+       "minkowskiGrob",
 
        "reduceGrob",
        "trimGrob")
@@ -46,6 +49,7 @@ S3method("makeContent", "reducegrob")
 S3method("makeContent", "trimgrob")
 S3method("makeContent", "polylineoffsetGrob")
 S3method("makeContent", "polyoffsetGrob")
+S3method("makeContent", "minkowskiGrob")
 
 S3method("polyclip", "character")
 S3method("polyclip", "default")
@@ -59,13 +63,17 @@ S3method("polylineoffset", "gPath")
 S3method("polylineoffset", "gList")
 S3method("polylineoffset", "character")
 
-
 S3method("polyoffset", "grob")
 S3method("polyoffset", "list")
 S3method("polyoffset", "gPath")
 S3method("polyoffset", "gList")
 S3method("polyoffset", "character")
 
+S3method("polyminkowski", "default")
+S3method("polyminkowski", "grob")
+S3method("polyminkowski", "gPath")
+S3method("polyminkowski", "gList")
+S3method("polyminkowski", "character")
 
 S3method("grid.polyclip", "character")
 S3method("grid.polyclip", "default")
@@ -85,6 +93,10 @@ S3method("grid.polylineoffset", "gList")
 S3method("grid.polylineoffset", "gPath")
 S3method("grid.polylineoffset", "character")
 
+S3method("grid.minkowski", "default")
+S3method("grid.minkowski", "gPath")
+S3method("grid.minkowski", "character")
+
 S3method("xyListFromCoords", "GridGrobCoords")
 S3method("xyListFromCoords", "GridGTreeCoords")
 

R/minkowski.R

@@ -0,0 +1,103 @@
+
+################################################################################
+## Low level coordinates interface
+## Create S3 generic from polyclip::polyminkowski()
+polyminkowski <- function(A, B, ...) {
+    UseMethod("polyminkowski")
+}
+
+polyminkowski.default <- function(A, B, ...) {
+    polyclip::polyminkowski(A, B, ...)
+}
+
+polyminkowskiGrob <- function(A, B, reduceA, reduceB, ...) {
+    if (inherits(B, "gPath") || is.character(B)) {
+        B <- grid.get(B, ...)
+    }
+    if (!(inherits(B, "grob") || inherits(B, "gList")))
+        stop("Argument 'B' must be a grob")
+    polyA <- xyListFromGrob(A, op = reduceA, closed = TRUE, ...)
+    polyB <- xyListFromGrob(B, op = reduceB, closed = TRUE, ...)
+    polyclip::polyminkowski(polyA, polyB, ...)
+}
+
+polyminkowski.grob <- function(A, B, 
+                               reduceA = "union",
+                               reduceB = "union",
+                               ...) {
+    polyminkowskiGrob(A, B, reduceA, reduceB, ...)
+}
+
+polyminkowski.gList <- function(A, B,
+                                reduceA = "union",
+                                reduceB = "union",
+                                ...) {
+    polyminkowskiGrob(A, B, reduceA, reduceB, ...)
+}
+
+polyminkowski.gPath <- function(A, B, 
+                                strict=FALSE, grep=FALSE, global=FALSE,
+                                reduceA = "union",
+                                reduceB = "union",
+                                ...) {
+    A <- grid.get(A, strict, grep, global)
+    polyminkowskiGrob(A, B, reduceA, reduceB, ...)
+}
+
+polyminkowski.character <- function(A, B,
+                                    strict=FALSE, grep=FALSE, global=FALSE,
+                                    reduceA = "union",
+                                    reduceB = "union",
+                                    ...) {
+    A <- grid.get(A, strict, grep, global)
+    polyminkowskiGrob(A, B, reduceA, reduceB, ...)
+}
+
+################################################################################
+## High level grob interface
+makeContent.minkowskiGrob <- function(x) {
+    offsetpts <- do.call(polyminkowski, c(list(A=x$A, B=x$B), x$minkowskiArgs))
+    setChildren(x, gList(xyListToPath(offsetpts)))
+}
+
+minkowskiGrob <- function(A, B, 
+                          name=NULL, gp=gpar(),
+                          ...) {
+    if (!(grobArg(A) && grobArg(B)))
+        stop("Invalid argument")
+    gTree(A=A, B=B, 
+          polyclipArgs=list(...),
+          gp=gp, name=name, cl="minkowskiGrob")
+}
+
+grid.minkowski <- function(A, B, ...) {
+    UseMethod("grid.minkowski")
+}
+
+grid.minkowski.default <- function(A, B, ...) {
+    grid.draw(minkowskiGrob(A, B, ...))
+}
+
+grid.minkowski.gPath <- function(A, B, ..., name=A$name, gp=NULL,
+                                strict=FALSE, grep=FALSE, global=FALSE) {
+    if (global)
+        stop("Cannot replace multiple grobs with single grob")
+    oldgrob <- grid.get(A, strict=strict, grep=grep)
+    if (is.null(gp)) {
+        gp <- oldgrob$gp
+    } 
+    newgrob <- forceGrob(minkowskiGrob(A, B, ..., name=name, gp=gp,
+                                      strict=strict, grep=grep))
+    if (name != A$name) {
+        grid.draw(newgrob)
+    } else {
+        grid.set(A, newgrob, strict, grep)
+    }
+}
+
+grid.minkowski.character <- function(A, B, ...) {
+    grid.minkowski(gPath(A), B, ...)
+}
+
+
+