From 98846937ca757c73799241be0f5a7b0729727e55 Mon Sep 17 00:00:00 2001 From: Paul Murrell Date: Mon, 5 Dec 2022 15:49:48 +1300 Subject: [PATCH] first hack at grid.minkowski() --- NAMESPACE | 16 +++++++- R/minkowski.R | 103 ++++++++++++++++++++++++++++++++++++++++++++++++++ 2 files changed, 117 insertions(+), 2 deletions(-) create mode 100644 R/minkowski.R diff --git a/NAMESPACE b/NAMESPACE index 788ae49..e65a894 100644 --- a/NAMESPACE +++ b/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") diff --git a/R/minkowski.R b/R/minkowski.R new file mode 100644 index 0000000..6400db0 --- /dev/null +++ b/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, ...) +} + + +