Nothing
#
# clipper.R
#
# Interface to Clipper C++ code
#
# $Revision: 1.15 $ $Date: 2018/06/14 02:02:36 $
#
validxy <- function(P) {
is.list(P) && all(c("x","y") %in% names(P)) &&
is.vector(P$x) && is.vector(P$y) && length(P$x)==length(P$y)
}
validpoly <- function(P) {
is.list(P) && all(unlist(lapply(P, validxy)))
}
xrange <- function(z) { range(z$x) }
yrange <- function(z) { range(z$y) }
ensurexydouble <- function(P) lapply(P[c("x", "y")],
"storage.mode<-", value="double")
ensuredouble <- function(A) lapply(A, ensurexydouble)
aspolygonlist <- function(A) lapply(A, "names<-", value=c("x", "y"))
polysimplify <-
function(A,
...,
eps, x0, y0,
filltype=c("evenodd", "nonzero", "positive", "negative")
) {
# validate parameters and convert to integer codes
filltype <- match.arg(filltype)
pft <- match(filltype, c("evenodd", "nonzero", "positive", "negative"))
# validate polygon
if(!validpoly(A)) {
if(validxy(A)) A <- list(A) else
stop("Argument A should be a list of lists, each containing vectors x,y")
}
# determine value of 'eps' if missing
if(missing(eps) || missing(x0) || missing(y0)) {
xr <- range(range(unlist(lapply(A, xrange))))
yr <- range(range(unlist(lapply(A, yrange))))
if(missing(eps)) eps <- max(diff(xr), diff(yr))/1e9
if(missing(x0)) x0 <- mean(xr)
if(missing(y0)) y0 <- mean(yr)
}
# call clipper library on each component path
result <- list()
A <- ensuredouble(A)
storage.mode(pft) <- "integer"
storage.mode(x0) <- storage.mode(y0) <- storage.mode(eps) <- "double"
result <- .Call(eCsimplify,
A, pft, x0, y0, eps,
PACKAGE="polyclip")
return(aspolygonlist(result))
}
polyclip <-
function(A, B,
op=c("intersection", "union", "minus", "xor"),
...,
eps, x0, y0,
fillA=c("evenodd", "nonzero", "positive", "negative"),
fillB=c("evenodd", "nonzero", "positive", "negative"),
closed=TRUE
) {
# validate parameters and convert to integer codes
op <- match.arg(op)
fillA <- match.arg(fillA)
fillB <- match.arg(fillB)
ct <- match(op, c("intersection", "union", "minus", "xor"))
pftA <- match(fillA, c("evenodd", "nonzero", "positive", "negative"))
pftB <- match(fillB, c("evenodd", "nonzero", "positive", "negative"))
# validate polygons and rescale
if(!validpoly(A)) {
if(validxy(A)) A <- list(A) else
stop("Argument A should be a list of lists, each containing vectors x,y")
}
if(!validpoly(B)) {
if(validxy(B)) B <- list(B) else
stop("Argument B should be a list of lists, each containing vectors x,y")
}
#
# determine value of 'eps' if missing
if(missing(eps) || missing(x0) || missing(y0)) {
xr <- range(range(unlist(lapply(A, xrange))),
range(unlist(lapply(B, xrange))))
yr <- range(range(unlist(lapply(A, yrange))),
range(unlist(lapply(B, yrange))))
if(missing(eps)) eps <- max(diff(xr), diff(yr))/1e9
if(missing(x0)) x0 <- mean(xr)
if(missing(y0)) y0 <- mean(yr)
}
# call clipper library
A <- ensuredouble(A)
B <- ensuredouble(B)
storage.mode(ct) <- storage.mode(pftA) <- storage.mode(pftB) <- "integer"
storage.mode(x0) <- storage.mode(y0) <- storage.mode(eps) <- "double"
storage.mode(closed) <- "logical"
ans <- .Call(eCclipbool,
A, B, pftA, pftB, ct,
x0, y0, eps, closed,
PACKAGE="polyclip")
return(aspolygonlist(ans))
}
polyoffset <-
function(A, delta,
...,
eps, x0, y0,
miterlim=2, arctol=abs(delta)/100,
jointype = c("square", "round", "miter")
) {
# validate parameters and convert to integer codes
jointype <- match.arg(jointype)
jt <- match(jointype, c("square", "round", "miter"))
# validate polygons and rescale
if(!validpoly(A)) {
if(validxy(A)) A <- list(A) else
stop("Argument A should be a list of lists, each containing vectors x,y")
}
# determine value of 'eps' if missing
if(missing(eps) || missing(x0) || missing(y0)) {
xr <- range(unlist(lapply(A, xrange)))
yr <- range(unlist(lapply(A, yrange)))
if(missing(eps)) eps <- max(diff(xr), diff(yr))/1e9
if(missing(x0)) x0 <- mean(xr)
if(missing(y0)) y0 <- mean(yr)
}
# arc tolerance
arctol <- max(eps/4, arctol)
# call clipper library
A <- ensuredouble(A)
storage.mode(jt) <- "integer"
storage.mode(delta) <-
storage.mode(miterlim) <- storage.mode(arctol) <- "double"
storage.mode(x0) <- storage.mode(y0) <- storage.mode(eps) <- "double"
ans <- .Call(eCpolyoffset,
A, delta, jt,
miterlim, arctol, x0, y0, eps,
PACKAGE="polyclip")
return(aspolygonlist(ans))
}
polylineoffset <-
function(A, delta,
...,
eps, x0, y0,
miterlim=2, arctol=abs(delta)/100,
jointype = c("square", "round", "miter"),
endtype = c("closedpolygon", "closedline",
"openbutt", "opensquare", "openround",
"closed", "butt", "square", "round")
) {
## validate parameters and convert to integer codes
jointype <- match.arg(jointype)
jt <- match(jointype, c("square", "round", "miter"))
endtype <- match.arg(endtype)
if(endtype == "closed") endtype <- "closedpolygon"
if(endtype %in% c("butt", "square", "round"))
endtype <- paste0("open", endtype)
et <- match(endtype, c("closedpolygon", "closedline",
"openbutt", "opensquare", "openround"))
## validate polygons and rescale
if(!validpoly(A)) {
if(validxy(A)) A <- list(A) else
stop("Argument A should be a list of lists, each containing vectors x,y")
}
## determine value of 'eps' if missing
if(missing(eps) || missing(x0) || missing(y0)) {
xr <- range(unlist(lapply(A, xrange)))
yr <- range(unlist(lapply(A, yrange)))
if(missing(eps)) eps <- max(diff(xr), diff(yr))/1e9
if(missing(x0)) x0 <- mean(xr)
if(missing(y0)) y0 <- mean(yr)
}
# arc tolerance
arctol <- max(eps/4, arctol)
# call clipper library
A <- ensuredouble(A)
storage.mode(jt) <- storage.mode(et) <- "integer"
storage.mode(delta) <- storage.mode(miterlim) <-
storage.mode(arctol) <- "double"
storage.mode(x0) <- storage.mode(y0) <- storage.mode(eps) <- "double"
ans <- .Call(eClineoffset,
A, delta, jt, et,
miterlim, arctol, x0, y0, eps,
PACKAGE="polyclip")
return(aspolygonlist(ans))
}
polyminkowski <-
function(A, B,
...,
eps, x0, y0,
closed=TRUE
) {
# validate parameters and convert to integer codes
closed <- as.logical(closed)
# validate polygons/paths
if(!validpoly(A)) {
if(validxy(A)) A <- list(A) else
stop("Argument A should be a list of lists, each containing vectors x,y")
}
if(length(A) > 1)
stop("Not implemented when A consists of more than one polygon")
if(!validpoly(B)) {
if(validxy(B)) B <- list(B) else
stop("Argument B should be a list of lists, each containing vectors x,y")
}
# determine value of 'eps' if missing
if(missing(eps) || missing(x0) || missing(y0)) {
xr <- range(range(unlist(lapply(A, xrange))))
yr <- range(range(unlist(lapply(A, yrange))))
xr <- range(xr, range(unlist(lapply(B, xrange))))
yr <- range(yr, range(unlist(lapply(B, yrange))))
if(missing(eps)) eps <- max(diff(xr), diff(yr))/1e9
if(missing(x0)) x0 <- xr[1]
if(missing(y0)) y0 <- yr[1] - diff(yr)/16
}
# call clipper library on each component path
A <- ensuredouble(A)
B <- ensuredouble(B)
storage.mode(x0) <- storage.mode(y0) <- storage.mode(eps) <- "double"
storage.mode(closed) <- "logical"
result <- .Call(eCminksum,
A, B, closed, x0, y0, eps,
PACKAGE="polyclip")
return(aspolygonlist(result))
}
pointinpolygon <-
function(P, A, eps, x0, y0) {
# validate arguments
if(!validxy(P))
stop("Argument P should be a list containing vectors x,y")
if(!validxy(A))
stop("Argument A should be a list containing vectors x,y")
# determine value of 'eps' if missing
if(missing(eps) || missing(x0) || missing(y0)) {
xr <- xrange(A)
yr <- yrange(A)
if(missing(eps)) eps <- max(diff(xr), diff(yr))/1e9
if(missing(x0)) x0 <- mean(xr)
if(missing(y0)) y0 <- mean(yr)
}
# call clipper library
A <- ensurexydouble(A)
P <- ensurexydouble(P)
storage.mode(x0) <- storage.mode(y0) <- storage.mode(eps) <- "double"
ans <- .Call(eCpiptest,
P, A,
x0, y0, eps,
PACKAGE="polyclip")
return(ans)
}
Any scripts or data that you put into this service are public.
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.