polyCub/0000755000176200001440000000000015172637442011702 5ustar liggesuserspolyCub/tests/0000755000176200001440000000000014623106010013022 5ustar liggesuserspolyCub/tests/test-polyiso.R0000644000176200001440000000702513752212303015631 0ustar liggesuserslibrary("polyCub") ## function to call an R CMD with environment variables ## 'env' specified as a named character vector Rcmd <- function (args, env = character(), ...) { stopifnot(is.vector(env, mode = "character"), !is.null(names(env))) if (.Platform$OS.type == "windows") { if (length(env)) { ## the 'env' argument of system2() is not supported on Windows setenv <- function (envs) { old <- Sys.getenv(names(envs), unset = NA, names = TRUE) set <- !is.na(envs) if (any(set)) do.call(Sys.setenv, as.list(envs[set])) if (any(!set)) Sys.unsetenv(names(envs)[!set]) invisible(old) } oldenv <- setenv(env) on.exit(setenv(oldenv)) } system2(command = file.path(R.home("bin"), "Rcmd.exe"), args = args, ...) } else { system2(command = file.path(R.home("bin"), "R"), args = c("CMD", args), env = paste(names(env), env, sep = "="), ...) } } ## test compilation with #include for the polyCub_iso C-routine message("compiling polyiso_powerlaw.c using R CMD SHLIB") shlib_error <- Rcmd( args = c("SHLIB", "--clean", "polyiso_powerlaw.c"), env = c("PKG_CPPFLAGS" = paste0( "-I", system.file("include", package="polyCub") ), "R_TESTS" = "") ) if (shlib_error) { warning("failed to build the shared object/DLL for the polyCub_iso example") q("no") } ## load shared object/DLL myDLL <- paste0("polyiso_powerlaw", .Platform$dynlib.ext) loadNamespace("polyCub") dyn.load(myDLL) ## R function calling C_polyiso_powerlaw polyiso_powerlaw <- function (xypoly, logpars, center, subdivisions = 100L, rel.tol = .Machine$double.eps^0.25, abs.tol = rel.tol, stop.on.error = TRUE) { .C("C_polyiso_powerlaw", as.double(xypoly$x), as.double(xypoly$y), as.integer(length(xypoly$x)), as.double(logpars), as.double(center[1L]), as.double(center[2L]), as.integer(subdivisions), as.double(abs.tol), as.double(rel.tol), as.integer(stop.on.error), value = double(1L), abserr = double(1L), neval = integer(1L) )[c("value", "abserr", "neval")] } ## example polygon and function parameters diamond <- list(x = c(1,2,1,0), y = c(1,2,3,2)) logpars <- log(c(0.5, 1)) center <- c(0.5,2.5) # lies on an edge (to cover that case as well) (res <- polyiso_powerlaw(xypoly = diamond, logpars = logpars, center = center)) ## compare with R implementation intrfr.powerlaw <- function (R, logpars) { sigma <- exp(logpars[[1L]]) d <- exp(logpars[[2L]]) if (d == 1) { R - sigma * log(R/sigma + 1) } else if (d == 2) { log(R/sigma + 1) - R/(R+sigma) } else { (R*(R+sigma)^(1-d) - ((R+sigma)^(2-d) - sigma^(2-d))/(2-d)) / (1-d) } } (orig <- polyCub:::polyCub1.iso(poly = diamond, intrfr = intrfr.powerlaw, logpars = logpars, center = center)) stopifnot(all.equal(res$value, orig[1L])) stopifnot(all.equal(res$abserr, orig[2L])) ## microbenchmark::microbenchmark( ## polyCub:::polyCub1.iso(diamond, intrfr.powerlaw, logpars, center=center), ## polyiso_powerlaw(diamond, logpars, center=center), ## times = 1000) ## ## 150 mus vs. 20 mus dyn.unload(myDLL) file.remove(myDLL) polyCub/tests/test-polyCub.R0000644000176200001440000000327614623106010015547 0ustar liggesusersif (!requireNamespace("spatstat.geom")) q("no") library("polyCub") ## bivariate, isotropic Gaussian density f <- function (s, mean, sd) dnorm(s[,1], mean=mean[1], sd=sd) * dnorm(s[,2], mean=mean[2], sd=sd) ## circular domain represented by a polygon r <- 5 center <- c(3,2) npoly <- 128 disc.owin <- spatstat.geom::disc(radius=r, centre=center, npoly=npoly) ## parameters for f m <- c(1,1) sd <- 3 ## target value of the integral over the _polygonal_ circle intExact <- 0.65844436 # taken from exact.Gauss cubature (below) stopIfDiff <- function(int, ...) if(!isTRUE(all.equal.numeric(intExact, int, ..., check.attributes = FALSE))) { if (is.call(cl <- substitute(int))) cl <- cl[1] stop(deparse(cl), " result not equal to reference value") } ## reproduce saved reference value if (identical(Sys.getenv("R_GPCLIBPERMIT"), "true") && local({pkg <- "gpclib"; requireNamespace(pkg)}) && # undeclared ... requireNamespace("mvtnorm")) stopIfDiff(polyCub.exact.Gauss(disc.owin, mean=m, Sigma=sd^2*diag(2)), tolerance = 1e-8) ## exact value of the integral over the _real_ circle stopIfDiff(circleCub.Gauss(center=center, r=r, mean=m, sd=sd), tolerance = 0.001) # agreement depends on 'npoly' ## polyCub.midpoint stopIfDiff(polyCub.midpoint(disc.owin, f, mean=m, sd=sd, dimyx=500), tolerance = 0.001) ## polyCub.SV intC <- polyCub.SV(disc.owin, f, mean=m, sd=sd, nGQ=3, engine="C") intR <- polyCub.SV(disc.owin, f, mean=m, sd=sd, nGQ=3, engine="R") stopifnot(all.equal(intC, intR)) stopIfDiff(intC, tolerance = 0.0001) ## polyCub.iso (using a numerical approximation of intrfr) stopIfDiff(polyCub.iso(disc.owin, f, mean=m, sd=sd, center=m)) polyCub/tests/polyiso_powerlaw.c0000644000176200001440000000344713752212303016621 0ustar liggesusers/******************************************************************************* * Example of using the C-routine "polyCub_iso", see also test-polyiso.R * * Copyright (C) 2015,2017 Sebastian Meyer * * This file is part of the R package "polyCub", * free software under the terms of the GNU General Public License, version 2, * a copy of which is available at https://www.R-project.org/Licenses/. ******************************************************************************/ #include #include // F(R) example static double intrfr_powerlaw(double R, double *logpars) { double sigma = exp(logpars[0]); double d = exp(logpars[1]); if (d == 1.0) { return R - sigma * log(R/sigma + 1); } else if (d == 2.0) { return log(R/sigma + 1) - R/(R+sigma); } else { return (R*pow(R+sigma,1-d) - (pow(R+sigma,2-d) - pow(sigma,2-d))/(2-d)) / (1-d); } } // function to be called from R void C_polyiso_powerlaw( double *x, double *y, // vertex coordinates (open) int *L, // number of vertices //intrfr_fn intrfr, // F(R) double *pars, // parameters for F(R) double *center_x, double *center_y, // center of isotropy int *subdivisions, double *epsabs, double *epsrel, // Rdqags options int *stop_on_error, // !=0 means to stop at first ier > 0 double *value, double *abserr, int *neval) // results { polyCub_iso(x, y, L, intrfr_powerlaw, pars, center_x, center_y, subdivisions, epsabs, epsrel, stop_on_error, value, abserr, neval); return; } polyCub/tests/test-regression.R0000644000176200001440000000114014616435706016321 0ustar liggesuserslibrary("polyCub") ### Regression tests hexagon <- list( list(x = c(7.33, 7.33, 3, -1.33, -1.33, 3), y = c(-0.5, 4.5, 7, 4.5, -0.5, -3)) ) f <- function (s) (rowSums(s^2)+1)^-2 ##plotpolyf(hexagon, f) ## isotropic cubature can handle control list for integrate() ## previously, passing control arguments did not work int1 <- polyCub.iso(hexagon, f, center=c(0,0), control=list(rel.tol=1e-3)) int2 <- polyCub.iso(hexagon, f, center=c(0,0), control=list(rel.tol=1e-8)) ## results are almost but not identical stopifnot(all.equal(int1, int2, tolerance = 1e-3), !identical(int1, int2)) polyCub/tests/test-NWGL.R0000644000176200001440000000160114004036556014701 0ustar liggesusersif (!requireNamespace("statmod")) q("no") library("polyCub") ## statmod::gauss.quad() gives cached Gauss-Legendre nodes/weights new.NWGL <- lapply( X = seq_len(61L), FUN = function (n) unname(statmod::gauss.quad(n = n, kind = "legendre")) ) stopifnot(all.equal(new.NWGL, polyCub:::.NWGL, check.attributes = FALSE)) ## polyCub.SV() can fetch nodes and weights from 'statmod' diamond <- list(list(x = c(1,2,1,0), y = c(1,2,3,2))) nw <- polyCub.SV(diamond, f = NULL, nGQ = 83) # nGQ > 61 stopifnot(is.list(nw)) ## polyCub.SV() can reduce nodes with zero weight rectangle <- list(list(x = c(-1,1,1,-1), y = c(1,1,2,2))) ##nw0 <- polyCub.SV(rectangle, f = NULL, nGQ = 3, engine = "C")[[1]] # 0s nw <- polyCub.SV(rectangle, f = NULL, nGQ = 3, engine = "C+reduce")[[1]] stopifnot(nw$weights != 0) ##f <- function (s) 1 # => calculate area (= 2) stopifnot(all.equal(sum(nw$weights), 2)) polyCub/MD50000644000176200001440000000512515172637442012215 0ustar liggesusersb8c218b110d4f511eab83b4ccdfa0e7f *DESCRIPTION ff103edaa2d5b22b4cfa416b7cff042c *NAMESPACE 68448574984b487699338578c986d986 *NEWS.md 04d9239e0d18a1de5c5ff0c22af44051 *R/circleCub.R 67d2618e4be025c0e90dce4d9c08453d *R/coerce-gpc-methods.R b634920707b46eb3e253020d5583ced3 *R/coerce-sp-methods.R 1b88fced2e86e9ed735c354ba2339b3f *R/plotpolyf.R 66ed1e08a73e014da557278a5eb0fc9d *R/polyCub.R c5e88af8127fbdbd09fbb168641297be *R/polyCub.SV.R 819e91400e7ec7439a1ce99b282d9285 *R/polyCub.exact.Gauss.R c3597495a42e75557e04048f85e17c9e *R/polyCub.iso.R 0f202f3e25b9d8ea5573f7d03bcd64c3 *R/polyCub.midpoint.R ac1add18746048ac8dc8cc5d3b5f7199 *R/sfg2gpc.R 75a1bb73253360d3ffdbb005b55f083f *R/sysdata.rda bb1b79ac93b885ce302ae408f95c9ec0 *R/tools.R e28efc764a23b9fd4ea93d3b13b0b77b *R/xylist.R 416aea114f73033efce2db84891251a6 *R/zzz.R 23e8ddc552422b0804014ace7f6f582d *README.md a54a9efb83f3215bdf2d944083265d01 *build/partial.rdb 244975ba269a3bfe71387348e6b86bed *build/vignette.rds eaca78d346f9c78d5bc6cd3841fa1a65 *inst/CITATION 9dd077a99669fb5870a7caf80e610c09 *inst/REFERENCES.R e070ad0b191812f4d0640a7e01d7eeaf *inst/doc/polyCub.R 9d190da8f4b3b717b544f50357de0d9e *inst/doc/polyCub.Rmd bc4c61b9308d06e57a7139dd25d12f91 *inst/doc/polyCub.html af7c7fdb25a9f3fc0db625dbc9f26307 *inst/include/polyCubAPI.h 17c4786cb83e1f655b9bc6e2e783620f *man/checkintrfr.Rd a7fcbcfca7392f100bd19a860ba52100 *man/circleCub.Gauss.Rd 9ad7baff79ee2c50c3057953c0444ade *man/coerce-gpc-methods.Rd d4da7579b0bd4dda09d652e52c3a7f12 *man/coerce-sp-methods.Rd cf49b62c6d4f953ca6284afd31382b33 *man/figures/logo.png af60322693dc78e067f10a3c39b30cc7 *man/plotpolyf.Rd de4e3c964bcc155b6ccf62e8e1427bae *man/polyCub-package.Rd 4ec7f978eac2c54336cd958516a88ce2 *man/polyCub.Rd 9271ebb2d3226b990343180d02ed9c14 *man/polyCub.SV.Rd 5040c1ff205983ba5eedf6d61daec3ff *man/polyCub.exact.Gauss.Rd 93927bbdbd69bd7b96baf8a61c186a6c *man/polyCub.iso.Rd dd5be802a2e98d9da2f7db7150d6df0b *man/polyCub.midpoint.Rd 73a4fe9c861c1c83d162aba6cb22d7d0 *man/sfg2gpc.Rd 525e60dffab091281ade1888476ce376 *man/xylist.Rd 8ab51266adc6ede5ffb503ad17fb360a *src/init.c bd2782f92e09d64dbea9e87f10b66f97 *src/polyCub.SV.c ce25a1a76b4cf52a0f34a1352640227d *src/polyCub.SV.h 2ef3ee5c813c5281bec75b33eb6cb589 *src/polyCub.iso.c c16fcda4cc1fa1bf7c4e7cb9b97294d3 *src/polyCub.iso.h 673cd0874ece8c19399eaf853af0457a *tests/polyiso_powerlaw.c 52d11d0bd2e3ff11dd8f191149301155 *tests/test-NWGL.R 59ebd383df0d1903d4aac7d8822521d2 *tests/test-polyCub.R 3853b06528ec88affd87fea8680ebef9 *tests/test-polyiso.R c992359d495fcdc0f7fca50a150d31cd *tests/test-regression.R 9d190da8f4b3b717b544f50357de0d9e *vignettes/polyCub.Rmd polyCub/R/0000755000176200001440000000000015172466713012104 5ustar liggesuserspolyCub/R/polyCub.SV.R0000644000176200001440000003377415172341742014203 0ustar liggesusers################################################################################ ### polyCub.SV: Product Gauss Cubature over Polygonal Domains ### ### Copyright (C) 2009-2014,2017-2018 Sebastian Meyer ### ### This file is part of the R package "polyCub", ### free software under the terms of the GNU General Public License, version 2, ### a copy of which is available at https://www.R-project.org/Licenses/. ################################################################################ #' Product Gauss Cubature over Polygonal Domains #' #' Product Gauss cubature over polygons as proposed by #' \bibcitet{sommariva.vianello2007}. #' #' @inheritParams plotpolyf #' @param f a two-dimensional real-valued function to be integrated over #' \code{polyregion} (or \code{NULL} to only compute nodes and weights). #' As its first argument it must take a coordinate matrix, i.e., a #' numeric matrix with two columns, and it must return a numeric vector of #' length the number of coordinates. #' @param nGQ degree of the one-dimensional Gauss-Legendre quadrature rule #' (default: 20) as implemented in function \code{\link[statmod]{gauss.quad}} #' of package \CRANpkg{statmod}. Nodes and weights up to \code{nGQ=60} are cached #' in \pkg{polyCub}, for larger degrees \pkg{statmod} is required. #' @param alpha base-line of the (rotated) polygon at \eqn{x = \alpha} #' \bibcitep{see|sommariva.vianello2007|for an explication}. #' If \code{NULL} (default), #' the midpoint of the x-range of each polygon is chosen if no \code{rotation} #' is performed, and otherwise the \eqn{x}-coordinate of the rotated point #' \code{"P"} (see \code{rotation}). If \code{f} has its maximum value at the #' origin \eqn{(0,0)}, e.g., the bivariate Gaussian density with zero mean, #' \code{alpha = 0} is a reasonable choice. #' @param rotation logical (default: \code{FALSE}) or a list of points #' \code{"P"} and \code{"Q"} describing the preferred direction. If #' \code{TRUE}, the polygon is rotated according to the vertices \code{"P"} and #' \code{"Q"}, which are farthest apart \bibcitep{see|sommariva.vianello2007|}. #' For convex polygons, this rotation guarantees that all nodes fall inside the #' polygon. #' @param engine character string specifying the implementation to use. #' Up to \pkg{polyCub} version 0.4-3, the two-dimensional nodes and weights #' were computed by \R functions and these are still available by setting #' \code{engine = "R"}. #' The new C-implementation is now the default (\code{engine = "C"}) and #' requires approximately 30\% less computation time.\cr #' The special setting \code{engine = "C+reduce"} will discard redundant nodes #' at (0,0) with zero weight resulting from edges on the base-line #' \eqn{x = \alpha} or orthogonal to it. #' This extra cleaning is only worth its cost for computationally intensive #' functions \code{f} over polygons which really have some edges on the #' baseline or parallel to the x-axis. Note that the old \R #' implementation does not have such unset zero nodes and weights. #' @param plot logical indicating if an illustrative plot of the numerical #' integration should be produced. #' @return The approximated value of the integral of \code{f} over #' \code{polyregion}.\cr #' In the case \code{f = NULL}, only the computed nodes and weights are #' returned in a list of length the number of polygons of \code{polyregion}, #' where each component is a list with \code{nodes} (a numeric matrix with #' two columns), \code{weights} (a numeric vector of length #' \code{nrow(nodes)}), the rotation \code{angle}, and \code{alpha}. #' @author Sebastian Meyer #' % NOTE: roxygen2 outputs author \emph{after} references in the Rd file, see #' % \code{roxygen2:::RoxyTopic$public_methods$format}, so do not \bibcite here #' @references #' \bibinfo{sommariva.vianello2007}{footer}{ #' Their MATLAB implementation \samp{polygauss}, on which this #' R implementation was based, is available (in revised versions) at #' \url{https://sites.google.com/view/alvisesommarivaunipd/home-page/software/software_matlab} #' under the GNU GPL (>=2) license.} #' \bibshow{*} #' @keywords math spatial #' @family cubature methods #' @importFrom graphics points #' @example examples/setting.R #' @example examples/polyCub.SV.R #' @export polyCub.SV <- function (polyregion, f, ..., nGQ = 20, alpha = NULL, rotation = FALSE, engine = "C", plot = FALSE) { polys <- xylist(polyregion) # transform to something like "owin$bdry" # which means anticlockwise vertex order with # first vertex not repeated stopifnot(isScalar(nGQ), nGQ > 0, is.null(alpha) || (isScalar(alpha) && !is.na(alpha))) ## COMPUTE NODES AND WEIGHTS OF 1D GAUSS QUADRATURE RULE. ## DEGREE "N" (as requested) (ORDER GAUSS PRIMITIVE) nw_N <- gauss.quad(nGQ) ## DEGREE "M" = N+1 (ORDER GAUSS INTEGRATION) nw_M <- gauss.quad(nGQ + 1) ## Special case f=NULL: compute and return nodes and weights only if (is.null(f)) { return(lapply(X = polys, FUN = polygauss, nw_MN = c(nw_M, nw_N), alpha = alpha, rotation = rotation, engine = engine)) } ## Cubature over every single polygon of the "polys" list f <- match.fun(f) int1 <- function (poly) { nw <- polygauss(poly, c(nw_M, nw_N), alpha, rotation, engine) fvals <- f(nw$nodes, ...) cubature_val <- sum(nw$weights * fvals) ## if (!isTRUE(all.equal(0, cubature_val))) { ## if ((1 - 2 * as.numeric(poly$hole)) * sign(cubature_val) == -1) ## warning("wrong sign if positive integral") ## } cubature_val } respolys <- vapply(X=polys, FUN=int1, FUN.VALUE=0, USE.NAMES=FALSE) int <- sum(respolys) ### ILLUSTRATION ### if (plot) { plotpolyf(polys, f, ..., use.lattice=FALSE) for (i in seq_along(polys)) { nw <- polygauss(polys[[i]], c(nw_M, nw_N), alpha, rotation, engine) points(nw$nodes, cex=0.6, pch = i) #, col=1+(nw$weights<=0) } } ################### int } ## this wrapper provides a partially memoized version of ## unname(statmod::gauss.quad(n, kind="legendre")) gauss.quad <- function (n) { if (n <= 61) { # results cached in R/sysdata.rda .NWGL[[n]] } else if (requireNamespace("statmod")) { unname(statmod::gauss.quad(n = n, kind = "legendre")) } else { stop("package ", sQuote("statmod"), " is required for nGQ > 60") } } #' Calculate 2D Nodes and Weights of the Product Gauss Cubature #' #' @param xy list with elements \code{"x"} and \code{"y"} containing the #' polygon vertices in \emph{anticlockwise} order (otherwise the result of the #' cubature will have a negative sign) with first vertex not repeated at the #' end (like \code{owin.object$bdry}). #' @param nw_MN unnamed list of nodes and weights of one-dimensional Gauss #' quadrature rules of degrees \eqn{N} and \eqn{M=N+1} (as returned by #' \code{\link[statmod]{gauss.quad}}): \code{list(s_M, w_M, s_N, w_N)}. #' @inherit polyCub.SV params references #' @keywords math internal #' @useDynLib polyCub, .registration = TRUE #' @noRd polygauss <- function (xy, nw_MN, alpha = NULL, rotation = FALSE, engine = "C") { ## POLYGON ROTATION xyrot <- if (identical(FALSE, rotation)) { if (is.null(alpha)) { # choose midpoint of x-range xrange <- range(xy[["x"]]) alpha <- (xrange[1L] + xrange[2L]) / 2 } angle <- 0 xy[c("x", "y")] } else { ## convert to coordinate matrix xy <- cbind(xy[["x"]], xy[["y"]], deparse.level=0) ## determine P and Q if (identical(TRUE, rotation)) { # automatic choice of rotation angle ## such that for a convex polygon all nodes fall inside the polygon QP <- vertexpairmaxdist(xy) Q <- QP[1L,,drop=TRUE] P <- QP[2L,,drop=TRUE] } else if (is.list(rotation)) { # predefined rotation P <- rotation$P Q <- rotation$Q stopifnot(is.vector(P, mode="numeric") && length(P) == 2L, is.vector(Q, mode="numeric") && length(Q) == 2L) stopifnot(any(P != Q)) rotation <- TRUE } else { stop("'rotation' must be logical or a list of points ", "\"P\" and \"Q\"") } rotmat <- rotmatPQ(P,Q) angle <- attr(rotmat, "angle") if (is.null(alpha)) { Prot <- rotmat %*% P alpha <- Prot[1] } xyrot <- xy %*% t(rotmat) # = t(rotmat %*% t(xy)) ## convert back to list list(x = xyrot[,1L,drop=TRUE], y = xyrot[,2L,drop=TRUE]) } ## number of vertices L <- length(xyrot[[1L]]) ## COMPUTE 2D NODES AND WEIGHTS. if (engine == "R") { toIdx <- c(seq.int(2, L), 1L) nwlist <- mapply(.polygauss.side, xyrot[[1L]], xyrot[[2L]], xyrot[[1L]][toIdx], xyrot[[2L]][toIdx], MoreArgs = c(nw_MN, alpha), SIMPLIFY = FALSE, USE.NAMES = FALSE) nodes <- c(lapply(nwlist, "[[", 1L), lapply(nwlist, "[[", 2L), recursive=TRUE) dim(nodes) <- c(length(nodes)/2, 2L) weights <- unlist(lapply(nwlist, "[[", 3L), recursive=FALSE, use.names=FALSE) } else { # use C-implementation ## degrees of cubature and vector template for results M <- length(nw_MN[[1L]]) N <- length(nw_MN[[3L]]) zerovec <- double(L*M*N) ## rock'n'roll nwlist <- .C(C_polygauss, as.double(xyrot[[1L]]), as.double(xyrot[[2L]]), as.double(nw_MN[[1L]]), as.double(nw_MN[[2L]]), as.double(nw_MN[[3L]]), as.double(nw_MN[[4L]]), as.double(alpha), as.integer(L), as.integer(M), as.integer(N), x = zerovec, y = zerovec, w = zerovec)[c("x", "y", "w")] nodes <- cbind(nwlist[[1L]], nwlist[[2L]], deparse.level=0) weights <- nwlist[[3L]] ## remove unset nodes from edges on baseline or orthogonal to it ## (note that the R implementation does not return such redundant nodes) if (engine == "C+reduce" && any(unset <- weights == 0)) { nodes <- nodes[!unset,] weights <- weights[!unset] } } ## back-transform rotated nodes by t(t(rotmat) %*% t(nodes)) ## (inverse of rotation matrix is its transpose) list(nodes = if (rotation) nodes %*% rotmat else nodes, weights = weights, angle = angle, alpha = alpha) } ## The working horse .polygauss.side below is an R translation ## of the original MATLAB implementation by Sommariva and Vianello (2007). .polygauss.side <- function (x1, y1, x2, y2, s_loc, w_loc, s_N, w_N, alpha) { if ((x1 == alpha && x2 == alpha) || (y2 == y1)) ## side lies on base-line or is orthogonal to it -> skip return(NULL) if (x2 == x1) { # side is parallel to base-line => degree N s_loc <- s_N w_loc <- w_N } half_pt_x <- (x1+x2)/2 half_length_x <- (x2-x1)/2 half_pt_y <- (y1+y2)/2 half_length_y <- (y2-y1)/2 ## GAUSSIAN POINTS ON THE SIDE. x_gauss_side <- half_pt_x + half_length_x * s_loc y_gauss_side <- half_pt_y + half_length_y * s_loc scaling_fact_minus <- (x_gauss_side - alpha) / 2 ## construct nodes and weights: x and y coordinates ARE STORED IN MATRICES. ## A COUPLE WITH THE SAME INDEX IS A POINT, i.e. P_i=(x(k),y(k)). ## Return in an unnamed list of nodes_x, nodes_y, weights ## (there is no need for c(nodes_x) and c(weights)) list( alpha + tcrossprod(scaling_fact_minus, s_N + 1), # degree_loc x N rep.int(y_gauss_side, length(s_N)), # length: degree_loc*N tcrossprod(half_length_y*scaling_fact_minus*w_loc, w_N) # degree_loc x N ) } ## NOTE: The above .polygauss.side() function is already efficient R code. ## Passing via C only at this deep level (see below) turned out to be ## slower than staying with R! However, stepping into C already for ## looping over the edges in polygauss() improves the speed. ## ## @useDynLib polyCub C_polygauss_side ## .polygauss.side <- function (x1, y1, x2, y2, s_M, w_M, s_N, w_N, alpha) ## { ## if ((x1 == alpha && x2 == alpha) || (y2 == y1)) ## ## side lies on base-line or is orthogonal to it -> skip ## return(NULL) ## ## parallel2baseline <- x2 == x1 # side is parallel to base-line => degree N ## M <- length(s_M) ## N <- length(s_N) ## loc <- if (parallel2baseline) N else M ## zerovec <- double(loc * N) ## .C(C_polygauss_side, ## as.double(x1), as.double(y1), as.double(x2), as.double(y2), ## as.double(if (parallel2baseline) s_N else s_M), ## as.double(if (parallel2baseline) w_N else w_M), ## as.double(s_N), as.double(w_N), as.double(alpha), ## as.integer(loc), as.integer(N), ## x = zerovec, y = zerovec, w = zerovec)[c("x", "y", "w")] ## } #' @importFrom stats dist vertexpairmaxdist <- function (xy) { ## compute euclidean distance matrix distances <- dist(xy) size <- attr(distances, "Size") ## select two points with maximum distance maxdistidx <- which.max(distances) lowertri <- seq_along(distances) == maxdistidx mat <- matrix(FALSE, size, size) mat[lower.tri(mat)] <- lowertri QPidx <- which(mat, arr.ind=TRUE, useNames=FALSE)[1L,] xy[QPidx,] } rotmatPQ <- function (P, Q) { direction_axis <- (Q-P) / vecnorm(Q-P) ## determine rotation angle [radian] rot_angle_x <- acos(direction_axis[1L]) rot_angle_y <- acos(direction_axis[2L]) rot_angle <- if (rot_angle_y <= pi/2) { if (rot_angle_x <= pi/2) -rot_angle_y else rot_angle_y } else { if (rot_angle_x <= pi/2) pi-rot_angle_y else rot_angle_y } ## rotation matrix rot_matrix <- diag(cos(rot_angle), nrow=2L) rot_matrix[2:3] <- c(-1,1) * sin(rot_angle) # clockwise rotation structure(rot_matrix, angle=rot_angle) } polyCub/R/circleCub.R0000644000176200001440000000445715167766605014143 0ustar liggesusers################################################################################ ### Integration of the Isotropic Gaussian Density over Circular Domains ### ### Copyright (C) 2013-2014,2026 Sebastian Meyer ### ### This file is part of the R package "polyCub", ### free software under the terms of the GNU General Public License, version 2, ### a copy of which is available at https://www.R-project.org/Licenses/. ################################################################################ #' Integration of the Isotropic Gaussian Density over Circular Domains #' #' This function calculates the integral of the bivariate, isotropic Gaussian #' density (i.e., \eqn{\Sigma} = \code{sd^2*diag(2)}) over a circular domain #' via the cumulative distribution function \code{pchisq} of the (non-central) #' Chi-Squared distribution \bibcitep{|R:Abramowitz+Stegun:1972|Formula 26.3.24}. #' #' @references \bibshow{*} #' @param center numeric vector of length 2 (center of the circle). #' @param r numeric (radius of the circle). Several radii may be supplied. #' @param mean numeric vector of length 2 #' (mean of the bivariate Gaussian density). #' @param sd numeric (common standard deviation of the isotropic #' Gaussian density in both dimensions). #' @return The integral value (one for each supplied radius). #' @note The non-centrality parameter of the evaluated chi-squared distribution #' equals the squared distance between the \code{mean} and the #' \code{center}. If this becomes too large, the result becomes inaccurate, see #' \code{\link{pchisq}}. #' @keywords math spatial #' @importFrom stats pchisq #' @export #' @examples #' circleCub.Gauss(center=c(1,2), r=3, mean=c(4,5), sd=6) #' #' ## compare with cubature over a polygonal approximation of a circle #' d2norm <- function (s, mean, sd) #' dnorm(s[,1], mean=mean[1], sd=sd) * dnorm(s[,2], mean=mean[2], sd=sd) #' if (requireNamespace("spatstat.geom")) { # for the disc() #' npoly <- 32 # increase this for a closer match #' disc.poly <- spatstat.geom::disc(radius=3, centre=c(1,2), npoly=npoly) #' polyCub.iso(disc.poly, d2norm, mean=c(4,5), sd=6, center=c(4,5)) #' } circleCub.Gauss <- function (center, r, mean, sd) { stopifnot(isScalar(sd), length(center) == 2, length(mean) == 2) pchisq((r/sd)^2, df=2, ncp=sum(((center-mean)/sd)^2)) } polyCub/R/polyCub.R0000644000176200001440000000452715172341742013646 0ustar liggesusers################################################################################ ### polyCub: Wrapper Function for the Various Cubature Methods ### ### Copyright (C) 2009-2013,2019 Sebastian Meyer ### ### This file is part of the R package "polyCub", ### free software under the terms of the GNU General Public License, version 2, ### a copy of which is available at https://www.R-project.org/Licenses/. ################################################################################ #' Wrapper Function for the Various Cubature Methods #' #' The wrapper function \code{polyCub} can be used to call specific cubature #' methods via its \code{method} argument. It calls the \code{\link{polyCub.SV}} #' function by default, which implements general-purpose product Gauss cubature. #' The desired cubature function should usually be called directly. #' #' @inheritParams plotpolyf #' @param f a two-dimensional real-valued function to be integrated over #' \code{polyregion}. As its first argument it must take a coordinate matrix, #' i.e., a numeric matrix with two columns, and it must return a numeric vector #' of length the number of coordinates.\cr #' For the \code{"exact.Gauss"} \code{method}, #' \code{f} is ignored since it is specific to the bivariate normal density. #' @param method choose one of the implemented cubature methods (partial #' argument matching is applied), see \code{help("\link{polyCub-package}")} #' for an overview. Defaults to using product Gauss cubature #' implemented in \code{\link{polyCub.SV}}. #' @param ... arguments of \code{f} or of the specific \code{method}. #' @param plot logical indicating if an illustrative plot of the numerical #' integration should be produced. #' @return The approximated integral of \code{f} over \code{polyregion}. #' @seealso Details and examples in the \code{vignette("polyCub")} #' and on the method-specific help pages. #' @family cubature methods #' @keywords math spatial #' @export polyCub <- function (polyregion, f, method = c("SV", "midpoint", "iso", "exact.Gauss"), ..., plot = FALSE) { method <- match.arg(method) cl <- match.call() cl$method <- NULL cl[[1]] <- call("::", as.name("polyCub"), as.name(paste("polyCub", method, sep="."))) if (method == "exact.Gauss") cl$f <- NULL int <- eval(cl, parent.frame()) int } polyCub/R/sfg2gpc.R0000644000176200001440000000606014516025551013554 0ustar liggesusers################################################################################ ### Convert polygonal "sfg" to "gpc.poly" (for polyCub.exact.Gauss) ### ### Copyright (C) 2021 Sebastian Meyer ### ### This file is part of the R package "polyCub", ### free software under the terms of the GNU General Public License, version 2, ### a copy of which is available at https://www.R-project.org/Licenses/. ################################################################################ #' Convert polygonal \code{"sfg"} to \code{"gpc.poly"} #' #' Package \pkg{polyCub} implements a converter from class #' \code{"\link[sf:st_polygon]{(MULTI)POLYGON}"} of package \CRANpkg{sf} #' to \code{"gpc.poly"} of package \CRANpkg{gpclib} #' such that \code{\link{polyCub.exact.Gauss}} #' can be used with simple feature polygons. #' #' @param object a \code{"POLYGON"} or \code{"MULTIPOLYGON"} \code{"sfg"} object. #' @return The converted polygon of class \code{"gpc.poly"}. #' If package \pkg{gpclib} is not available, #' \code{sfg2gpc} will just return the \code{pts} slot of the #' \code{"gpc.poly"} (no formal class) with a warning. #' @author Sebastian Meyer #' @note Package \pkg{gpclib} is required for the formal class #' definition of a \code{"gpc.poly"}. #' @seealso \code{\link{xylist}} #' @keywords spatial methods #' @import methods #' @export #' @examplesIf requireNamespace("sf") #' ## use example polygons from #' example(plotpolyf, ask = FALSE) #' letterR # a simple "xylist" #' #' letterR.sfg <- sf::st_polygon(lapply(letterR, function(xy) #' rbind(cbind(xy$x, xy$y), c(xy$x[1], xy$y[1])))) #' letterR.sfg #' stopifnot(identical(letterR, xylist(letterR.sfg))) #' \dontshow{ #' stopifnot(identical(rep(letterR, 2), #' xylist(sf::st_multipolygon(list(letterR.sfg, letterR.sfg))))) #' } #' ## convert sf "POLYGON" to a "gpc.poly" #' letterR.gpc_from_sfg <- sfg2gpc(letterR.sfg) #' letterR.gpc_from_sfg #' \dontshow{ #' if (is(letterR.gpc_from_sfg, "gpc.poly") && requireNamespace("spatstat.geom")) { #' letterR.xylist_from_gpc <- xylist(letterR.gpc_from_sfg) # with hole info #' stopifnot(identical(letterR, lapply(letterR.xylist_from_gpc, `[`, 1:2))) #' }} sfg2gpc <- function (object) { assert_polygonal_sfg(object) ## determine hole flags of the individual polygons if (inherits(object, "MULTIPOLYGON")) { hole <- unlist(lapply(object, seq_along)) > 1L object <- unlist(object, recursive = FALSE) } else { hole <- seq_along(object) > 1L } pts <- mapply( FUN = function (coords, hole) { idx <- seq_len(nrow(coords) - 1L) list(x = coords[idx, 1L], y = coords[idx, 2L], hole = hole) }, coords = object, hole = hole, SIMPLIFY = FALSE, USE.NAMES = FALSE) if (know_gpc.poly()) { new("gpc.poly", pts = pts) } else { warning("formal class \"gpc.poly\" not available") pts } } assert_polygonal_sfg <- function (object) { if (!inherits(object, c("POLYGON", "MULTIPOLYGON"))) stop("only *polygonal* SF geometries are supported") invisible(object) } polyCub/R/polyCub.midpoint.R0000644000176200001440000000641215172341742015463 0ustar liggesusers################################################################################ ### polyCub.midpoint: Two-Dimensional Midpoint Rule ### ### Copyright (C) 2009-2015,2017,2021 Sebastian Meyer ### ### This file is part of the R package "polyCub", ### free software under the terms of the GNU General Public License, version 2, ### a copy of which is available at https://www.R-project.org/Licenses/. ################################################################################ #' Two-Dimensional Midpoint Rule #' #' The surface is converted to a binary pixel image #' using the \code{\link[spatstat.geom]{as.im.function}} method from package #' \CRANpkg{spatstat.geom}. #' The integral under the surface is then approximated as the #' sum over (pixel area * f(pixel midpoint)). #' #' @inheritParams plotpolyf #' @param polyregion a polygonal integration domain. #' It can be any object coercible to the \pkg{spatstat.geom} class #' \code{"\link[spatstat.geom]{owin}"} via a corresponding #' \code{\link[spatstat.geom]{as.owin}}-method. #' Note that this includes polygons of the classes \code{"gpc.poly"} and #' \code{"\link[sp:SpatialPolygons-class]{SpatialPolygons}"}, because #' \pkg{polyCub} defines methods \code{\link{as.owin.gpc.poly}} and #' \code{\link{as.owin.SpatialPolygons}}, respectively. #' \pkg{sf} also registers suitable \code{as.owin} methods for its #' \code{"\link[sf:st_polygon]{(MULTI)POLYGON}"} classes. #' @param eps width and height of the pixels (squares), #' see \code{\link[spatstat.geom]{as.mask}}. #' @param dimyx number of subdivisions in each dimension, #' see \code{\link[spatstat.geom]{as.mask}}. #' @param plot logical indicating if an illustrative plot of the numerical #' integration should be produced. #' @return The approximated value of the integral of \code{f} over #' \code{polyregion}. #' @keywords math spatial #' @family cubature methods #' @importFrom sp plot #' @importFrom grDevices gray #' @example examples/setting.R #' @example examples/polyCub.midpoint.R #' @export polyCub.midpoint <- function (polyregion, f, ..., eps = NULL, dimyx = NULL, plot = FALSE) { ## as.im needs separate x and y arguments fxy <- function (x, y, ...) f(cbind(x,y), ...) ## calculate pixel values of fxy IM <- tryCatch( spatstat.geom::as.im.function(X = fxy, W = polyregion, ..., eps = eps, dimyx = dimyx), error = function (e) { ## if eps was to small such that the dimensions of the image would ## be too big then the operation matrix(TRUE, nr, nc) throws an ## error. (try e.g. devnull <- matrix(TRUE, 1e6,1e6)) ## unfortunately, it is not clear what we should do in this case ... stop("inapplicable choice of bandwidth (eps=", format(eps), ") in midpoint rule:\n", e) }) ### ILLUSTRATION ### if (plot) { spatstat.geom::plot.im(IM, axes=TRUE, col=gray(31:4/35), main="") ## add evaluation points #with(IM, points(expand.grid(xcol, yrow), col=!is.na(v), cex=0.5)) plot(polyregion, add=TRUE, poly.args=list(lwd=2), lwd=2) ##<- two 'lwd'-specifications such that it works with owin and gpc.poly } #################### ## return the approximated integral spatstat.geom::integral.im(IM) } polyCub/R/zzz.R0000644000176200001440000000437615167151664013076 0ustar liggesusers################################################################################ ### Package Setup ### ### Copyright (C) 2009-2014,2018-2021,2023,2026 Sebastian Meyer ### ### This file is part of the R package "polyCub", ### free software under the terms of the GNU General Public License, version 2, ### a copy of which is available at https://www.R-project.org/Licenses/. ################################################################################ #' Cubature over Polygonal Domains #' #' The \R package \pkg{polyCub} implements #' \emph{cubature} (numerical integration) over \emph{polygonal} domains. #' It solves the problem of integrating a continuously differentiable #' function \eqn{f(x,y)} over simple closed polygons. #' #' \pkg{polyCub} provides the following cubature methods: #' \describe{ #' \item{\code{\link{polyCub.SV}}:}{ #' General-purpose \emph{product Gauss cubature} #' \bibcitep{sommariva.vianello2007} #' } #' \item{\code{\link{polyCub.midpoint}}:}{ #' Simple \emph{two-dimensional midpoint rule} based on #' \code{\link[spatstat.geom]{as.im.function}} from \CRANpkg{spatstat.geom} #' \bibcitep{R:spatstat.geom} #' } #' \item{\code{\link{polyCub.iso}}:}{ #' Adaptive cubature for \emph{radially symmetric functions} #' via line \code{\link{integrate}()} along the polygon boundary #' \bibcitep{|meyer.held2014|Supplement B, Section 2.4} #' } #' } #' A brief description and benchmark experiment of the above cubature #' methods can be found in the \code{vignette("polyCub")}. #' #' There is also \code{\link{polyCub.exact.Gauss}}, intended to #' accurately (but slowly) integrate the \emph{bivariate Gaussian density}; #' however, this implementation is disabled as of \pkg{polyCub} 0.9.0: #' it needs a reliable implementation of polygon triangulation. #' #' \bibcitet{|meyer2010|Section 3.2} #' discusses and compares some of these methods. #' #' @note To cite package \pkg{polyCub} in publications, #' please use \code{citation("polyCub")}: #' #' \Sexpr[results=rd,stage=build]{tools::toRd(citation("polyCub"))} #' #' @author Sebastian Meyer #' @references \bibshow{*} #' @seealso #' \code{vignette("polyCub")} #' #' For the special case of a rectangular domain along the axes #' (e.g., a bounding box), the \CRANpkg{cubature} package is more appropriate. "_PACKAGE" polyCub/R/tools.R0000644000176200001440000000355515166164717013401 0ustar liggesusers################################################################################ ### Internal Functions ### ### Copyright (C) 2009-2015,2017,2021,2026 Sebastian Meyer ### ### This file is part of the R package "polyCub", ### free software under the terms of the GNU General Public License, version 2, ### a copy of which is available at https://www.R-project.org/Licenses/. ################################################################################ ## Check if a Polygon is Closed ## (first and last row of coordinate matrix are identical) #' @importFrom grDevices xy.coords isClosed <- function (coords) { xycoords <- xy.coords(coords)[c("x","y")] n <- length(xycoords$x) return(identical(xycoords$x[1], xycoords$x[n]) && identical(xycoords$y[1], xycoords$y[n])) } ## Dot/Scalar Product of Two Vectors dotprod <- function (x,y) sum(x*y) ## Euclidean Vector Norm (Length) vecnorm <- function (x) sqrt(sum(x^2)) ## Check if an R object is scalar (a numeric vector of length 1) isScalar <- function (x) { length(x) == 1L && is.vector(x, mode = "numeric") } ## Plot a Polygonal Domain (of Various Classes) #' @importMethodsFrom sp plot plot_polyregion <- function (polyregion, lwd=2, add=FALSE) { if (is.vector(polyregion, mode="list")) { # internal xylist object stopifnot(add) lapply(polyregion, graphics::polygon, lwd=lwd) invisible() } else if (inherits(polyregion, "gpc.poly")) { plot(polyregion, poly.args=list(lwd=lwd), ann=FALSE, add=add) } else { if (inherits(polyregion, "Polygon")) polyregion <- sp::Polygons(list(polyregion), "ID") if (inherits(polyregion, "Polygons")) polyregion <- sp::SpatialPolygons(list(polyregion)) ## plot call which works for "SpatialPolygons", "owin", and "sfg" plot(polyregion, lwd=lwd, axes=TRUE, main="", add=add) } } polyCub/R/polyCub.exact.Gauss.R0000644000176200001440000002157015172341742016027 0ustar liggesusers################################################################################ ### polyCub.exact.Gauss: Quasi-Exact Cubature of the Bivariate Normal Density ### ### Copyright (C) 2009-2018,2021-2023 Sebastian Meyer ### ### This file is part of the R package "polyCub", ### free software under the terms of the GNU General Public License, version 2, ### a copy of which is available at https://www.R-project.org/Licenses/. ################################################################################ #' Quasi-Exact Cubature of the Bivariate Normal Density (DEFUNCT) #' #' This cubature method is \strong{defunct} as of \pkg{polyCub} version 0.9.0. #' It relied on \code{tristrip()} from package \CRANpkg{gpclib} for polygon #' triangulation, but that package did not have a \acronym{FOSS} license and #' was no longer maintained on a mainstream repository.\cr #' Contributions to resurrect this cubature method are welcome: an alternative #' implementation for constrained polygon triangulation is needed, see #' \url{https://github.com/bastistician/polyCub/issues/2}. #' #' The bivariate Gaussian density can be integrated based on a triangulation of #' the (transformed) polygonal domain, using formulae from the #' \bibcitet{R:Abramowitz+Stegun:1972} handbook (Section 26.9, Example 9, pp. 956f.). #' This method is quite cumbersome because the A&S formula is only for triangles #' where one vertex is the origin (0,0). For each triangle #' we have to check in which of the 6 outer #' regions of the triangle the origin (0,0) lies and adapt the signs in the #' formula appropriately: \eqn{(AOB+BOC-AOC)} or \eqn{(AOB-AOC-BOC)} or #' \eqn{(AOB+AOC-BOC)} or \eqn{(AOC+BOC-AOB)} or \ldots. #' However, the most time consuming step is the #' evaluation of \code{\link[mvtnorm]{pmvnorm}}. #' #' @param polyregion a \code{"gpc.poly"} polygon or #' something that can be coerced to this class, e.g., an \code{"owin"} polygon #' (via \code{\link{owin2gpc}}), or an \code{"sfg"} polygon (via #' \code{\link{sfg2gpc}}). #' @param mean,Sigma mean and covariance matrix of the bivariate normal density #' to be integrated. #' @param plot logical indicating if an illustrative plot of the numerical #' integration should be produced. Note that the \code{polyregion} will be #' transformed (shifted and scaled). #' @return The integral of the bivariate normal density over \code{polyregion}. #' Two attributes are appended to the integral value: #' \item{nEval}{ #' number of triangles over which the standard bivariate normal density had to #' be integrated, i.e. number of calls to \code{\link[mvtnorm]{pmvnorm}} and #' \code{\link[stats]{pnorm}}, the former of which being the most time-consuming #' operation. #' } #' \item{error}{ #' Approximate absolute integration error stemming from the error introduced by #' the \code{nEval} \code{\link[mvtnorm]{pmvnorm}} evaluations. #' For this reason, the cubature method is in fact only #' quasi-exact (as is the \code{pmvnorm} function). #' } #' @references \bibshow{*} #' @keywords math spatial #' @seealso \code{\link{circleCub.Gauss}} for quasi-exact cubature of the #' isotropic Gaussian density over a circular domain. ## #' @family cubature methods ## #' @example examples/setting.R ## #' @examples ## #' ## quasi-exact integration based on gpclib::tristrip() and mvtnorm::pmvnorm() ## #' \dontrun{## (this example requires gpclib) ## #' hexagon.gpc <- new("gpc.poly", pts = lapply(hexagon, c, list(hole = FALSE))) ## #' plotpolyf(hexagon.gpc, f, xlim = c(-8,8), ylim = c(-8,8)) ## #' print(polyCub.exact.Gauss(hexagon.gpc, mean = c(0,0), Sigma = 5^2*diag(2), ## #' plot = TRUE), digits = 16) ## #' } #' @import methods #' @importFrom sp plot #' @importFrom stats cov2cor #' @importFrom graphics lines #' @export polyCub.exact.Gauss <- function (polyregion, mean = c(0,0), Sigma = diag(2), plot = FALSE) { ## defunctify with a maintainer-level backdoor for building the vignette if (!identical(Sys.getenv("R_GPCLIBPERMIT"), "true")) .Defunct(msg = paste0( "'polyCub.exact.Gauss' is currently unavailable.\n", "Contributions are welcome: " )) if (inherits(polyregion, "owin")) { polyregion <- owin2gpc(polyregion) } else if (inherits(polyregion, "sfg")) { polyregion <- sfg2gpc(polyregion) } else if (!inherits(polyregion, "gpc.poly")) { polyregion <- as(polyregion, "gpc.poly") } stopifnot(is.numeric(mean), length(mean) == 2L, !is.na(mean), is.matrix(Sigma), identical(dim(Sigma), c(2L, 2L)), is.numeric(Sigma), diag(Sigma) > 0, !is.na(Sigma)) ## coordinate transformation so that the standard bivariat normal density ## can be used in integrations (cf. formula 26.3.22) polyregion@pts <- transform_pts(polyregion@pts, mean = mean, Sigma = Sigma) ## triangulation: tristrip() returns a list where each element is a ## coordinate matrix of vertices of triangles ## FIXME: need a reliable tristrip() alternative triangleSets <- utils::getFromNamespace("tristrip", "gpclib")(polyregion) ### ILLUSTRATION ### if (plot) { plot(polyregion, poly.args=list(lwd=2), ann=FALSE) lapply(triangleSets, lines, lty=2) } #################### integrals <- vapply(X = triangleSets, FUN = function (triangles) { int <- 0 error <- 0 nTriangles <- nrow(triangles) - 2L for (i in seq_len(nTriangles)) { res <- .intTriangleAS(triangles[i+(0:2),]) int <- int + res error <- error + attr(res, "error") } c(int, nTriangles, error) }, FUN.VALUE = numeric(3L), USE.NAMES = FALSE) int <- sum(integrals[1,]) ## number of .V() evaluations (if there were no degenerate triangles) attr(int, "nEval") <- 6 * sum(integrals[2,]) ## approximate absolute integration error attr(int, "error") <- sum(integrals[3,]) return(int) } ########################### ### Auxiliary Functions ### ########################### ## transform coordinates according to Formula 26.3.22 transform_pts <- function (pts, mean, Sigma) { mx <- mean[1L] my <- mean[2L] rho <- cov2cor(Sigma)[1L,2L] stopifnot(abs(rho) < 1) sdx <- sqrt(Sigma[1L,1L]) sdy <- sqrt(Sigma[2L,2L]) lapply(pts, function (poly) { x0 <- (poly[["x"]] - mx) / sdx y0 <- (poly[["y"]] - my) / sdy list(x = (x0 + y0) / sqrt(2 + 2*rho), y = (y0 - x0) / sqrt(2 - 2*rho), hole = poly[["hole"]]) }) } ## calculates the integral of the standard bivariat normal over a triangle ABC .intTriangleAS <- function (xy) { if (anyDuplicated(xy)) # degenerate triangle return(structure(0, error = 0)) A <- xy[1,] B <- xy[2,] C <- xy[3,] intAOB <- .intTriangleAS0(A, B) intBOC <- .intTriangleAS0(B, C) intAOC <- .intTriangleAS0(A, C) # determine signs of integrals signAOB <- -1 + 2*.pointsOnSameSide(A,B,C) signBOC <- -1 + 2*.pointsOnSameSide(B,C,A) signAOC <- -1 + 2*.pointsOnSameSide(A,C,B) int <- signAOB*intAOB + signBOC*intBOC + signAOC*intAOC attr(int, "error") <- attr(intAOB, "error") + attr(intBOC, "error") + attr(intAOC, "error") return(int) } ## calculates the integral of the standard bivariat normal over a triangle A0B .intTriangleAS0 <- function (A, B) { BmA <- B - A d <- vecnorm(BmA) h <- abs(B[2L]*A[1L] - A[2L]*B[1L]) / d # distance of AB to the origin if (d == 0 || h == 0) # degenerate triangle: A == B or 0, A, B on a line return(structure(0, error = 0)) k1 <- dotprod(A, BmA) / d k2 <- dotprod(B, BmA) / d V2 <- .V(h, abs(k2)) V1 <- .V(h, abs(k1)) res <- if (sign(k1) == sign(k2)) { ## A and B are on the same side of the normal line through 0 abs(V2 - V1) } else { V2 + V1 } attr(res, "error") <- attr(V1, "error") + attr(V2, "error") return(res) } ## checks if point1 and point2 lie on the same side of a line through ## linepoint1 and linepoint2 .pointsOnSameSide <- function (linepoint1, linepoint2, point1, point2 = c(0,0)) { n <- c(-1,1) * rev(linepoint2-linepoint1) # normal vector S <- dotprod(point1-linepoint1,n) * dotprod(point2-linepoint1,n) return(S > 0) } ## calculates the integral of the standard bivariat normal ## over a triangle bounded by y=0, y=ax, x=h (cf. formula 26.3.23) #' @importFrom stats pnorm .V <- function(h,k) { if (k == 0) # degenerate triangle return(structure(0, error = 0)) a <- k/h rho <- -a/sqrt(1+a^2) # V = 0.25 + L(h,0,rho) - L(0,0,rho) - Q(h) / 2 # L(0,0,rho) = 0.25 + asin(rho) / (2*pi) # V = L(h,0,rho) - asin(rho)/(2*pi) - Q(h) / 2 Lh0rho <- mvtnorm::pmvnorm( lower = c(h,0), upper = c(Inf,Inf), mean = c(0,0), corr = matrix(c(1,rho,rho,1), 2L, 2L) ) Qh <- pnorm(h, mean = 0, sd = 1, lower.tail = FALSE) return(Lh0rho - asin(rho)/2/pi - Qh/2) } polyCub/R/coerce-gpc-methods.R0000644000176200001440000001030014516025551015661 0ustar liggesusers################################################################################ ### Conversion between polygonal "owin" and "gpc.poly" ### ### Copyright (C) 2012-2015,2017-2018,2021 Sebastian Meyer ### ### This file is part of the R package "polyCub", ### free software under the terms of the GNU General Public License, version 2, ### a copy of which is available at https://www.R-project.org/Licenses/. ################################################################################ #' Conversion between polygonal \code{"owin"} and \code{"gpc.poly"} #' #' Package \pkg{polyCub} implements converters between the classes #' \code{"\link[spatstat.geom:owin.object]{owin}"} of package \CRANpkg{spatstat.geom} #' and \code{"gpc.poly"} of package \CRANpkg{gpclib}. #' #' @param object an object of class \code{"gpc.poly"} or \code{"owin"}, #' respectively. #' @return The converted polygon of class \code{"gpc.poly"} or \code{"owin"}, #' respectively. If package \pkg{gpclib} is not available, #' \code{owin2gpc} will just return the \code{pts} slot of the #' \code{"gpc.poly"} (no formal class) with a warning. #' @author Sebastian Meyer #' @note The converter \code{owin2gpc} requires the package #' \pkg{gpclib} for the formal class definition of a \code{"gpc.poly"}. #' It will produce vertices ordered according to the \pkg{sp} convention, #' i.e. clockwise for normal boundaries and anticlockwise for holes, where, #' however, the first vertex is \emph{not} repeated! #' @seealso \code{\link{xylist}} #' @name coerce-gpc-methods #' @rdname coerce-gpc-methods #' @keywords spatial methods #' @import methods #' @export #' @examplesIf requireNamespace("spatstat.geom") #' ## use example polygons from #' example(plotpolyf, ask = FALSE) #' letterR # a simple "xylist" #' #' letterR.owin <- spatstat.geom::owin(poly = letterR) #' letterR.gpc_from_owin <- owin2gpc(letterR.owin) #' ## warns if "gpclib" is unavailable #' #' if (is(letterR.gpc_from_owin, "gpc.poly")) { #' letterR.xylist_from_gpc <- xylist(letterR.gpc_from_owin) #' stopifnot(all.equal(letterR, lapply(letterR.xylist_from_gpc, `[`, 1:2))) #' letterR.owin_from_gpc <- gpc2owin(letterR.gpc_from_owin) #' stopifnot(all.equal(letterR.owin, letterR.owin_from_gpc)) #' } owin2gpc <- function (object) { object <- spatstat.geom::as.polygonal(object) ## determine hole flags of the individual polygons hole <- spatstat.geom::summary.owin(object)$areas < 0 ## reverse vertices and set hole flags pts <- mapply( FUN = function (poly, hole) { list(x = rev.default(poly$x), y = rev.default(poly$y), hole = hole) }, poly = object$bdry, hole = hole, SIMPLIFY = FALSE, USE.NAMES = FALSE) ## formal class if (know_gpc.poly()) { new("gpc.poly", pts = pts) } else { warning("formal class \"gpc.poly\" not available") pts } } #' @rdname coerce-gpc-methods #' @param ... further arguments passed to \code{\link[spatstat.geom]{owin}}. #' @export gpc2owin <- function (object, ...) { ## first convert to an "owin" without checking areas etc. ## to determine the hole status according to vertex order (area) res <- spatstat.geom::owin(poly = object@pts, check = FALSE) holes_owin <- spatstat.geom::summary.owin(res)$areas < 0 ## or directly lapply spatstat.utils::is.hole.xypolygon ## now fix the vertex order bdry <- mapply( FUN = function (poly, owinhole) { if (poly$hole != owinhole) { poly$x <- rev(poly$x) poly$y <- rev(poly$y) } poly }, poly = object@pts, owinhole = holes_owin, SIMPLIFY = FALSE, USE.NAMES = FALSE) ## now really convert to owin with appropriate vertex order spatstat.geom::owin(poly = bdry, ...) } #' @rdname coerce-gpc-methods #' @param W an object of class \code{"gpc.poly"}. #' @export #' @rawNamespace if(getRversion() >= "3.6.0") { # delayed registration #' S3method(spatstat.geom::as.owin, gpc.poly) #' } as.owin.gpc.poly <- function (W, ...) { gpc2owin(W, ...) } ## check for the formal class "gpc.poly" #' @import methods know_gpc.poly <- function () { isClass("gpc.poly") #|| requireNamespace("gpclib", quietly = TRUE) } polyCub/R/plotpolyf.R0000644000176200001440000001032115172466713014254 0ustar liggesusers################################################################################ ### plotpolyf: Plot Polygonal Domain on Image of Bivariate Function ### ### Copyright (C) 2013-2014,2018,2021 Sebastian Meyer ### ### This file is part of the R package "polyCub", ### free software under the terms of the GNU General Public License, version 2, ### a copy of which is available at https://www.R-project.org/Licenses/. ################################################################################ #' Plot Polygonal Domain on Image of Bivariate Function #' #' Produces a combined plot of a polygonal domain and an image of a bivariate #' function, using either \code{\link[lattice:levelplot]{lattice::levelplot}} #' or \code{\link{image}}. #' #' @param polyregion a polygonal domain. #' The following classes are supported: #' \code{"\link[spatstat.geom]{owin}"} from package \pkg{spatstat.geom}, #' \code{"gpc.poly"} from \pkg{gpclib}, #' \code{"\link[sp:SpatialPolygons-class]{SpatialPolygons}"}, #' \code{"\link[sp:Polygons-class]{Polygons}"}, #' and \code{"\link[sp:Polygon-class]{Polygon}"} from package \pkg{sp}, as well as #' \code{"\link[sf:st_polygon]{(MULTI)POLYGON}"} from package \pkg{sf}. #' (For these classes, \pkg{polyCub} knows how to get an \code{\link{xylist}}.) #' @param f a two-dimensional real-valued function. #' As its first argument it must take a coordinate matrix, i.e., a #' numeric matrix with two columns, and it must return a numeric vector of #' length the number of coordinates. #' @param ... further arguments for \code{f}. #' @param npixel numeric vector of length 1 or 2 setting the number of pixels #' in each dimension. #' @param cuts number of cut points in the \eqn{z} dimension. #' The range of function values will be divided into \code{cuts+1} levels. #' @param col color vector used for the function levels. #' @param lwd line width of the polygon edges. #' @param xlim,ylim numeric vectors of length 2 setting the axis limits. #' \code{NULL} means using the bounding box of \code{polyregion}. #' @param use.lattice logical indicating if \pkg{lattice} graphics #' (\code{\link[lattice]{levelplot}}) should be used. #' @param print.args a list of arguments passed to \code{\link[lattice]{print.trellis}} #' for plotting the produced \code{\link[lattice:trellis.object]{"trellis"}} object #' (if \code{use.lattice = TRUE}). The \code{print} step is omitted #' if \code{print.args} is not a list. #' @author Sebastian Meyer #' @keywords hplot #' @example examples/plotpolyf.R #' @importFrom grDevices extendrange heat.colors #' @importFrom graphics image #' @export plotpolyf <- function (polyregion, f, ..., npixel = 100, cuts = 15, col = rev(heat.colors(cuts+1)), lwd = 3, xlim = NULL, ylim = NULL, use.lattice = TRUE, print.args = list()) { polys <- if (inherits(polyregion, "gpc.poly")) { # avoid xylist.gpc.poly polyregion@pts # ring direction is irrelevant for plotting } else xylist(polyregion) npixel <- rep_len(npixel, 2L) ## make two-dimensional grid if (is.null(xlim)) xlim <- extendrange(unlist(lapply(polys, "[[", "x"), use.names=FALSE)) if (is.null(ylim)) ylim <- extendrange(unlist(lapply(polys, "[[", "y"), use.names=FALSE)) xgrid <- seq(xlim[1L], xlim[2L], length.out = npixel[1L]) ygrid <- seq(ylim[1L], ylim[2L], length.out = npixel[2L]) xygrid <- expand.grid(x=xgrid, y=ygrid, KEEP.OUT.ATTRS=FALSE) ## compute function values on the grid xygrid$fval <- f(as.matrix(xygrid, rownames.force = FALSE), ...) ## plot if (use.lattice && requireNamespace("lattice")) { mypanel <- function(...) { lattice::panel.levelplot(...) lapply(polys, lattice::panel.polygon, lwd=lwd) } trobj <- lattice::levelplot(fval ~ x*y, data=xygrid, aspect="iso", cuts=cuts, col.regions=col, panel=mypanel) if (is.list(print.args)) { do.call("print", c(alist(x=trobj), print.args)) } else trobj } else { image(xgrid, ygrid, matrix(xygrid$fval, npixel[1L], npixel[2L]), col=col, xlab="x", ylab="y", asp=1) plot_polyregion(polyregion, lwd=lwd, add=TRUE) } } polyCub/R/polyCub.iso.R0000644000176200001440000002564115172341742014437 0ustar liggesusers################################################################################ ### polyCub.iso: Cubature of Isotropic Functions over Polygonal Domains ### ### Copyright (C) 2013-2018,2026 Sebastian Meyer ### ### This file is part of the R package "polyCub", ### free software under the terms of the GNU General Public License, version 2, ### a copy of which is available at https://www.R-project.org/Licenses/. ################################################################################ #' Cubature of Isotropic Functions over Polygonal Domains #' #' \code{polyCub.iso} numerically integrates a radially symmetric function #' \eqn{f(x,y) = f_r(||(x,y)-\boldsymbol{\mu}||)}{f(x,y) = f_r(||(x,y)-\mu||)}, #' with \eqn{\mu} being the center of isotropy, over a polygonal domain. #' It internally approximates a line integral along the polygon boundary using #' \code{\link{integrate}}. The integrand requires the antiderivative of #' \eqn{r f_r(r)}), which should be supplied as argument \code{intrfr} #' (\code{f} itself is only required if \code{check.intrfr=TRUE}). #' The two-dimensional integration problem thereby reduces to an efficient #' adaptive quadrature in one dimension. #' If \code{intrfr} is not available analytically, \code{polyCub.iso} can use a #' numerical approximation (meaning \code{integrate} within \code{integrate}), #' but the general-purpose cubature method \code{\link{polyCub.SV}} might be #' more efficient in this case. #' See \bibcitet{|meyer.held2014|Supplement B, Section 2.4} #' for mathematical details. #' #' @inheritParams plotpolyf #' @param intrfr a \code{function(R, ...)}, which implements the (analytical) #' antiderivative of \eqn{r f_r(r)} from 0 to \code{R}. The first argument #' must be vectorized but not necessarily named \code{R}.\cr #' If \code{intrfr} is missing, it will be approximated numerically via #' \preformatted{ #' integrate(function(r, ...) r * f(cbind(x0 + r, y0), ...), #' 0, R, ..., control = control) #' } #' where \code{c(x0, y0)} is the \code{center} of isotropy. #' Note that \code{f} will \emph{not} be checked for isotropy. #' @param ... further arguments for \code{f} or \code{intrfr}. #' @param center numeric vector of length 2, the center of isotropy. #' @param control list of arguments passed to \code{\link{integrate}}, the #' quadrature rule used for the line integral along the polygon boundary. #' @param check.intrfr logical (or numeric vector) indicating if #' (for which \code{r}'s) the supplied \code{intrfr} function should be #' checked against a numerical approximation. This check requires \code{f} #' to be specified. If \code{TRUE}, the set of test #' \code{r}'s defaults to a \code{\link{seq}} of length 20 from 1 to #' the maximum absolute x or y coordinate of any edge of the \code{polyregion}. #' @param plot logical indicating if an image of the function should be plotted #' together with the polygonal domain, i.e., #' \code{\link{plotpolyf}(polyregion, f, \dots)}. #' @return The approximate integral of the isotropic function #' \code{f} over \code{polyregion}.\cr #' If the \code{intrfr} function is provided (which is assumed to be exact), an #' upper bound for the absolute integration error is appended to the result as #' attribute \code{"abs.error"}. It equals the sum of the absolute errors #' reported by all \code{\link{integrate}} calls #' (there is one for each edge of \code{polyregion}). #' @author Sebastian Meyer #' #' The basic mathematical formulation of this efficient integration for radially #' symmetric functions was ascertained with great support by #' Emil Hedevang (Dept. of Mathematics, Aarhus University, Denmark) #' during the Summer School on Topics in #' Space-Time Modeling and Inference (May 2013, Aalborg, Denmark). #' @references \bibshow{*} #' @seealso #' \code{system.file("include", "polyCubAPI.h", package = "polyCub")} #' for a full C-implementation of this cubature method (for a \emph{single} #' polygon). The corresponding C-routine \code{polyCub_iso} can be used by #' other \R packages, notably \CRANpkg{surveillance}, via \samp{LinkingTo: polyCub} #' (in the \file{DESCRIPTION}) and \samp{#include } (in suitable #' \file{/src} files). Note that the \code{intrfr} function must then also be #' supplied as a C-routine. An example can be found in the package tests. #' @keywords math spatial #' @family cubature methods #' @example examples/polyCub.iso.R #' @importFrom stats integrate #' @export polyCub.iso <- function (polyregion, f, intrfr, ..., center, control = list(), check.intrfr = FALSE, plot = FALSE) { polys <- xylist(polyregion) # transform to something like "owin$bdry" # which means anticlockwise vertex order with # first vertex not repeated getError <- !missing(intrfr) # can't estimate error of double approximation center <- as.vector(center, mode = "numeric") stopifnot(length(center) == 2L, is.finite(center)) ## check 'intrfr' function rs <- if (isTRUE(check.intrfr)) { seq(1, max(abs(unlist(lapply(polys, "[", c("x","y"))))), length.out=20L) } else if (identical(check.intrfr, FALSE)) { numeric(0L) } else { check.intrfr } intrfr <- checkintrfr(intrfr, f, ..., center=center, control=control, rs=rs) ## plot polygon and function image if (plot) plotpolyf(polys, f, ...) ## do the cubature over all polygons of the 'polys' list .polyCub.iso(polys, intrfr, ..., center=center, control=control, .witherror=getError) } #' Check the Integral of \eqn{r f_r(r)} #' #' This function is auxiliary to \code{\link{polyCub.iso}} #' for the cubature of a radially symmetric function #' \eqn{f(x,y) = f_r(||(x,y)-\boldsymbol{\mu}||)}{f(x,y) = f_r(||(x,y)-\mu||)}, #' with \eqn{\mu} being the center of isotropy, over a polygonal domain. #' The (analytical) integral of \eqn{r f_r(r)} from 0 to \eqn{R}, \code{intrfr}, #' is checked against an \code{\link{integrate}}-based approximation #' for various values (\code{rs}) of the upper bound \eqn{R}. #' A warning is issued if inconsistencies are found. #' #' @inheritParams polyCub.iso #' @param rs numeric vector of upper bounds for which to check the validity of #' \code{intrfr}. If it has length 0 (default), no checks are performed. #' @param tolerance of \code{\link{all.equal.numeric}} when comparing #' \code{intrfr} results with numerical integration. Defaults to the #' relative tolerance used for \code{integrate}. #' @examples #' f_const <- function (coords) rep(1, nrow(coords)) #' intrfr_const <- function (R) R^2/2 # = \int_0^R r f_r(r) dr #' checkintrfr(intrfr_const, f = f_const, center = c(0,0), rs = 1:10) # OK #' checkintrfr(function(R) R, f = f_const, center = c(0,0), rs = 1:10) # warns #' @return The \code{intrfr} function, invisibly. If only \code{f} was given, #' an \code{integrate}-based approximation of \code{intrfr} is returned. #' @importFrom stats integrate #' @export checkintrfr <- function (intrfr, f, ..., center, control = list(), rs = numeric(0L), tolerance = control$rel.tol) { doCheck <- length(rs) > 0L if (!missing(f)) { f <- match.fun(f) rfr <- function (r, ...) r * f(cbind(center[1L]+r, center[2L], deparse.level=0L), ...) quadrfr1 <- function (R, ...) integrate(rfr, 0, R, ...)$value if (length(control)) body(quadrfr1)[[2L]] <- as.call(c(as.list(body(quadrfr1)[[2L]]), control)) quadrfr <- function (R, ...) vapply(X = R, FUN = quadrfr1, FUN.VALUE = 0, ..., USE.NAMES = FALSE) if (missing(intrfr)) { return(quadrfr) } else if (doCheck) { cat("Checking 'intrfr' against a numerical approximation ... ") stopifnot(is.vector(rs, mode="numeric")) if (is.null(tolerance)) tolerance <- eval(formals(integrate)$rel.tol) ana <- intrfr(rs, ...) num <- quadrfr(rs, ...) comp <- all.equal(num, ana, tolerance = tolerance) if (!isTRUE(comp)) { cat("\n->", comp, "\n") warning("'intrfr' might be incorrect: ", comp) } else cat("OK\n") } } else if (doCheck) { stop("numerical verification of 'intrfr' requires 'f'") } invisible(match.fun(intrfr)) } #' @description #' \code{.polyCub.iso} is a \dQuote{bare-bone} version of \code{polyCub.iso}. #' @rdname polyCub.iso #' @param polys something like \code{owin$bdry}, but see \code{\link{xylist}}. #' @param .witherror logical indicating if an upper bound for the absolute #' integration error should be attached as an attribute to the result? #' @export .polyCub.iso <- function (polys, intrfr, ..., center, control = list(), .witherror = FALSE) { ints <- lapply(polys, polyCub1.iso, intrfr, ..., center=center, control=control, .witherror=.witherror) if (.witherror) { res <- sum(vapply(X=ints, FUN="[", FUN.VALUE=0, 1L, USE.NAMES=FALSE)) attr(res, "abs.error") <- sum(vapply(X=ints, FUN="[", FUN.VALUE=0, 2L, USE.NAMES=FALSE)) res } else { sum(unlist(ints, recursive=FALSE, use.names=FALSE)) } } ## cubature method for a single polygon polyCub1.iso <- function (poly, intrfr, ..., center, control = list(), .witherror = TRUE) { xy <- cbind(poly[["x"]], poly[["y"]], deparse.level=0L) nedges <- nrow(xy) intedges <- erredges <- numeric(nedges) for (i in seq_len(nedges)) { v0 <- xy[i, ] - center v1 <- xy[if (i==nedges) 1L else i+1L, ] - center int <- lineInt(v0, v1, intrfr, ..., control=control) intedges[i] <- int$value erredges[i] <- int$abs.error } int <- sum(intedges) ## if (!is.null(poly$hole) && !isTRUE(all.equal(0, int))) { ## if ((1 - 2 * as.numeric(poly$hole)) * sign(int) == -1) ## warning("wrong sign if positive integral") ## } if (.witherror) { c(int, sum(erredges)) } else { int } } ## line integral for one edge #' @importFrom stats integrate lineInt <- function (v0, v1, intrfr, ..., control = list()) { d <- v1 - v0 num <- v1[2L]*v0[1L] - v1[1L]*v0[2L] # = d[2]*p[,1] - d[1]*p[,2] # for any point p on the edge if (num == 0) { # i.e., if 'center' is part of this polygon edge return(list(value = 0, abs.error = 0)) } integrand <- function (t) { ## get the points on the edge corresponding to t p <- cbind(v0[1L] + t*d[1L], v0[2L] + t*d[2L], deparse.level=0L) norm2 <- .rowSums(p^2, length(t), 2L) ints <- intrfr(sqrt(norm2), ...) ##ints[is.infinite(ints)] <- 1e300 num * ints / norm2 } if (length(control)) { # use slower do.call()-construct do.call("integrate", c(list(integrand, 0, 1), control)) } else { integrate(integrand, 0, 1) } } polyCub/R/sysdata.rda0000644000176200001440000004464412375637762014266 0ustar liggesusers7zXZi"6!X|Ih])TW"nRʟ)'dz$&}T1}} IL9d]hϐf Qcv\ DÿNրGsFcw}8=ɥ""(U= b4 Yq:>qx6J6LUB4x}0&[g"QCBb9,xgeދ|`$ٔ'Nz#3< @?4򬐱kw,askfG 8ym['ZlDrKG3C,ACI[ :Qms]볾+) 1ER˹FbK%uaR4f!5P)~+LbBF{Oq@mHMN+`]rWI5O.Sޟ\BlO!ɫB|UK-sk<`p[_FЁ'v`¬#Ȯd3D}hm _04zYeWgU -}_ϬH>4dbn* &!d0L!d҆;b.jH)\9м AJa_F>={i*[B$85͋͞;fy+ !+ϷW6g_ \Mj'0c ې2(̮jE'd,m ʓ(emgW| ߒA6VʰB`M91 iOY -H/Ş3D ,6PKZrN02p jӢOo C])˧.-h[c6G_ڢZdvy L˜ه)"$mluu誣H%6BC7IxJb4(K\`343u*ҡ>Lׇ.Inm0j )/\J)r6wjӳQW1M>}(BYż{s)q My pUAvsUj0h1qd),C\-v`7[1}%l7݂(&{d a~t0Ŗyfk_lJ:0JM^g X+.2{ZFG_e5x+}OY5kА-JFo⑐5_Q :!I^oO}e%oG8xO*ݿ <^Lx8o}~;u/T%6AejBB R63*7(QL#iZLԤ?GokLhۻ.0 =--[Aaϗ/x\㇑&$q+p!6e=j;+^Nq=v%"tJ$2/:Ȳ3EBJ@rŘHKEGkڂ2t=,Nes!2MXO9ԲoDaU~7qÔ9yn/ot' 7oYz\2z䘯 P+r f0pQ-hG̨Lܗo.w'/mGИ Ah9fݳ(+xaF-[G5O1\6ǜDD\dd۷bqK1GqpВjՂb;ǑlnlP!\6Gsi AQcxl 4ugB`$ L 5  p3K8c,4H35ܰJt.V Cꈥx-juv.NcJW2 /}ݽxW)qS<f;8ؿ,U2Pt/F}'懂 ?GC,馸tU|PZ(36{s@e> _٭5-*WX:l|P…df9րu Hs s>kǴ-ZZ#vnz\Ɂ3'̐`Az]rw? $Y2j^ܩQ@xr68R=r!r1YmWS<%c Hjɺ{ilL6~ҝ/~eڕrhBA vJV/q5cr`*Z庅PJ8Zڲ찭ȃD7˔?OΟ7a1clf咦n*_R U\KS്iNB:fO{!B3 592#9-Ȅ=jC7m^R3ސ%u [U/|ih R~xK@|[!Xd~:"OEmpE߃Ԋs2ӺK6OŮ )..k{WCbG] ȸ>q4Psn&vE¦<|E΄1|ibBR;U}h.vY^ pmZ_0nAYxlBW6*ZP ]gV>ɉf_ l/hOy˔d[СYLE'a]$,o[ưuuVHF(XfH'q~pf>9k7ޔ3`A(hzs*n԰-jyxěѥ$ *l'EXTmE%۟cc[0J}= 4AT+:oju-b[e>QaD0*H P󆑕3w"C 57;Fd|k4U/-I8aEw]EI>0Ӳf,Kw:}!!|d9=ч1 u*1YWȘYrT##?>FVT1[_Rz2a!W2NyH; bb~ӄdʲ 6B}N4:/ 7zEW3Wn9ee޲ ն*9:ڽcoL64/+Fpqyr :9`͚ŭU~d;%6] 2kMexHp'ˁ0rW6dEk#^a+) cё9J-I`4[Lː]t7ķ2 0#k1?L}l*Q2[-ʹ,;#RX1$dᖩC cա:NعX (錼;G15 `%XOJV%?Ek:uy#Ǝ]}-`)w\MgEdX+ndY ^L)HQk {+—Qꦋ,(ض4h'|ÞD _`mcPφζ6UӳƼ=Ԯm";N`CAh`(Jq-I8ξq4( `BH/h[r#hvp7?%^q|"JU6j6[OG=*&'p8a. ; 6s_EѮD?Z=m2Ղ:8fgɌx‡]S&WCZq"Wɖ5_||Ѝ.ٌ%5923GCQD-K IJ #2]dM7[*A?&en6qY}dBPiz48V|)k`OFoTW)h{Fn$ӂ';Daڂ1K{إ> 1QwrH" !gb=j-"xF=6%Qgjd'wf_1@bZlm*^a#Hf"6ǭ+ǹhc}| x2#r~V,^M@tlyY<[<(gV󋇅@ %>l:+8iE&6{v()#Q(Yy],>kv.A2M'JTZ6RfaN%8i%Lez81\*Zyx[N; + GEft_9M"^[R`J_1A(S돭 }Of*wH_(`bcFUNMѝUAeگf Aў|m_1sڠ~  [diwbZ˚wEe9Hb1Y&ɂ 7x"\D9ΞKztE쌛xq>ˎ&R^D$lfO~zs9P[ը2'NRx O=F (hu |'{ڗߛ6P2Dhb+[ _W}rtyl3&38~;N yQփ-Fc#J5e bdP/gǂr@ϟrʛf0CU[ug SLVNepZ|JT.&Qmu \'tZ-cC[FU5b 7f"wJ|ϊWJXu8SItS˼A~1crgJ'̱Q@՗0Kj{dG׏YT0>o⋢jL!d*\cM8na <^ )بh&߷)%QVu$%c42MCBQ|T<,eSu|K~;5kDC-T9G=$?TۚHQS%$ wLq*Bp'W.>34~#9qĹlZ XSjؖ-.VP33 QQ2+QC,ےOG$)Y&ފ#bnPšmC <%q Bc.SҖ[QF-k;~O{8N9&Yǽ5SqS"-[gQyK )s2VYVv=KNΡ{Ju y9D,[׺YYxZؓVȫ.õN{822Xye z4}p7QCzU~&lNuǓa@4zPԊMUvWij-؆O_2+whF)NM?7쪖o p;{xi<?cCN,ƕvMP c!Mxp*^D_^*\0v%S5N'{G|8sգZ w3'.*kx[0읏 Ca(]Mڢ@՗>)*Dez礩izh- xP*+qʂ3C-fKN*DnzX{¥Y3b{?PLcps!<+2j|}`mZ=Ѫe#e[wdJq# 7ƴFLL4ՙ賗hrHY$ )IRl?lOWFwBc+L1(t9-eD:6J*[̏ /o{!n;/vEXc8XETU#ayC DxF*,R꒸3ؿM1eLNrjYR@mi쭢SMMfנ/h`ҹc>i)~ur=#b_b .q_gK ǟ ؿ!pHC#*n gli-D晱:~xywjјq{ BTzdםv3WTgNzn|ATW =K_WUE;õE5V 3˓c $pmNb  ؇ǘ#(:tyyb! zgILlC1ARG<=6a GkD & aA"Sw^)з:YsC.۠:!LqOi1 fG۟E(7'k^Y`X=D-kHXl.㪙¤?zY~-<ĵ+zL+.iHFO6˦D!$ e/ +s~4#AIZX8[1?Ł>n#>8JE}cڳ%1vfTlC6nʽkmӕD$h1˚9MXy;1 tnsIa lWџW \L Xi.By sHu]M|sf٠}Q\[ ] qosl?h!)+#ͬ|IտۀRӯl􋗥58I&IMO5=~DOl2T|1QRjo/.}1 d~c銧۫Oa{jbBMi4K<$^.qp@Di:"gt*:'TċּeufšFEb׳eteV%ML(̸kY^oƒyOG*$wkWe3t*mV!XL%fzn3s,F3JxAV0N!{{§&5"XkiUٜ (䄔Cp@sukFݎpŢd( sENffI3/݅WG{8} jtzlGM]`! T/毌@(l >d`[q&YW6/p9j)naQ!| jwн\,4 j=G;s2ljRi_y@<,j(`Ba:`<,vWpI_pP5aq7Z<2=IҨE\e-CLzh„/9Rz{ U: cnZ0!H mW>#Q;_܍'Afi^N>JޡXȊ<VkAg$"Fs@]V?-AdzFKh||*, O0.T _n`mH<#?ɀSsTg?NSg/ EÿXLE{v,(}gp=QR& kMW#y\ӊebq&$Nx] ɼBqt xd36`Pl@w~372R] \too׏ $^Ar:HK ]s؀DU)07+=͡]=դz̩6h+8zj;C@4N z`4( ):PW)ad?aYoyEb7XIeF"_9in1\PWD,c`SpqW׉/VS(ŭI8KՀѕ.Kfm_oطrٗ#7 ~#'{ !^> tbi;0!1~/ 6Z(CDZz[2 bRdOI WOI*07M8Fas[ʘ6"&E)F(Ĉ-t(bORڮˢ< ˱GUx!m}Ztv|%RXc;ȢA\!ڌ_Z`p]͇ѠFKzNy}vMs{:1<~UcT9Woo5geLҮL@cTAvAN,st İ vM,ʐLڹń)ӎ[kDh0o: wdrf3qhmpMxDm%Wɡ(e>,!#bTxVٲ6F[vo|`3Gf' 矵-^LsYvIcNH 2рΏW{%f5U=30O?Rue<''Z[07p?%wrO=!wLAumҕ&̓^%٨{߷OjKPoS[.mз~wcLg|5S\Dܑ$b$v5_;[EpfEgNz0>+u`lj?:J*D/ky?+}yV*<5V_ y:-q|SL_*6MȱKEKXF҆SH"( Q= E*Q'?}m&mAD}:sQ_//2j*pl޼d(}prL5O,8wQbmѪ$'#$_í"kM[9<-xm=3  &`V2q0!yY9gVlc4}bi!v>W@zvJPqjrNRNҞ`_*';n Ny+AONW.dM>֚\F2J}ItVDwDN4zTޢHd8 60re<Ta"mpYȀ#FVo:a ]k-A?úٷ^}.8B&cV" 1Ujb>^WR jiܻs)cN\}dF9$qĞmSffuY\{r_F%vIeD]ϨN7!?Vvf.a""Fzi60#; }_f % *rM#KZ[?cOgsLbmÈnpFӲY5(R$=% 4$qWof [?A`*y+uRR[N?'R}SgDZ.u%ꘌT˕c( cPKdŤU P.<m~aٔW 8a8dVU3!6b 'ܔ=JX4NjbGBl72E/*ƁǏn K 1Yy\GTYpi. Cff3DJ!:%f(nޫzjK:K0@3I2K?IJm[ܰ y@R}w@}~rK>,ƨ =5_UWW-SGMՆa=LULp4vo Qrgp7Ў̡p(o2W #]gpm)e!ѹم4>O uhm{7C {@D+>è\}'I:VSoD"0a @O_|cBow?JɓOJej`ëG6ԾuޏXc%^I`^K mM^<fHjAc.oӶM;k(tq 8Lb|C9اq*s6 9/P@(3"F)$_} ~s "p!d2(1.uYSIQX7pw3KB G.sDs) d7tGn?-WeOPi8Yzǚ8^ hTk_">M,v{=ýɻq/*ؖ[QfXS6/; &kمn==p [9-l d5V5sڢX+YƤx *"(˦Һ}3p+N36H\޿&S4,>xݐԪqN8t t y~MҎ8rXyѵ7dq1K=%H_ISt]@h"uƯP6U-F?sI)r-.xT,+3WH'Ql̬0sUNZ3h ܈-MBՠ{ 7^ѹS=u8fo"? D$zVTl9c˞U'F}AE 1ZbV()-Q36Mp!֘ A9kuۈtg]S<%e"Rհu[kri^BOP!U)y|KbLn:qNG2.P-;G>Yl%腰=O/sjwʿ+OQhKfCۄ]@l_VI! We3 qDT$}Dlq"J }=O-kEBzvl^MiDHӧ{I`K@qq''%FiS3M&S0F?2eEkͤ s,;!,_t/]R=<Al]=  Hv$ݼadn_^Yuu;6_S0[EI!**q\#a}wGG͍S,"J!+0Hh(w #U 3)|cjJW[IrŻ:ҝ|@zC~a>A?[蹺a}?,\hI󺡹8U&6C5K=S> V}-_,!~=1XT S8e|h,No}Nۿ9E&^HLm*%^܈v/Nto1ӑJE%kkݚX/ l[_{qkR|0ۀ 00{k4HV_z{F_\]*W-> &`Mt oUHsԂ+YE|kwQxa =+b4p &F2lj9!h|!-`3tWw-jj,EﮓSS[ۈ=:+LsՁ [+ -kIi겂f%tIjY#E*u}ϒ}c Q5d .KCeCI0>+ KU*xEʊ17 NMK/O_x̲)PzI| S %\l[2|I 3oh;,j1ѨLx7pvpyFsE H*M$>'e:w fT!UrL!&lDF% aάm9w"5s>|펻86_FyV8A w9_a =IzNLc\Gg3g8v$#'Hf@8EG1MJv"u*\CG"7"[C6Mdy.bQV,xWlQvQmv֓|~O곀NoC#nN>iyI4|B$)=' ߤ$\0 ynmo SO8bKfRo5UVclW;e1{,dٷ r+!"m/Xq$;Idn NcY.9R `MWև;9"yAz SAF(rH翿^~DX0.~Nqs'SȀ0'Hu]'D &$nJZhy"N, z(h$W[Hj1MTr "ZޅQGtM`663S/_XJwz"Elgl~YuEc@: cN7}!~ kn{n@̘/lX>NP%=\s{ZYzB9A/"pV^EK8la2 "2yn~buts6/>OU^Ja#)&-肈,<ȸ $?N5M0^9w;б# \PVN |J!6FU  i59Rb@2 P\a$~lr D R-@ݘL ۴Hn m\dٲ#(3OEd{`J!a<./d/&kG!tpV#@zJJL+\@ZF>u?{ jRPj^.;7C:D %㶫IP=vؔIB/gGA :xa_O>Ï]>V|7Iv0ܷ[(c2NohCdl,4ҒP).+mD~.0zk2Mո o+)!p]Ct] ;),KԅdyㆁdIG۔52߳J@HD$DO%̊ Q Eݤ`j%A'{Px'PچpBj/zʱABfC[% Juǿt=ih=v>ĜYj 1PT*kb_z8\WW9MCjV}.}JO7E5)jMxH GvDOz:W A#W7B3b7"MTG%n,c(p1 Fqkix?A9]@3-/>0 YZpolyCub/R/xylist.R0000644000176200001440000001307415172123737013564 0ustar liggesusers################################################################################ ### xylist: Convert Various Polygon Classes to a Simple List of Vertices ### ### Copyright (C) 2012-2014,2017,2021 Sebastian Meyer ### ### This file is part of the R package "polyCub", ### free software under the terms of the GNU General Public License, version 2, ### a copy of which is available at https://www.R-project.org/Licenses/. ################################################################################ #' Convert Various Polygon Classes to a Simple List of Vertices #' #' Different packages concerned with spatial data use different polygon #' specifications, which sometimes becomes very confusing (see Details below). #' To be compatible with the various polygon classes, package \pkg{polyCub} #' uses an S3 class \code{"xylist"}, which represents a polygonal domain #' (of potentially multiple polygons) by its core feature only: a list of lists #' of vertex coordinates (see the "Value" section below). #' The generic function \code{xylist} can deal with the #' following polygon classes: #' \itemize{ #' \item \code{"\link[spatstat.geom:owin.object]{owin}"} from package \pkg{spatstat.geom} #' \item \code{"gpc.poly"} from package \pkg{gpclib} #' \item \code{"\link[sp:Polygons-class]{Polygons}"} from package \pkg{sp} #' (as well as \code{"\link[sp:Polygon-class]{Polygon}"} and #' \code{"\link[sp:SpatialPolygons-class]{SpatialPolygons}"}) #' \item \code{"\link[sf:st_polygon]{(MULTI)POLYGON}"} from package \pkg{sf} #' } #' The (somehow useless) default \code{xylist}-method #' does not perform any transformation but only ensures that the polygons are #' not closed (first vertex not repeated). #' #' Polygon specifications differ with respect to: #' \itemize{ #' \item is the first vertex repeated? #' \item which ring direction represents holes? #' } #' Package overview: #' \describe{ #' \item{\pkg{spatstat.geom}:}{\code{"owin"} does \emph{not repeat} the #' first vertex, and anticlockwise = normal boundary, clockwise = hole. #' This convention is also used for the return value of \code{xylist}.} #' \item{\pkg{sp}:}{\emph{Repeat} first vertex at the end (closed), #' anticlockwise = hole, clockwise = normal boundary} #' \item{\pkg{sf}:}{\emph{Repeat} first vertex at the end (closed), #' clockwise = hole, anticlockwise = normal boundary; #' \emph{however}, \pkg{sf} does not check the ring direction by default, so #' it cannot be relied upon.} #' \item{\pkg{gpclib}:}{There seem to be no such conventions #' for polygons of class \code{"gpc.poly"}.} #' } #' Thus, for polygons from \pkg{sf} and \pkg{gpclib}, \code{xylist} needs #' to check the ring direction, which makes these two formats the least #' efficient for integration domains in \pkg{polyCub}. #' #' @param object an object of one of the supported spatial classes. #' @param ... (unused) argument of the generic. #' @return Applying \code{xylist} to a polygon object, one gets a simple list, #' where each component (polygon) is a list of \code{"x"} and \code{"y"} #' coordinates. These represent vertex coordinates following \pkg{spatstat.geom}'s #' \code{"owin"} convention (anticlockwise order for exterior boundaries, #' without repeating any vertex). #' @author Sebastian Meyer #' @example examples/diamond.R #' @examples #' stopifnot(identical(xylist(diamond.sp), list(diamond))) #' stopifnot(identical(xylist(diamond.Ps), list(diamond))) #' stopifnot(identical(xylist(diamond.SpPs), list(diamond))) #' @keywords spatial methods #' @export xylist <- function (object, ...) UseMethod("xylist") #' @rdname xylist #' @export xylist.owin <- function (object, ...) { spatstat.geom::as.polygonal(object)$bdry } #' @rdname xylist #' @export xylist.sfg <- function (object, ...) { assert_polygonal_sfg(object) obj <- sf::st_sfc(object, check_ring_dir = TRUE)[[1L]] ## it would be more efficient to use sf's check_ring_dir() directly ## unfortunately, that function is not exported from sf (0.9-7) if (inherits(obj, "MULTIPOLYGON")) obj <- unlist(obj, recursive = FALSE) lapply(obj, function (coords) { idx <- seq_len(nrow(coords) - 1L) list(x = coords[idx, 1L], y = coords[idx, 2L]) }) } #' @rdname xylist #' @export xylist.gpc.poly <- function (object, ...) { xylist.owin(gpc2owin(object, check = FALSE)) } #' @rdname xylist #' @export xylist.SpatialPolygons <- function (object, reverse = TRUE, ...) { unlist(lapply(object@polygons, xylist.Polygons, reverse=reverse, ...), recursive=FALSE, use.names=FALSE) } #' @rdname xylist #' @param reverse logical (\code{TRUE}) indicating if the vertex order of the #' \pkg{sp} classes should be reversed to get the \code{xylist}/\code{owin} #' convention. #' @importFrom sp coordinates #' @export xylist.Polygons <- function (object, reverse = TRUE, ...) { lapply(object@Polygons, function (sr) { coords <- coordinates(sr) n <- nrow(coords) - 1L # number of vertices idxs <- if (reverse) seq.int(n,1) else seq_len(n) list(x = coords[idxs,1L], y = coords[idxs,2L]) #area = sr@area, hole = sr@hole }) } #' @rdname xylist #' @import methods #' @export xylist.Polygon <- function (object, reverse = TRUE, ...) xylist.Polygons(as(object,"Polygons"), reverse=reverse, ...) #' @rdname xylist #' @importFrom grDevices xy.coords #' @export xylist.default <- function (object, ...) { lapply(object, function (xy) { poly <- xy.coords(xy)[c("x","y")] if (isClosed(poly)) { sel <- seq_len(length(poly$x) - 1L) poly$x <- poly$x[sel] poly$y <- poly$y[sel] } poly }) } polyCub/R/coerce-sp-methods.R0000644000176200001440000000641715172123737015554 0ustar liggesusers################################################################################ ### as.owin.SpatialPolygons: Coerce "SpatialPolygons" to "owin" ### ### Copyright (C) 2012-2013,2015,2017-2018,2021 Sebastian Meyer ### ### This file is part of the R package "polyCub", ### free software under the terms of the GNU General Public License, version 2, ### a copy of which is available at https://www.R-project.org/Licenses/. ################################################################################ #' Coerce \code{"SpatialPolygons"} to \code{"owin"} #' #' Package \pkg{polyCub} implements \code{coerce}-methods #' (\code{as(object, Class)}) to convert #' \code{"\link[sp:SpatialPolygons-class]{SpatialPolygons}"} #' (or \code{"\link[sp:Polygons-class]{Polygons}"} #' or \code{"\link[sp:Polygon-class]{Polygon}"}) #' of package \CRANpkg{sp} #' to \code{"\link[spatstat.geom:owin.object]{owin}"} #' of package \CRANpkg{spatstat.geom}. #' They are also available as \code{as.owin.*} functions to support #' \code{\link{polyCub.midpoint}}. #' @author Sebastian Meyer #' @seealso \code{\link{xylist}} #' @keywords spatial methods #' @name coerce-sp-methods #' @rdname coerce-sp-methods #' @import methods #' @importClassesFrom sp Polygon Polygons SpatialPolygons owin #' @exportMethod coerce #' @example examples/diamond.R #' @examples #' if (require("spatstat.geom")) { #' diamond.owin <- owin(poly = diamond) #' diamond.owin_from_Polygon <- as.owin(diamond.sp) #' stopifnot(all.equal(diamond.owin, diamond.owin_from_Polygon)) #' ## also for "Polygons" and "SpatialPolygons", using S3 or S4 methods: #' stopifnot(identical(diamond.owin, as.owin(diamond.Ps))) #' stopifnot(identical(diamond.owin, as(diamond.SpPs, "owin"))) #' } NULL #' @param W an object of class \code{"SpatialPolygons"}, #' \code{"Polygons"}, or \code{"Polygon"}. #' @param ... further arguments passed to \code{\link[spatstat.geom]{owin}}. #' @return The polygon(s) as an #' \code{"\link[spatstat.geom:owin.object]{owin}"} object. #' @rdname coerce-sp-methods #' @export #' @rawNamespace if(getRversion() >= "3.6.0") { # delayed registration #' S3method(spatstat.geom::as.owin, SpatialPolygons) #' S3method(spatstat.geom::as.owin, Polygons) #' S3method(spatstat.geom::as.owin, Polygon) #' } as.owin.SpatialPolygons <- function (W, ...) spatstat.geom::owin(poly = xylist.SpatialPolygons(W), ...) #' @rdname coerce-sp-methods #' @export as.owin.Polygons <- function (W, ...) spatstat.geom::owin(poly = xylist.Polygons(W), ...) #' @rdname coerce-sp-methods #' @export as.owin.Polygon <- function (W, ...) spatstat.geom::owin(poly = xylist.Polygon(W), ...) #' @name coerce,SpatialPolygons,owin-method #' @rdname coerce-sp-methods setAs(from = "SpatialPolygons", to = "owin", def = function (from) as.owin.SpatialPolygons(from)) #' @name coerce,Polygons,owin-method #' @rdname coerce-sp-methods setAs(from = "Polygons", to = "owin", def = function (from) as.owin.Polygons(from)) #' @name coerce,Polygon,owin-method #' @rdname coerce-sp-methods setAs(from = "Polygon", to = "owin", def = function (from) as.owin.Polygon(from)) #' @name coerce,Polygon,Polygons-method #' @rdname coerce-sp-methods setAs(from = "Polygon", to = "Polygons", def = function (from) sp::Polygons(list(from), "Polygon")) polyCub/vignettes/0000755000176200001440000000000015172632754013713 5ustar liggesuserspolyCub/vignettes/polyCub.Rmd0000644000176200001440000002762515172466713016010 0ustar liggesusers--- title: "Getting started with 'polyCub'" author: "Sebastian Meyer" date: "`{r} Sys.Date()`" lang: "en" ## litedown:::add_citation() does not currently support R citation files ... #bibliography: '`{r} system.file("REFERENCES.R", package = "polyCub", mustWork = TRUE)`' vignette: > %\VignetteIndexEntry{Getting started with 'polyCub'} %\VignetteEngine{litedown::vignette} %\VignetteDepends{polyCub, spatstat.geom} output: html: meta: js: ["@center-img"] --- ```{r, setup, include = FALSE, purl = FALSE} litedown::reactor(collapse = TRUE, fig.width = 4, fig.height = 3.5, dev.args = list(units = "in", res = 72)) ## kludge: achieve 'echo = -1' by filtering a chunk's "xfun_record_results" source_drop1 <- function (res) replace(res, 1, list(`attributes<-`(res[[1L]][-1], attributes(res[[1]])))) ## maintainer-mode options for building the vignette: USE_GPCLIB <- identical(Sys.getenv("R_GPCLIBPERMIT"), "true") && requireNamespace("gpclib") # unavailable in --as-cran checks DO_BENCHMARK <- USE_PNGQUANT <- identical(Sys.getenv("NOT_CRAN"), "true") if (DO_BENCHMARK) stopifnot(requireNamespace("microbenchmark"), USE_GPCLIB) if (USE_PNGQUANT) stopifnot(nzchar(Sys.which("pngquant"))) ``` The R package **polyCub** implements *cubature* (numerical integration) over *polygonal* domains. It solves the problem of integrating a continuously differentiable function f(x,y) over simple closed polygons. For the special case of a rectangular domain along the axes, the package [**cubature**](https://CRAN.R-project.org/package=cubature) is more appropriate (cf. [`CRAN Task View: Numerical Mathematics`](https://CRAN.R-project.org/view=NumericalMathematics)). ## Polygon representations The integration domain is described by a polygonal boundary (or multiple polygons, including holes). Various R packages for spatial data analysis provide classes for polygons. The implementations differ in vertex order (which direction represents a hole) and if the first vertex is repeated. All of **polyCub**'s cubature methods understand * `"owin"` from package [**spatstat.geom**](https://CRAN.R-project.org/package=spatstat.geom), * `"gpc.poly"` from [**gpclib**](https://github.com/rdpeng/gpclib/), * `"SpatialPolygons"` from package [**sp**](https://CRAN.R-project.org/package=sp), and * `"(MULTI)POLYGON"` from package [**sf**](https://CRAN.R-project.org/package=sf). Internally, **polyCub** uses its auxiliary `xylist()` function to extract a plain list of lists of vertex coordinates from these classes, such that vertices are ordered anticlockwise (for exterior boundaries) and the first vertex is not repeated (i.e., the `"owin"` convention). ## Cubature methods The following cubature methods are implemented in **polyCub**: 1. `polyCub.SV()`: Product Gauss cubature 2. `polyCub.midpoint()`: Two-dimensional midpoint rule 3. `polyCub.iso()`: Adaptive cubature for radially symmetric functions $f(x,y) = f_r(\lVert(x-x_0,y-y_0)\rVert)$ 4. `polyCub.exact.Gauss()` (*currently disabled*): Accurate integration of the bivariate Gaussian density The following section details and illustrates the different cubature methods. ## Illustrations ```{r} library("polyCub") ``` We consider the integration of a function f(x,y) which all of the above cubature methods can handle: an isotropic zero-mean Gaussian density. **polyCub** expects the integrand f to take a two-column coordinate matrix as its first argument (as opposed to separate arguments for the x and y coordinates), so: ```{r, example-f} f <- function (s, sigma = 5) { exp(-rowSums(s^2)/2/sigma^2) / (2*pi*sigma^2) } ``` We use a simple hexagon as polygonal integration domain, here specified via an `"xylist"` of vertex coordinates: ```{r, example-polygon} hexagon <- list( list(x = c(7.33, 7.33, 3, -1.33, -1.33, 3), y = c(-0.5, 4.5, 7, 4.5, -0.5, -3)) ) ``` An image of the function and the integration domain can be produced using **polyCub**'s rudimentary (but convenient) plotting utility: ```{r, example} plotpolyf(hexagon, f, xlim = c(-8,8), ylim = c(-8,8)) ``` ### 1. Product Gauss cubature: `polyCub.SV()` The **polyCub** package provides an R-interfaced C-translation of `polygauss.m`, an algorithm by Sommariva and Vianello (2007, *BIT Numerical Mathematics*, ). The cubature rule is based on Green's integration formula and incorporates appropriately transformed weights and nodes of one-dimensional Gauss-Legendre quadrature in both dimensions, thus the name "product Gauss cubature". It is exact for all bivariate polynomials if the number of cubature nodes is sufficiently large (depending on the degree of the polynomial). For the above example, a reasonable approximation is already obtained with degree `nGQ = 3` of the one-dimensional Gauss-Legendre quadrature: ```{r, product-Gauss, filter = source_drop1} par(mar = c(3,3,1,2)) polyCub.SV(hexagon, f, nGQ = 3, plot = TRUE) ``` The involved nodes (displayed in the figure above) and weights can be extracted by calling `polyCub.SV()` with `f = NULL`, e.g., to determine the number of nodes: ```{r} nrow(polyCub.SV(hexagon, f = NULL, nGQ = 3)[[1]]$nodes) ``` For illustration, we create a variant of `polyCub.SV()`, which returns the number of function evaluations as an attribute: ```{r} polyCub.SVn <- function (polyregion, f, ..., nGQ = 20) { nw <- polyCub.SV(polyregion, f = NULL, ..., nGQ = nGQ) ## nw is a list with one element per polygon of 'polyregion' res <- sapply(nw, function (x) c(result = sum(x$weights * f(x$nodes, ...)), nEval = nrow(x$nodes))) structure(sum(res["result",]), nEval = sum(res["nEval",])) } polyCub.SVn(hexagon, f, nGQ = 3) ``` We can use this function to investigate how the accuracy of the approximation depends on the degree `nGQ` and the associated number of cubature nodes: ```{r} for (nGQ in c(1:5, 10, 20)) { result <- polyCub.SVn(hexagon, f, nGQ = nGQ) cat(sprintf("nGQ = %2i: %.12f (n=%i)\n", nGQ, result, attr(result, "nEval"))) } ``` ### 2. Two-dimensional midpoint rule: `polyCub.midpoint()` The two-dimensional midpoint rule in **polyCub** is a simple wrapper around `as.im.function()` and `integral.im()` from package **spatstat.geom**. In other words, the polygon is represented by a binary pixel image and the integral is approximated as the sum of (pixel area * f(pixel midpoint)) over all pixels whose midpoint is part of the polygon. To use `polyCub.midpoint()`, we need to convert our polygon to **spatstat.geom**'s `"owin"` class: ```{r, message = FALSE} library("spatstat.geom") hexagon.owin <- owin(poly = hexagon) ``` Using a pixel size of `eps = 0.5` (here yielding 270 pixels), we obtain: ```{r, midpoint, filter = source_drop1} par(mar = c(3,3,1,3), xaxs = "i", yaxs = "i") polyCub.midpoint(hexagon.owin, f, eps = 0.5, plot = TRUE) ``` ### 3. Adaptive cubature for *isotropic* functions: `polyCub.iso()` A radially symmetric function can be expressed in terms of the distance r from its point of symmetry: f(r). If the antiderivative of r times f(r), called `intrfr()`, is analytically available, Green's theorem leads us to a cubature rule which only needs *one-dimensional* numerical integration. More specifically, `intrfr()` will be `integrate()`d along the edges of the polygon. The mathematical details are given in Meyer and Held (2014, *The Annals of Applied Statistics*, , Supplement B, Section 2.4). For the bivariate Gaussian density `f` defined above, the integral from 0 to R of `r*f(r)` is analytically available as: ```{r} intrfr <- function (R, sigma = 5) { (1 - exp(-R^2/2/sigma^2))/2/pi } ``` With this information, we can apply the cubature rule as follows: ```{r} polyCub.iso(hexagon, intrfr = intrfr, center = c(0,0)) ``` Note that we do not even need the original function `f`. If `intrfr()` is missing, it can be approximated numerically using `integrate()` for `r*f(r)` as well, but the overall integration will then be much less efficient than product Gauss cubature. Package **polyCub** exposes a C-version of `polyCub.iso()` for use by other R packages (notably [**surveillance**](https://CRAN.R-project.org/package=surveillance)) via `LinkingTo: polyCub` and `#include `. This requires the `intrfr()` function to be implemented in C as well. See for an example. ### 4. Integration of the *bivariate Gaussian density*: `polyCub.exact.Gauss()` *This cubature method is currently disabled* ([#2](https://github.com/bastistician/polyCub/issues/2)). It requires polygon triangulation originally performed using `tristrip()` from the [**gpclib**](https://github.com/rdpeng/gpclib/) package; unfortunately, it has become unavailable from mainstream repositories. Abramowitz and Stegun (1972, Section 26.9, Example 9) offer a formula for the integral of the bivariate Gaussian density over a triangle with one vertex at the origin. This formula can be used after triangulation of the polygonal domain. The core of the formula is an integral of the bivariate Gaussian density with zero mean, unit variance and some correlation over an infinite rectangle [h, Inf] x [0, Inf], which can be computed accurately using `pmvnorm()` from the [**mvtnorm**](https://CRAN.R-project.org/package=mvtnorm) package. For the above example, we obtained: ```{r, purl = FALSE, eval = USE_GPCLIB} polyCub.exact.Gauss(hexagon.owin, mean = c(0,0), Sigma = 5^2*diag(2)) ``` The required triangulation as well as the numerous calls of `pmvnorm()` make this integration algorithm quite cumbersome. For large-scale integration tasks, it is thus advisable to resort to the general-purpose product Gauss cubature rule `polyCub.SV()`. Note: **polyCub** provides an auxiliary function `circleCub.Gauss()` to calculate the integral of an *isotropic* Gaussian density over a *circular* domain (which requires nothing more than a single call of `pchisq()`). ## Benchmark We use the last result from `polyCub.exact.Gauss()` as a reference value and tune the number of cubature nodes in `polyCub.SV()` and `polyCub.midpoint()` until the absolute error is below $10^{-8}$. This leads to `nGQ = 4` for product Gauss cubature and a 1200 x 1200 pixel image for the midpoint rule. For `polyCub.iso()`, we keep the default tolerance levels of `integrate()`. For comparison, we also run `polyCub.iso()` without the analytically derived `intrfr` function, which leads to a double-`integrate` approximation. The median runtimes [ms] of the different cubature methods are given below. ```{r, benchmark, purl = FALSE, eval = DO_BENCHMARK} benchmark <- microbenchmark::microbenchmark( SV = polyCub.SV(hexagon.owin, f, nGQ = 4), midpoint = polyCub.midpoint(hexagon.owin, f, dimyx = 1200), iso = polyCub.iso(hexagon.owin, intrfr = intrfr, center = c(0,0)), iso_double_approx = polyCub.iso(hexagon.owin, f, center = c(0,0)), exact = polyCub.exact.Gauss(hexagon.owin, mean = c(0,0), Sigma = 5^2*diag(2)), times = 9, check = function (values) all(abs(unlist(values) - 0.274144773813434) < 1e-8)) ``` ```{r, purl = FALSE, eval = DO_BENCHMARK, print.args = I(list(digits = 2))} summary(benchmark, unit = "ms")[c("expr", "median")] ``` The general-purpose SV-method is the clear winner of this small competition. A disadvantage of that method is that the number of cubature nodes needs to be tuned manually. This also holds for the midpoint rule, which is by far the slowest option. In contrast, the "iso"-method for radially symmetric functions is based on R's `integrate()` function, which implements automatic tolerance levels. Furthermore, the "iso"-method can also be used with "spiky" integrands, such as a heavy-tailed power-law kernel $f(r) = (r+1)^{-2}$. ```{r, compact-PNGs, include = FALSE, purl = FALSE, eval = USE_PNGQUANT} system2("pngquant", c("--skip-if-larger", "--speed=1", "--ext=.png", "--force", "--", shQuote(litedown::get_context("plot_files")))) ``` polyCub/src/0000755000176200001440000000000015172632754012472 5ustar liggesuserspolyCub/src/polyCub.SV.h0000644000176200001440000000160113163463332014575 0ustar liggesusers/******************************************************************************* * Header file of polyCub.SV.c * * Copyright (C) 2017 Sebastian Meyer * * This file is part of the R package "polyCub", * free software under the terms of the GNU General Public License, version 2, * a copy of which is available at https://www.R-project.org/Licenses/. ******************************************************************************/ void C_polygauss( double *x, double *y, // vertex coordinates (open) of a polygon double *s_M, double *w_M, // nodes & weights of Gauss-Legendre quadrature double *s_N, double *w_N, // of degree M=N+1 and N, respectively double *alpha, // base-line int *L, int *M, int *N, // L: number of edges/vertices // result: nodes and weights of length (<=) M*N per edge double *nodes_x, double *nodes_y, double *weights); polyCub/src/init.c0000644000176200001440000000236213421646222013572 0ustar liggesusers/******************************************************************************* * Registering native routines (entry points in compiled code) * * Copyright (C) 2017,2019 Sebastian Meyer * * This file is part of the R package "polyCub", * free software under the terms of the GNU General Public License, version 2, * a copy of which is available at https://www.R-project.org/Licenses/. ******************************************************************************/ #include // for NULL #include // for SEXP types #include #include "polyCub.SV.h" #include "polyCub.iso.h" // types array (could be omitted) static R_NativePrimitiveArgType C_polygauss_t[] = { REALSXP, REALSXP, REALSXP, REALSXP, REALSXP, REALSXP, REALSXP, /*L, M, N:*/ INTSXP, INTSXP, INTSXP, /*results:*/ REALSXP, REALSXP, REALSXP }; static const R_CMethodDef CEntries[] = { {"C_polygauss", (DL_FUNC) &C_polygauss, 13, C_polygauss_t}, {NULL, NULL, 0, NULL} }; void R_init_polyCub(DllInfo *dll) { R_registerRoutines(dll, CEntries, NULL, NULL, NULL); R_useDynamicSymbols(dll, FALSE); //R_forceSymbols(dll, TRUE); // would require R >= 3.0.0 R_RegisterCCallable("polyCub", "polyiso", (DL_FUNC) &polyiso); } polyCub/src/polyCub.iso.h0000644000176200001440000000176713163463332015054 0ustar liggesusers/******************************************************************************* * Header file of polyCub.iso.c * * Copyright (C) 2017 Sebastian Meyer * * This file is part of the R package "polyCub", * free software under the terms of the GNU General Public License, version 2, * a copy of which is available at https://www.R-project.org/Licenses/. ******************************************************************************/ typedef double (*intrfr_fn) (double, double*); void polyiso( double *x, double *y, // vertex coordinates (open) int *L, // number of vertices intrfr_fn intrfr, // F(R) double *pars, // parameters for F(R) double *center_x, double *center_y, // center of isotropy int *subdivisions, double *epsabs, double *epsrel, // Rdqags options int *stop_on_error, // !=0 means to stop at first ier > 0 double *value, double *abserr, int *neval); // results polyCub/src/polyCub.SV.c0000644000176200001440000000571613163463332014603 0ustar liggesusers/******************************************************************************* * C-version of .polygauss.side() * * Copyright (C) 2014,2017 Sebastian Meyer * * This file is part of the R package "polyCub", * free software under the terms of the GNU General Public License, version 2, * a copy of which is available at https://www.R-project.org/Licenses/. ******************************************************************************/ #include "polyCub.SV.h" static void C_polygauss_side( double *x1, double *y1, double *x2, double *y2, double *s_loc, double *w_loc, double *s_N, double *w_N, double *alpha, int *loc, int *N, // lengths (loc is M=N+1 or N) // *loc * *N nodes and weights will be computed double *nodes_x, double *nodes_y, double *weights) { double half_pt_x = (*x1 + *x2) / 2.0; double half_length_x = (*x2 - *x1) / 2.0; double half_pt_y = (*y1 + *y2) / 2.0; double half_length_y = (*y2 - *y1) / 2.0; double x_gauss_side, y_gauss_side, scaling_fact_minus; int idx; for (int i = 0; i < *loc; i++) { // GAUSSIAN POINTS ON THE SIDE x_gauss_side = half_pt_x + half_length_x * s_loc[i]; y_gauss_side = half_pt_y + half_length_y * s_loc[i]; scaling_fact_minus = (x_gauss_side - *alpha) / 2.0; // COMPUTE NODES AND WEIGHTS for (int j = 0; j < *N; j++) { idx = j * *loc + i; // use same order as in R implementation nodes_x[idx] = *alpha + scaling_fact_minus * (s_N[j] + 1.0); nodes_y[idx] = y_gauss_side; weights[idx] = half_length_y*scaling_fact_minus * w_loc[i] * w_N[j]; } } } /*** * Function to be called from R to loop over all polygon edges, * calling the above C_polygauss_side() for each ***/ void C_polygauss( double *x, double *y, // vertex coordinates (open) of a polygon double *s_M, double *w_M, // nodes & weights of Gauss-Legendre quadrature double *s_N, double *w_N, // of degree M=N+1 and N, respectively double *alpha, // base-line int *L, int *M, int *N, // L: number of edges/vertices // result: nodes and weights of length (<=) M*N per edge double *nodes_x, double *nodes_y, double *weights) { int idxTo, idxBlock; double x1, y1, x2, y2; for (int i = 0; i < *L; i++) { x1 = x[i]; y1 = y[i]; if (i == *L-1) idxTo = 0; else idxTo = i+1; x2 = x[idxTo]; y2 = y[idxTo]; // if edge is on base-line or is orthogonal to it -> skip if ((x1 == *alpha && x2 == *alpha) || (y2 == y1)) continue; idxBlock = i * *M * *N; // start index of nodes of edge i if (x2 == x1) // side is parallel to base-line -> use degree N in both dimensions C_polygauss_side(&x1, &y1, &x2, &y2, s_N, w_N, s_N, w_N, alpha, N, N, nodes_x + idxBlock, nodes_y + idxBlock, weights + idxBlock); else // use degrees M and N, respectively C_polygauss_side(&x1, &y1, &x2, &y2, s_M, w_M, s_N, w_N, alpha, M, N, nodes_x + idxBlock, nodes_y + idxBlock, weights + idxBlock); } } polyCub/src/polyCub.iso.c0000644000176200001440000001171413163463332015040 0ustar liggesusers/******************************************************************************* * C-version of polyCub1.iso() * * Copyright (C) 2015,2017 Sebastian Meyer * * This file is part of the R package "polyCub", * free software under the terms of the GNU General Public License, version 2, * a copy of which is available at https://www.R-project.org/Licenses/. ******************************************************************************/ /* The corresponding math is derived in Supplement B (Section 2.4) of * Meyer and Held (2014): "Power-law models for infectious disease spread." * The Annals of Applied Statistics, 8(3), 1612-1639. * https://doi.org/10.1214/14-AOAS743SUPPB */ #include // R_FINITE, otherwise math.h would suffice #include // error #include // R_alloc #include // Rprintf #include // Rdqags // header file defines the intrfr_fn type #include "polyCub.iso.h" // integrand for the edge (x0,y0) -> (x1,y1), see Equation 7 static double lineIntegrand( double t, double x0, double y0, double x1, double y1, intrfr_fn intrfr, double *pars) { double num = y1*x0 - x1*y0; // numerator term // point on the edge corresponding to t double px = x0 + t*(x1-x0); double py = y0 + t*(y1-y0); double norm2 = px*px + py*py; // evaluate F(R) = int_0^R r*f(r) dr at R=||(px,py)|| double inti = intrfr(sqrt(norm2), pars); if (!R_FINITE(inti)) error("non-finite intrfr value at R=%f", sqrt(norm2)); return num*inti/norm2; } // set of parameters for line integration (passed via the *ex argument) typedef struct { double x0, y0, x1, y1; intrfr_fn intrfr; double *pars; } Params; // vectorized lineIntegrand for use with Rdqags static void myintegr_fn(double *x, int n, void *ex) { Params *param = (Params *) ex; for(int i = 0; i < n; i++) { x[i] = lineIntegrand(x[i], param->x0, param->y0, param->x1, param->y1, param->intrfr, param->pars); } return; } // calculate line integral for one edge (x0,y0) -> (x1,y1) // using Gauss-Kronrod quadrature via Rdqags as declared in , // implemented in R/src/appl/integrate.c, // and used in R/src/library/stats/src/integrate.c static void polyiso_side( double x0, double y0, double x1, double y1, // 2 vertices intrfr_fn intrfr, double *pars, // F(R) int subdivisions, double *epsabs, double *epsrel, // control double *result, double *abserr, int *neval, int *ier) // results { double num = y1*x0 - x1*y0; // numerator in lineIntegrand // for any point p on the edge if (num == 0.0) { // 'center' is part of this polygon edge *result = 0.0; *abserr = 0.0; //*last = 0; *neval = 0; *ier = 0; return; } // set of parameters for lineIntegrand Params param = {x0, y0, x1, y1, intrfr, pars}; // prepare for Rdqags double lower = 0.0; double upper = 1.0; int lenw = 4 * subdivisions; int last; // unused int *iwork = (int *) R_alloc((size_t) subdivisions, sizeof(int)); double *work = (double *) R_alloc((size_t) lenw, sizeof(double)); Rdqags(myintegr_fn, ¶m, &lower, &upper, epsabs, epsrel, result, abserr, neval, ier, // results &subdivisions, &lenw, &last, iwork, work); return; } // line integration along the edges of a polygon void polyiso( double *x, double *y, // vertex coordinates (open) int *L, // number of vertices intrfr_fn intrfr, // F(R) double *pars, // parameters for F(R) double *center_x, double *center_y, // center of isotropy int *subdivisions, double *epsabs, double *epsrel, // Rdqags options int *stop_on_error, // !=0 means to stop at first ier > 0 double *value, double *abserr, int *neval) // results { // auxiliary variables double resulti, abserri; int nevali, ieri; double x0, y0, x1, y1; int idxTo; // initialize result at 0 (do += for each polygon edge); *value = 0.0; *abserr = 0.0; *neval = 0; for (int i = 0; i < *L; i++) { x0 = x[i] - *center_x; y0 = y[i] - *center_y; idxTo = (i == *L-1) ? 0 : i+1; x1 = x[idxTo] - *center_x; y1 = y[idxTo] - *center_y; polyiso_side(x0, y0, x1, y1, intrfr, pars, *subdivisions, epsabs, epsrel, &resulti, &abserri, &nevali, &ieri); if (ieri > 0) { if (*stop_on_error == 0) { Rprintf("abnormal termination of integration routine (%i)\n", ieri); } else { error("abnormal termination of integration routine (%i)\n", ieri); } } *value += resulti; *abserr += abserri; *neval += nevali; } return; } polyCub/NAMESPACE0000644000176200001440000000274415167151664013131 0ustar liggesusers# Generated by roxygen2: do not edit by hand S3method(xylist,Polygon) S3method(xylist,Polygons) S3method(xylist,SpatialPolygons) S3method(xylist,default) S3method(xylist,gpc.poly) S3method(xylist,owin) S3method(xylist,sfg) export(.polyCub.iso) export(as.owin.Polygon) export(as.owin.Polygons) export(as.owin.SpatialPolygons) export(as.owin.gpc.poly) export(checkintrfr) export(circleCub.Gauss) export(gpc2owin) export(owin2gpc) export(plotpolyf) export(polyCub) export(polyCub.SV) export(polyCub.exact.Gauss) export(polyCub.iso) export(polyCub.midpoint) export(sfg2gpc) export(xylist) exportMethods(coerce) if(getRversion() >= "3.6.0") { # delayed registration S3method(spatstat.geom::as.owin, SpatialPolygons) S3method(spatstat.geom::as.owin, Polygons) S3method(spatstat.geom::as.owin, Polygon) } if(getRversion() >= "3.6.0") { # delayed registration S3method(spatstat.geom::as.owin, gpc.poly) } import(methods) importClassesFrom(sp,Polygon) importClassesFrom(sp,Polygons) importClassesFrom(sp,SpatialPolygons) importClassesFrom(sp,owin) importFrom(grDevices,extendrange) importFrom(grDevices,gray) importFrom(grDevices,heat.colors) importFrom(grDevices,xy.coords) importFrom(graphics,image) importFrom(graphics,lines) importFrom(graphics,points) importFrom(sp,coordinates) importFrom(sp,plot) importFrom(stats,cov2cor) importFrom(stats,dist) importFrom(stats,integrate) importFrom(stats,pchisq) importFrom(stats,pnorm) importMethodsFrom(sp,plot) useDynLib(polyCub, .registration = TRUE) polyCub/NEWS.md0000644000176200001440000002340615172631065013000 0ustar liggesuserspolyCub 0.9.4 (2026-04-24) ========================== * Removed obsolete `gpclibPermit()` and `gpclibPermitStatus()`: package [**gpclib**](https://github.com/rdpeng/gpclib) is no longer supported (and no longer has a restricted license anyway). polyCub 0.9.3 (2026-04-10) ========================== * **polyCub** now requires R >= 3.4.0. * `vignette("polyCub")` now uses `vignetteEngine("litedown::vignette")` (directly) rather than `"knitr::knitr"` with `markdown::html_format`. polyCub 0.9.2 (2025-02-11) ========================== * Maintenance release, updating cross references in the documentation. polyCub 0.9.1 (2024-05-21) ========================== * `vignette("polyCub")` now uses the lightweight `"knitr::knitr"` engine rather than `"knitr::rmarkdown"`. polyCub 0.9.0 (2023-10-25) ========================== * `polyCub.exact.Gauss()` is defunct. It may be resurrected in future versions, using a reliable replacement for `gpclib::tristrip()` ([#2](https://github.com/bastistician/polyCub/issues/2)). * Removed remaining references to archived packages [**gpclib**](https://CRAN.R-project.org/package=gpclib) and [**rgeos**](https://CRAN.R-project.org/package=rgeos). * **polyCub** now requires R >= 3.2.0. polyCub 0.8.1 (2022-11-25) ========================== * Accommodate CRAN checks with `_R_CHECK_DEPENDS_ONLY_=true`. polyCub 0.8.0 (2021-01-26) ========================== * Support `"(MULTI)POLYGON"` geometries from package [**sf**](https://CRAN.R-project.org/package=sf) as integration domains ([#3](https://github.com/bastistician/polyCub/issues/3)). Since these classes do not strictly enforce a particular ring direction, the vertex order is checked when the polygon coordinates are extracted for cubature. Thus, **sf** polygons are a less efficient choice for **polyCub** input than polygons from **sp** or **spatstat.geom**. Note that `"POLYGON"` objects were already accepted in previous versions of **polyCub** but this was undocumented and didn't check the vertex order. * The suggested package **spatstat** was split into several packages. Package **polyCub** now only suggests **spatstat.geom** (to handle `"owin"` polygons). polyCub 0.7.1 (2019-02-07) ========================== * Added a *getting started* `vignette("polyCub")`. * Fix minor compiler warning about missing `types` field in `R_CMethodDef` (@wrathematics, [#1](https://github.com/bastistician/polyCub/issues/1)). polyCub 0.7.0 (2018-10-11) ========================== * Package **polyCub** no longer attaches package [**sp**](https://CRAN.R-project.org/package=sp) (moved from "Depends" to "Imports"). * The R code of the examples is no longer installed by default. Use the `--example` flag of `R CMD INSTALL` to achieve that. * `README.md` now exemplifies the four different cubature rules. polyCub 0.6.1 (2017-10-02) ========================== * The exported C-function `polyCub_iso()` ... * did not handle its `stop_on_error` argument correctly (it would always stop on error). * now detects non-finite `intrfr` function values and gives an informative error message (rather than just reporting "abnormal termination of integration routine"). * Package **polyCub** no longer strictly depends on package [**spatstat**](https://CRAN.R-project.org/package=spatstat). It is only required for `polyCub.midpoint()` and for polygon input of class `"owin"`. polyCub 0.6.0 (2017-05-24) ========================== * Added full C-implementation of `polyCub.iso()`, which is exposed as `"polyCub_iso"` for use by other R packages (notably future versions of [**surveillance**](https://CRAN.R-project.org/package=surveillance)) via `LinkingTo: polyCub` and `#include `. * Accommodate CRAN checks: add missing import from **graphics**, register native routines and disable symbol search polyCub 0.5-2 (2015-02-25) ========================== * `polyCub.midpoint()` works directly with input polygons of classes `"gpc.poly"` and `"SpatialPolygons"`, since package **polyCub** now registers corresponding `as.owin`-methods. * `polyCub.exact.Gauss()` did not work if the `tristrip` of the transformed input polygon contained degenerate triangles (spotted by Ignacio Quintero). * Line integration in `polyCub.iso()` could break due to division by zero if the `center` point was part of the polygon boundary. polyCub 0.5-1 (2014-10-24) ========================== * Nodes and weights for `polyCub.SV()` were only cached up to `nGQ=59`, not 60 as announced in version 0.5-0. Fixed that which also makes examples truly run without **statmod**. * In `polyCub.SV()`, the new special setting `f=NULL` means to only compute nodes and weights. * Internal changes to the `"gpc.poly"` converters to accommodate [**spatstat**](https://CRAN.R-project.org/package=spatstat) 1.39-0. polyCub 0.5-0 (2014-05-07) ========================== * `polyCub.SV()` gained an argument `engine` to choose among available implementations. The new and faster C-implementation is the default. There should not be any numerical differences in the result of the cubature. * Package [**statmod**](https://CRAN.R-project.org/package=statmod) is no longer strictly required (imported). Nodes and weights for Gauss-Legendre quadrature in `polyCub.SV()` are now cached in the **polyCub** package up to `nGQ=60`. **statmod**`::gauss.quad` is only queried for a higher number of nodes. polyCub 0.4-3 (2014-03-14) ========================== * `polyCub.iso()` ... * could not handle additional arguments for `integrate()` given in the `control` list. * now applies the `control` arguments also to the numerical approximation of `intrfr`. * The `checkintrfr()` function is exported and documented. * Added a CITATION file. polyCub 0.4-2 (2014-02-12) ========================== * `plotpolyf()` ... * gained an additional argument `print.args`, an optional list of arguments passed to `print.trellis()` if `use.lattice=TRUE`. * passed a *data frame* of coordinates to `f` instead of a matrix as documented. polyCub 0.4-1 (2013-12-05) ========================== * This version solely fixes a missing `NAMESPACE` import to make package **polyCub** again compatible with older versions of [**spatstat**](https://CRAN.R-project.org/package=spatstat) (< 1.33-0). polyCub 0.4-0 (2013-11-19) ========================== INFRASTRUCTURE -------------- * [**rgeos**](https://CRAN.R-project.org/package=rgeos) (and therefore the GEOS library) is no longer strictly required (moved from "Imports" to "Suggests"). * Added `coerce`-methods from `"Polygons"` (or `"SpatialPolygons"` or `"Polygon"`) to `"owin"` (`as(..., "owin")`). * S4-style `coerce`-methods between `"gpc.poly"` and `"Polygons"`/`"owin"` have been removed from the package (since we no longer import the formal class `"gpc.poly"` from **gpclib** or **rgeos**). However, there are two new functions `gpc2owin` and `owin2gpc` similar to those dropped from [**spatstat**](https://CRAN.R-project.org/package=spatstat) since version 1.34-0. * Moved `discpoly()` back to [**surveillance**](https://CRAN.R-project.org/package=surveillance) since it is only used there. * The latter two changes cause [**surveillance**](https://CRAN.R-project.org/package=surveillance) version 1.6-0 to be incompatible with this new version of **polyCub**. Appropriate modifications have been made in the new version 1.7-0 of **surveillance**. SPEED-UP `polyCub.SV()` ----------------------- * thorough optimization of `polyCub.SV()`-related code resulted in about 27% speed-up: * use `mapply()` instead of a `for`-loop * avoid `cbind()` * use `tcrossprod()` * less object copying MINOR CHANGES ------------- * `xylist()` is now exported. It simply extracts polygon coordinates from various spatial classes (with same unifying intention as `xy.coords()`). * A `polyregion` of class `"SpatialPolygons"` of length more than 1 now works in `polyCub`-methods. * Use aspect ratio of 1 in `plotpolyf()`. polyCub 0.3-1 (2013-08-22) ========================== * This version solely fixes a few typos and a technical note from `R CMD check` in the current R development version (also import packages into the `NAMESPACE` which are listed in the "Depends" field). polyCub 0.3-0 (2013-07-06) ========================== * New cubature method `polyCub.iso()` specific to isotropic functions (thanks to Emil Hedevang for the basic idea). * New function `plotpolyf()` to plot a polygonal domain on top of an image of a bivariate function. * The package now depends on R >= 2.15.0 (for `.rowSums()`). * The package no longer registers `"owin"` as an S4-class since we depend on the **sp** package which does the job. This avoids a spurious warning (in `.simpleDuplicateClass()`) upon package installation. * In `discpoly()`, the argument `r` has been renamed to `radius`. This is backward compatible by partial argument matching in old code. polyCub 0.2-0 (2013-05-09) ========================== * This is the initial version of the **polyCub** package mainly built on functions previously maintained within the [**surveillance**](https://CRAN.R-project.org/package=surveillance) package. These methods for cubature of polygonal domains have been outsourced into this separate **polyCub** package since they are of general use for other packages as well. * The **polyCub** package has more documentation and tests, avoids the use of [**gpclib**](https://CRAN.R-project.org/package=gpclib) as far as possible (using [**rgeos**](https://CRAN.R-project.org/package=rgeos) instead), and solves a compatibility issue with package [**maptools**](https://CRAN.R-project.org/package=maptools) (use `setClass("owin")` instead of `setOldClass("owin")`). polyCub/inst/0000755000176200001440000000000015172632754012660 5ustar liggesuserspolyCub/inst/include/0000755000176200001440000000000013163463332014273 5ustar liggesuserspolyCub/inst/include/polyCubAPI.h0000644000176200001440000000325713163463332016422 0ustar liggesusers/******************************************************************************* * Header file with wrapper functions for the C-routines provided by polyCub * * Copyright (C) 2017 Sebastian Meyer * * This file is part of the R package "polyCub", * free software under the terms of the GNU General Public License, version 2, * a copy of which is available at https://www.R-project.org/Licenses/. ******************************************************************************/ #include // NULL #include // SEXP #include // R_GetCCallable typedef double (*intrfr_fn) (double, double*); void polyCub_iso( double *x, double *y, // vertex coordinates (open) int *L, // number of vertices intrfr_fn intrfr, // F(R) double *pars, // parameters for F(R) double *center_x, double *center_y, // center of isotropy int *subdivisions, double *epsabs, double *epsrel, // Rdqags options int *stop_on_error, // !=0 means to stop at first ier > 0 double *value, double *abserr, int *neval) // results { static void(*fun)(double*,double*,int*,intrfr_fn,double*,double*,double*, int*,double*,double*,int*,double*,double*,int*) = NULL; if (fun == NULL) fun = (void(*)(double*,double*,int*,intrfr_fn,double*,double*,double*, int*,double*,double*,int*,double*,double*,int*)) R_GetCCallable("polyCub", "polyiso"); fun(x, y, L, intrfr, pars, center_x, center_y, subdivisions, epsabs, epsrel, stop_on_error, value, abserr, neval); return; } polyCub/inst/CITATION0000644000176200001440000000053015167151503014003 0ustar liggesusersbibentry( key = "R:polyCub", bibtype = "Article", author = "Sebastian Meyer", title = "{polyCub}: An {R} package for Integration over Polygons", journal = "Journal of Open Source Software", issn = "2475-9066", year = "2019", volume = "4", number = "34", pages = "1056", doi = "10.21105/joss.01056" ) polyCub/inst/REFERENCES.R0000644000176200001440000000271215167151503014416 0ustar liggesusersbibentry( key = "meyer.held2014", bibtype = "Article", author = c(person("Sebastian", "Meyer"), person("Leonhard", "Held")), title = "Power-law models for infectious disease spread", journal = "Annals of Applied Statistics", year = "2014", volume = "8", number = "3", pages = "1612--1639", doi = "10.1214/14-AOAS743" ) bibentry( key = "sommariva.vianello2007", bibtype = "Article", author = c(person(given = "Alvise", family = "Sommariva"), person(given = "Marco", family = "Vianello")), title = "Product {Gauss} cubature over polygons based on {Green}'s integration formula", journal = "BIT Numerical Mathematics", year = "2007", volume = "47", number = "2", pages = "441--453", doi = "10.1007/s10543-007-0131-2" ) bibentry( key = "meyer2010", bibtype = "MastersThesis", author = "Sebastian Meyer", school = "Department of Statistics, LMU", title = "Spatio-Temporal Infectious Disease Epidemiology based on Point Processes", year = "2010", address = "Munich, Germany", url = "https://epub.ub.uni-muenchen.de/11703/" ) bibentry( key = "R:spatstat.geom", bibtype = "Book", title = "Spatial Point Patterns: Methodology and Applications with {R}", author = "Adrian Baddeley and Ege Rubak and Rolf Turner", year = "2015", publisher = "Chapman and Hall/CRC Press", address = "London", isbn = "9781482210200" ) polyCub/inst/doc/0000755000176200001440000000000015172632754013425 5ustar liggesuserspolyCub/inst/doc/polyCub.R0000644000176200001440000000234315172632754015167 0ustar liggesuserslibrary("polyCub") f <- function (s, sigma = 5) { exp(-rowSums(s^2)/2/sigma^2) / (2*pi*sigma^2) } hexagon <- list( list(x = c(7.33, 7.33, 3, -1.33, -1.33, 3), y = c(-0.5, 4.5, 7, 4.5, -0.5, -3)) ) plotpolyf(hexagon, f, xlim = c(-8,8), ylim = c(-8,8)) par(mar = c(3,3,1,2)) polyCub.SV(hexagon, f, nGQ = 3, plot = TRUE) nrow(polyCub.SV(hexagon, f = NULL, nGQ = 3)[[1]]$nodes) polyCub.SVn <- function (polyregion, f, ..., nGQ = 20) { nw <- polyCub.SV(polyregion, f = NULL, ..., nGQ = nGQ) ## nw is a list with one element per polygon of 'polyregion' res <- sapply(nw, function (x) c(result = sum(x$weights * f(x$nodes, ...)), nEval = nrow(x$nodes))) structure(sum(res["result",]), nEval = sum(res["nEval",])) } polyCub.SVn(hexagon, f, nGQ = 3) for (nGQ in c(1:5, 10, 20)) { result <- polyCub.SVn(hexagon, f, nGQ = nGQ) cat(sprintf("nGQ = %2i: %.12f (n=%i)\n", nGQ, result, attr(result, "nEval"))) } library("spatstat.geom") hexagon.owin <- owin(poly = hexagon) par(mar = c(3,3,1,3), xaxs = "i", yaxs = "i") polyCub.midpoint(hexagon.owin, f, eps = 0.5, plot = TRUE) intrfr <- function (R, sigma = 5) { (1 - exp(-R^2/2/sigma^2))/2/pi } polyCub.iso(hexagon, intrfr = intrfr, center = c(0,0)) polyCub/inst/doc/polyCub.Rmd0000644000176200001440000002762515172466713015522 0ustar liggesusers--- title: "Getting started with 'polyCub'" author: "Sebastian Meyer" date: "`{r} Sys.Date()`" lang: "en" ## litedown:::add_citation() does not currently support R citation files ... #bibliography: '`{r} system.file("REFERENCES.R", package = "polyCub", mustWork = TRUE)`' vignette: > %\VignetteIndexEntry{Getting started with 'polyCub'} %\VignetteEngine{litedown::vignette} %\VignetteDepends{polyCub, spatstat.geom} output: html: meta: js: ["@center-img"] --- ```{r, setup, include = FALSE, purl = FALSE} litedown::reactor(collapse = TRUE, fig.width = 4, fig.height = 3.5, dev.args = list(units = "in", res = 72)) ## kludge: achieve 'echo = -1' by filtering a chunk's "xfun_record_results" source_drop1 <- function (res) replace(res, 1, list(`attributes<-`(res[[1L]][-1], attributes(res[[1]])))) ## maintainer-mode options for building the vignette: USE_GPCLIB <- identical(Sys.getenv("R_GPCLIBPERMIT"), "true") && requireNamespace("gpclib") # unavailable in --as-cran checks DO_BENCHMARK <- USE_PNGQUANT <- identical(Sys.getenv("NOT_CRAN"), "true") if (DO_BENCHMARK) stopifnot(requireNamespace("microbenchmark"), USE_GPCLIB) if (USE_PNGQUANT) stopifnot(nzchar(Sys.which("pngquant"))) ``` The R package **polyCub** implements *cubature* (numerical integration) over *polygonal* domains. It solves the problem of integrating a continuously differentiable function f(x,y) over simple closed polygons. For the special case of a rectangular domain along the axes, the package [**cubature**](https://CRAN.R-project.org/package=cubature) is more appropriate (cf. [`CRAN Task View: Numerical Mathematics`](https://CRAN.R-project.org/view=NumericalMathematics)). ## Polygon representations The integration domain is described by a polygonal boundary (or multiple polygons, including holes). Various R packages for spatial data analysis provide classes for polygons. The implementations differ in vertex order (which direction represents a hole) and if the first vertex is repeated. All of **polyCub**'s cubature methods understand * `"owin"` from package [**spatstat.geom**](https://CRAN.R-project.org/package=spatstat.geom), * `"gpc.poly"` from [**gpclib**](https://github.com/rdpeng/gpclib/), * `"SpatialPolygons"` from package [**sp**](https://CRAN.R-project.org/package=sp), and * `"(MULTI)POLYGON"` from package [**sf**](https://CRAN.R-project.org/package=sf). Internally, **polyCub** uses its auxiliary `xylist()` function to extract a plain list of lists of vertex coordinates from these classes, such that vertices are ordered anticlockwise (for exterior boundaries) and the first vertex is not repeated (i.e., the `"owin"` convention). ## Cubature methods The following cubature methods are implemented in **polyCub**: 1. `polyCub.SV()`: Product Gauss cubature 2. `polyCub.midpoint()`: Two-dimensional midpoint rule 3. `polyCub.iso()`: Adaptive cubature for radially symmetric functions $f(x,y) = f_r(\lVert(x-x_0,y-y_0)\rVert)$ 4. `polyCub.exact.Gauss()` (*currently disabled*): Accurate integration of the bivariate Gaussian density The following section details and illustrates the different cubature methods. ## Illustrations ```{r} library("polyCub") ``` We consider the integration of a function f(x,y) which all of the above cubature methods can handle: an isotropic zero-mean Gaussian density. **polyCub** expects the integrand f to take a two-column coordinate matrix as its first argument (as opposed to separate arguments for the x and y coordinates), so: ```{r, example-f} f <- function (s, sigma = 5) { exp(-rowSums(s^2)/2/sigma^2) / (2*pi*sigma^2) } ``` We use a simple hexagon as polygonal integration domain, here specified via an `"xylist"` of vertex coordinates: ```{r, example-polygon} hexagon <- list( list(x = c(7.33, 7.33, 3, -1.33, -1.33, 3), y = c(-0.5, 4.5, 7, 4.5, -0.5, -3)) ) ``` An image of the function and the integration domain can be produced using **polyCub**'s rudimentary (but convenient) plotting utility: ```{r, example} plotpolyf(hexagon, f, xlim = c(-8,8), ylim = c(-8,8)) ``` ### 1. Product Gauss cubature: `polyCub.SV()` The **polyCub** package provides an R-interfaced C-translation of `polygauss.m`, an algorithm by Sommariva and Vianello (2007, *BIT Numerical Mathematics*, ). The cubature rule is based on Green's integration formula and incorporates appropriately transformed weights and nodes of one-dimensional Gauss-Legendre quadrature in both dimensions, thus the name "product Gauss cubature". It is exact for all bivariate polynomials if the number of cubature nodes is sufficiently large (depending on the degree of the polynomial). For the above example, a reasonable approximation is already obtained with degree `nGQ = 3` of the one-dimensional Gauss-Legendre quadrature: ```{r, product-Gauss, filter = source_drop1} par(mar = c(3,3,1,2)) polyCub.SV(hexagon, f, nGQ = 3, plot = TRUE) ``` The involved nodes (displayed in the figure above) and weights can be extracted by calling `polyCub.SV()` with `f = NULL`, e.g., to determine the number of nodes: ```{r} nrow(polyCub.SV(hexagon, f = NULL, nGQ = 3)[[1]]$nodes) ``` For illustration, we create a variant of `polyCub.SV()`, which returns the number of function evaluations as an attribute: ```{r} polyCub.SVn <- function (polyregion, f, ..., nGQ = 20) { nw <- polyCub.SV(polyregion, f = NULL, ..., nGQ = nGQ) ## nw is a list with one element per polygon of 'polyregion' res <- sapply(nw, function (x) c(result = sum(x$weights * f(x$nodes, ...)), nEval = nrow(x$nodes))) structure(sum(res["result",]), nEval = sum(res["nEval",])) } polyCub.SVn(hexagon, f, nGQ = 3) ``` We can use this function to investigate how the accuracy of the approximation depends on the degree `nGQ` and the associated number of cubature nodes: ```{r} for (nGQ in c(1:5, 10, 20)) { result <- polyCub.SVn(hexagon, f, nGQ = nGQ) cat(sprintf("nGQ = %2i: %.12f (n=%i)\n", nGQ, result, attr(result, "nEval"))) } ``` ### 2. Two-dimensional midpoint rule: `polyCub.midpoint()` The two-dimensional midpoint rule in **polyCub** is a simple wrapper around `as.im.function()` and `integral.im()` from package **spatstat.geom**. In other words, the polygon is represented by a binary pixel image and the integral is approximated as the sum of (pixel area * f(pixel midpoint)) over all pixels whose midpoint is part of the polygon. To use `polyCub.midpoint()`, we need to convert our polygon to **spatstat.geom**'s `"owin"` class: ```{r, message = FALSE} library("spatstat.geom") hexagon.owin <- owin(poly = hexagon) ``` Using a pixel size of `eps = 0.5` (here yielding 270 pixels), we obtain: ```{r, midpoint, filter = source_drop1} par(mar = c(3,3,1,3), xaxs = "i", yaxs = "i") polyCub.midpoint(hexagon.owin, f, eps = 0.5, plot = TRUE) ``` ### 3. Adaptive cubature for *isotropic* functions: `polyCub.iso()` A radially symmetric function can be expressed in terms of the distance r from its point of symmetry: f(r). If the antiderivative of r times f(r), called `intrfr()`, is analytically available, Green's theorem leads us to a cubature rule which only needs *one-dimensional* numerical integration. More specifically, `intrfr()` will be `integrate()`d along the edges of the polygon. The mathematical details are given in Meyer and Held (2014, *The Annals of Applied Statistics*, , Supplement B, Section 2.4). For the bivariate Gaussian density `f` defined above, the integral from 0 to R of `r*f(r)` is analytically available as: ```{r} intrfr <- function (R, sigma = 5) { (1 - exp(-R^2/2/sigma^2))/2/pi } ``` With this information, we can apply the cubature rule as follows: ```{r} polyCub.iso(hexagon, intrfr = intrfr, center = c(0,0)) ``` Note that we do not even need the original function `f`. If `intrfr()` is missing, it can be approximated numerically using `integrate()` for `r*f(r)` as well, but the overall integration will then be much less efficient than product Gauss cubature. Package **polyCub** exposes a C-version of `polyCub.iso()` for use by other R packages (notably [**surveillance**](https://CRAN.R-project.org/package=surveillance)) via `LinkingTo: polyCub` and `#include `. This requires the `intrfr()` function to be implemented in C as well. See for an example. ### 4. Integration of the *bivariate Gaussian density*: `polyCub.exact.Gauss()` *This cubature method is currently disabled* ([#2](https://github.com/bastistician/polyCub/issues/2)). It requires polygon triangulation originally performed using `tristrip()` from the [**gpclib**](https://github.com/rdpeng/gpclib/) package; unfortunately, it has become unavailable from mainstream repositories. Abramowitz and Stegun (1972, Section 26.9, Example 9) offer a formula for the integral of the bivariate Gaussian density over a triangle with one vertex at the origin. This formula can be used after triangulation of the polygonal domain. The core of the formula is an integral of the bivariate Gaussian density with zero mean, unit variance and some correlation over an infinite rectangle [h, Inf] x [0, Inf], which can be computed accurately using `pmvnorm()` from the [**mvtnorm**](https://CRAN.R-project.org/package=mvtnorm) package. For the above example, we obtained: ```{r, purl = FALSE, eval = USE_GPCLIB} polyCub.exact.Gauss(hexagon.owin, mean = c(0,0), Sigma = 5^2*diag(2)) ``` The required triangulation as well as the numerous calls of `pmvnorm()` make this integration algorithm quite cumbersome. For large-scale integration tasks, it is thus advisable to resort to the general-purpose product Gauss cubature rule `polyCub.SV()`. Note: **polyCub** provides an auxiliary function `circleCub.Gauss()` to calculate the integral of an *isotropic* Gaussian density over a *circular* domain (which requires nothing more than a single call of `pchisq()`). ## Benchmark We use the last result from `polyCub.exact.Gauss()` as a reference value and tune the number of cubature nodes in `polyCub.SV()` and `polyCub.midpoint()` until the absolute error is below $10^{-8}$. This leads to `nGQ = 4` for product Gauss cubature and a 1200 x 1200 pixel image for the midpoint rule. For `polyCub.iso()`, we keep the default tolerance levels of `integrate()`. For comparison, we also run `polyCub.iso()` without the analytically derived `intrfr` function, which leads to a double-`integrate` approximation. The median runtimes [ms] of the different cubature methods are given below. ```{r, benchmark, purl = FALSE, eval = DO_BENCHMARK} benchmark <- microbenchmark::microbenchmark( SV = polyCub.SV(hexagon.owin, f, nGQ = 4), midpoint = polyCub.midpoint(hexagon.owin, f, dimyx = 1200), iso = polyCub.iso(hexagon.owin, intrfr = intrfr, center = c(0,0)), iso_double_approx = polyCub.iso(hexagon.owin, f, center = c(0,0)), exact = polyCub.exact.Gauss(hexagon.owin, mean = c(0,0), Sigma = 5^2*diag(2)), times = 9, check = function (values) all(abs(unlist(values) - 0.274144773813434) < 1e-8)) ``` ```{r, purl = FALSE, eval = DO_BENCHMARK, print.args = I(list(digits = 2))} summary(benchmark, unit = "ms")[c("expr", "median")] ``` The general-purpose SV-method is the clear winner of this small competition. A disadvantage of that method is that the number of cubature nodes needs to be tuned manually. This also holds for the midpoint rule, which is by far the slowest option. In contrast, the "iso"-method for radially symmetric functions is based on R's `integrate()` function, which implements automatic tolerance levels. Furthermore, the "iso"-method can also be used with "spiky" integrands, such as a heavy-tailed power-law kernel $f(r) = (r+1)^{-2}$. ```{r, compact-PNGs, include = FALSE, purl = FALSE, eval = USE_PNGQUANT} system2("pngquant", c("--skip-if-larger", "--speed=1", "--ext=.png", "--force", "--", shQuote(litedown::get_context("plot_files")))) ``` polyCub/inst/doc/polyCub.html0000644000176200001440000015254515172632754015744 0ustar liggesusers Getting started with ‘polyCub’

Getting started with ‘polyCub’

Sebastian Meyer

2026-04-24

The R package polyCub implements cubature (numerical integration) over polygonal domains. It solves the problem of integrating a continuously differentiable function f(x,y) over simple closed polygons.

For the special case of a rectangular domain along the axes, the package cubature is more appropriate (cf. CRAN Task View: Numerical Mathematics).

Polygon representations

The integration domain is described by a polygonal boundary (or multiple polygons, including holes). Various R packages for spatial data analysis provide classes for polygons. The implementations differ in vertex order (which direction represents a hole) and if the first vertex is repeated.

All of polyCub’s cubature methods understand

  • "owin" from package spatstat.geom,

  • "gpc.poly" from gpclib,

  • "SpatialPolygons" from package sp, and

  • "(MULTI)POLYGON" from package sf.

Internally, polyCub uses its auxiliary xylist() function to extract a plain list of lists of vertex coordinates from these classes, such that vertices are ordered anticlockwise (for exterior boundaries) and the first vertex is not repeated (i.e., the "owin" convention).

Cubature methods

The following cubature methods are implemented in polyCub:

  1. polyCub.SV(): Product Gauss cubature

  2. polyCub.midpoint(): Two-dimensional midpoint rule

  3. polyCub.iso(): Adaptive cubature for radially symmetric functions \(f(x,y) = f_r(\lVert(x-x_0,y-y_0)\rVert)\)

  4. polyCub.exact.Gauss() (currently disabled): Accurate integration of the bivariate Gaussian density

The following section details and illustrates the different cubature methods.

Illustrations

library("polyCub")

We consider the integration of a function f(x,y) which all of the above cubature methods can handle: an isotropic zero-mean Gaussian density. polyCub expects the integrand f to take a two-column coordinate matrix as its first argument (as opposed to separate arguments for the x and y coordinates), so:

f <- function (s, sigma = 5)
{
    exp(-rowSums(s^2)/2/sigma^2) / (2*pi*sigma^2)
}

We use a simple hexagon as polygonal integration domain, here specified via an "xylist" of vertex coordinates:

hexagon <- list(
    list(x = c(7.33, 7.33, 3, -1.33, -1.33, 3),
         y = c(-0.5, 4.5, 7, 4.5, -0.5, -3))
)

An image of the function and the integration domain can be produced using polyCub’s rudimentary (but convenient) plotting utility:

plotpolyf(hexagon, f, xlim = c(-8,8), ylim = c(-8,8))

1. Product Gauss cubature: polyCub.SV()

The polyCub package provides an R-interfaced C-translation of polygauss.m, an algorithm by Sommariva and Vianello (2007, BIT Numerical Mathematics, https://doi.org/10.1007/s10543-007-0131-2). The cubature rule is based on Green’s integration formula and incorporates appropriately transformed weights and nodes of one-dimensional Gauss-Legendre quadrature in both dimensions, thus the name “product Gauss cubature”. It is exact for all bivariate polynomials if the number of cubature nodes is sufficiently large (depending on the degree of the polynomial).

For the above example, a reasonable approximation is already obtained with degree nGQ = 3 of the one-dimensional Gauss-Legendre quadrature:

polyCub.SV(hexagon, f, nGQ = 3, plot = TRUE)
#> [1] 0.2741456

The involved nodes (displayed in the figure above) and weights can be extracted by calling polyCub.SV() with f = NULL, e.g., to determine the number of nodes:

nrow(polyCub.SV(hexagon, f = NULL, nGQ = 3)[[1]]$nodes)
#> [1] 72

For illustration, we create a variant of polyCub.SV(), which returns the number of function evaluations as an attribute:

polyCub.SVn <- function (polyregion, f, ..., nGQ = 20) {
    nw <- polyCub.SV(polyregion, f = NULL, ..., nGQ = nGQ)
    ## nw is a list with one element per polygon of 'polyregion'
    res <- sapply(nw, function (x)
        c(result = sum(x$weights * f(x$nodes, ...)), nEval = nrow(x$nodes)))
    structure(sum(res["result",]), nEval = sum(res["nEval",]))
}
polyCub.SVn(hexagon, f, nGQ = 3)
#> [1] 0.2741456
#> attr(,"nEval")
#> [1] 72

We can use this function to investigate how the accuracy of the approximation depends on the degree nGQ and the associated number of cubature nodes:

for (nGQ in c(1:5, 10, 20)) {
    result <- polyCub.SVn(hexagon, f, nGQ = nGQ)
    cat(sprintf("nGQ = %2i: %.12f (n=%i)\n", nGQ, result, attr(result, "nEval")))
}
#> nGQ =  1: 0.285265369245 (n=12)
#> nGQ =  2: 0.274027610314 (n=36)
#> nGQ =  3: 0.274145638288 (n=72)
#> nGQ =  4: 0.274144768964 (n=120)
#> nGQ =  5: 0.274144773834 (n=180)
#> nGQ = 10: 0.274144773813 (n=660)
#> nGQ = 20: 0.274144773813 (n=2520)

2. Two-dimensional midpoint rule: polyCub.midpoint()

The two-dimensional midpoint rule in polyCub is a simple wrapper around as.im.function() and integral.im() from package spatstat.geom. In other words, the polygon is represented by a binary pixel image and the integral is approximated as the sum of (pixel area * f(pixel midpoint)) over all pixels whose midpoint is part of the polygon.

To use polyCub.midpoint(), we need to convert our polygon to spatstat.geom’s "owin" class:

library("spatstat.geom")
hexagon.owin <- owin(poly = hexagon)

Using a pixel size of eps = 0.5 (here yielding 270 pixels), we obtain:

polyCub.midpoint(hexagon.owin, f, eps = 0.5, plot = TRUE)
#> [1] 0.2736067

3. Adaptive cubature for isotropic functions: polyCub.iso()

A radially symmetric function can be expressed in terms of the distance r from its point of symmetry: f(r). If the antiderivative of r times f(r), called intrfr(), is analytically available, Green’s theorem leads us to a cubature rule which only needs one-dimensional numerical integration. More specifically, intrfr() will be integrate()d along the edges of the polygon. The mathematical details are given in Meyer and Held (2014, The Annals of Applied Statistics, https://doi.org/10.1214/14-AOAS743, Supplement B, Section 2.4).

For the bivariate Gaussian density f defined above, the integral from 0 to R of r*f(r) is analytically available as:

intrfr <- function (R, sigma = 5)
{
    (1 - exp(-R^2/2/sigma^2))/2/pi
}

With this information, we can apply the cubature rule as follows:

polyCub.iso(hexagon, intrfr = intrfr, center = c(0,0))
#> [1] 0.2741448
#> attr(,"abs.error")
#> [1] 3.043618e-15

Note that we do not even need the original function f.

If intrfr() is missing, it can be approximated numerically using integrate() for r*f(r) as well, but the overall integration will then be much less efficient than product Gauss cubature.

Package polyCub exposes a C-version of polyCub.iso() for use by other R packages (notably surveillance) via LinkingTo: polyCub and #include <polyCubAPI.h>. This requires the intrfr() function to be implemented in C as well. See https://github.com/bastistician/polyCub/blob/master/tests/polyiso_powerlaw.c for an example.

4. Integration of the bivariate Gaussian density: polyCub.exact.Gauss()

This cubature method is currently disabled (#2). It requires polygon triangulation originally performed using tristrip() from the gpclib package; unfortunately, it has become unavailable from mainstream repositories.

Abramowitz and Stegun (1972, Section 26.9, Example 9) offer a formula for the integral of the bivariate Gaussian density over a triangle with one vertex at the origin. This formula can be used after triangulation of the polygonal domain. The core of the formula is an integral of the bivariate Gaussian density with zero mean, unit variance and some correlation over an infinite rectangle [h, Inf] x [0, Inf], which can be computed accurately using pmvnorm() from the mvtnorm package.

For the above example, we obtained:

polyCub.exact.Gauss(hexagon.owin, mean = c(0,0), Sigma = 5^2*diag(2))
#> [1] 0.2741448
#> attr(,"nEval")
#> [1] 48
#> attr(,"error")
#> [1] 4.6e-14

The required triangulation as well as the numerous calls of pmvnorm() make this integration algorithm quite cumbersome. For large-scale integration tasks, it is thus advisable to resort to the general-purpose product Gauss cubature rule polyCub.SV().

Note: polyCub provides an auxiliary function circleCub.Gauss() to calculate the integral of an isotropic Gaussian density over a circular domain (which requires nothing more than a single call of pchisq()).

Benchmark

We use the last result from polyCub.exact.Gauss() as a reference value and tune the number of cubature nodes in polyCub.SV() and polyCub.midpoint() until the absolute error is below \(10^{-8}\). This leads to nGQ = 4 for product Gauss cubature and a 1200 x 1200 pixel image for the midpoint rule. For polyCub.iso(), we keep the default tolerance levels of integrate(). For comparison, we also run polyCub.iso() without the analytically derived intrfr function, which leads to a double-integrate approximation.

The median runtimes [ms] of the different cubature methods are given below.

benchmark <- microbenchmark::microbenchmark(
  SV = polyCub.SV(hexagon.owin, f, nGQ = 4),
  midpoint = polyCub.midpoint(hexagon.owin, f, dimyx = 1200),
  iso = polyCub.iso(hexagon.owin, intrfr = intrfr, center = c(0,0)),
  iso_double_approx = polyCub.iso(hexagon.owin, f, center = c(0,0)),
  exact = polyCub.exact.Gauss(hexagon.owin, mean = c(0,0), Sigma = 5^2*diag(2)),
  times = 9,
  check = function (values) all(abs(unlist(values) - 0.274144773813434) < 1e-8))

summary(benchmark, unit = "ms")[c("expr", "median")]
expr median
SV 0.08
midpoint 165.51
iso 0.29
iso_double_approx 3.89
exact 7.02

The general-purpose SV-method is the clear winner of this small competition. A disadvantage of that method is that the number of cubature nodes needs to be tuned manually. This also holds for the midpoint rule, which is by far the slowest option. In contrast, the “iso”-method for radially symmetric functions is based on R’s integrate() function, which implements automatic tolerance levels. Furthermore, the “iso”-method can also be used with “spiky” integrands, such as a heavy-tailed power-law kernel \(f(r) = (r+1)^{-2}\).

polyCub/README.md0000644000176200001440000000625514623074317013165 0ustar liggesusers # polyCub The [R](https://www.R-project.org/) package **polyCub** implements *cubature* (numerical integration) over *polygonal* domains. It solves the problem of integrating a continuously differentiable function f(x,y) over simple closed polygons. For the special case of a rectangular domain along the axes, the [**cubature**](https://CRAN.R-project.org/package=cubature) package is more appropriate (cf. [`CRAN Task View: Numerical Mathematics`](https://CRAN.R-project.org/view=NumericalMathematics)). ## Installation You can install [polyCub from CRAN](https://CRAN.R-project.org/package=polyCub) via: ```R install.packages("polyCub") ``` To install the development version from the [GitHub repository](https://github.com/bastistician/polyCub), use: ```R ## install.packages("remotes") remotes::install_github("bastistician/polyCub") ``` ## Usage The basic usage is: ```r library("polyCub") polyCub(polyregion, f) ``` * `polyregion` represents the integration domain as an object of class `"owin"` (from **spatstat.geom**), `"gpc.poly"` (from **gpclib**), `"SpatialPolygons"` (from **sp**), or `"(MULTI)POLYGON"` (from **sf**), or even as a plain list of lists of vertex coordinates (`"xylist"`). * `f` is the integrand and needs to take a two-column coordinate matrix as its first argument. The `polyCub()` function wraps the implemented cubature methods and by default calls `polyCub.SV()`, a C-implementation of *product Gauss cubature*. Directly calling the desired cubature function is preferable, see the list below. ### Implemented cubature methods 1. `polyCub.SV()`: General-purpose **product Gauss cubature** (Sommariva and Vianello, 2007, *BIT Numerical Mathematics*, ) 2. `polyCub.midpoint()`: Simple **two-dimensional midpoint rule** based on [**spatstat.geom**](https://CRAN.R-project.org/package=spatstat.geom)`::as.im.function()` 3. `polyCub.iso()`: Adaptive **cubature for radially symmetric functions** via line `integrate()` along the polygon boundary (Meyer and Held, 2014, *The Annals of Applied Statistics*, , Supplement B, Section 2.4) For details and illustrations see the `vignette("polyCub")` in the installed package or [on CRAN](https://CRAN.R-project.org/package=polyCub/vignettes/polyCub.html). ## Applications The **polyCub** package evolved from the need to integrate so-called spatial interaction functions (Gaussian or power-law kernels) over the observation region of a spatio-temporal point process. Such epidemic models are implemented in [**surveillance**](https://CRAN.R-project.org/package=surveillance). ## Feedback Contributions are welcome! Please submit suggestions or report bugs at or via e-mail to `maintainer("polyCub")`. ## License The **polyCub** package is free and open source software, licensed under the GPLv2. polyCub/build/0000755000176200001440000000000015172632754013002 5ustar liggesuserspolyCub/build/vignette.rds0000644000176200001440000000035315172632754015342 0ustar liggesusersePM0 -&& 7n 딩$|j7ZtK֭{}ۻiQ4jx(9m LpTev[^6OXiiq5oS" =]0X]t@HeOQ!r0;,4מ2^[[=gƌLbuն_.۰a}“&Ex~1polyCub/build/partial.rdb0000644000176200001440000007164715172632750015142 0ustar liggesusersywI'REIԑ%%()JbJQL]I*kؕdtdD@S}Q3suI {wz{ԺEp=/C?#r0>c^"^sWjo6sVujVu|fl>4%'w)_>=Z뜍SI5_eo{ej߾~ހU-:%ίA߮XoVj郅//M÷E zˢ:hgU5+V; ~6|OƗvTU^=>^sۋY/nl O̺ۥԷUj+21?vY7œJCߞپ׏~ cC*[g^rUMv̮e8np_k0-v}hxXvibsx 9'ATa.aW-vS x>;<ZbK=jmK(w3j%*xRRշ6pq֙i%]fY .۬Vճm漱\Y/.{TL(τ UmC_ GQ}ŗs"f\m",7ˬWb# jS̍8Չn o Ee`% ģFu I%_X@s*K'7M6Š`GAO}P+:@@tӯ;2{c:Ui2 VXA!4TjtBmjt  Y% ģ*_޴=^ih[^8]Dn/3Iti0=h&cL#I(ta0l3E³ϦZ?TJ= <yќ^}QG4- yL]/Fvj,iOKW'R49N)n.'AOjX)a`[lKvpbk hm7iCIBC֢Z=$gCPk_jE> YgQ7AfQqׁgEw*GU'.[,v-3j=-ZiW~.ZIsPsFl^t ڵzR6ǟ-[׊|u3ɱL=^xh<g§zunέ;.+65[.L$+/,.Lh砟6TԊYtvVQZ{q.* +QgkM|fkVh.ݱ1%!.ģ8He#TRna y5p@"Zp/9^M+[J{-Zri4,˲^YYeMtM\+)Sue7mi9#F .軩 fcMa蜄ZDàiM/%lwS!?㰲nX/ Ƨv,n,i-$kgIoѲ#GRlٮ~Pl?8ק!h儶>ɛ,TI)ЧR~UB gPv[GYnE/f'sSc9Ogofr7h+$-з'D>S)*QanY/7Yfutekéefj֮4r8<(]dC\.MUZ7YO\P4|XzM)t5ĕʮ7ߙjygtu34ӑs:˺܊]_x5he3|nE ˩d;6 Ŭ| cvLF=_{{ CLsU/;\Ҍ {hy0Ă,D̷4\  Ś* @zI>hln9V]=ݻ;N#O&[j>B[DŽhiieI,2NپyjVKk=Mn}]cذ^hc۳O\ɑ_-\k ^R٪6{&{yOAw0X=d) kqHx<=;;9ukjQ)Ɩ/V@klVG5nasCF{XRzvX$9% 0h%S,ԁ--%ZpMc*xRI?-mS$`=pqXBŏGG2fPmHi't(TQ|v{iH*_o׬f){żw \ olmƛZvY4%Β7;S,PD6L-/ Z8k|15熛]~_E$,᥶«`Fv(sjKJ27_:_lat7Q`caCŴ {4bb}}Ƌ^_].}+\6%Q۪\roy@̗sn]v_;~wlhoN,?ͩ_X÷KvJ]OfSVRhbcxAĽ*UYҎeN5FZ08۴&XV zduVC4:UAt5t߬XiHQgw^;N[^[]ՅG*Iu[6:u^*R{IjL>v~Hqub_冂ne&") x1K/ovAsrii8QqE^qMw\{cUD:٩[|_71Fwkta)4 *b(88y.w( ST9ȉix2gϹZaU&0>tp4iFiHt̒vHxhw6ʗh@Oh:DX`X h{h)ttXW}ԟ7=ji}OijZZҫK/_ZB!=CZk6' X+&R B[r/ƄWS ;z?` %2[G"?7+%9/˹`!ěD%Х$Uur >'`F O_8|BU!9IΔmk?d%:zݺ$lo ޛ$M&\dW)=`#4N)J5Ŗx KOJR96$1Cf~`L6M$&mq}?-iFLu RŖMLWO ؖMS6[^jܼVKv!ZiHURBhl[ZVdģ(a]vt'l}#E΢H(=8[v4Dv+dTi03F˹zm$d: < S񥆧vcK= <dMgCv*i.;pp@\N&џS3N 4U""m efPVhY!$h[XI^0XJQt"@NNe4Jx+keѸ ݵƆj[a(ŰQQA.a^wegF/9Sɓ=(~]MƼ"IC"JµS(z/$=σV2L(G]@_H؄(GCxEoN/ gtGU\|$|x_ScNT/a.$#>@RTI-G.z9цk1 oljgjbVBUw c5-$NO՗c՝T.#~;N+5v *.Kx OZ- Z-5!Vz&~zn%Lrۡ p3jפۺ_j#[2%魸S RBRㄌ>c=YP<-+vU_(d{\G\<'="JTU(ʐYշOWB$3mȷٯ6傿Kvr*!nzYvH,bKx mq 2 ]bɔ&ZܰJ!Z|cǺ25|=h 9 <jE:xtڜ0$ e ^Suש0'AO*?T/xJhˎ^)觲r7a߻PHXP햄Z.. ˯d^zR)4,ir(=^_&yN ]ߤَ#ˤ pݘUP R@i){`JVα}@uݭZ./tݗIuRY_f[L皏Z}'QȗI, Gs@{K3(Ѹ܅}GXOOT\?KgQԒA]%6Fģ*JfͷX͓mO7"׼qSj>\fvb]l䭔u=6)tS&;~H Gol!D.|:8":_/?m&:/a= /IQbEb/Now7qgf٩nw/³lͩWK-ۍQ=9e la*m槕z ؃[ sLBwǜGw%=bC|oW֠qcZuFZֱ-5aN <0OTa?~zOz;)&i‘utYw͈|v5s|f>$j1PGGP_\DKD*7ؚk[LL4k:جk]YlgsV!LFy\cEv=c~0pŌ#7%W7F՞^g_1JYгRT-mJ.)\Q-:~msf{n|X[臑&yJ<+TI`t=;=* pDdȪ/2=5XͲkuyeg=qa ɣPek6$]ߘMl9Dhm>Ǡ^ e*sJU)*)phc|ٲXnkAc%ۣ(%fzdH2}thfW)FR fnEtT.h?ѣDNaB:Nq1|67ϪMEV9ӮS\"DžF| m\>]5bR,[VڃNꩉɉ"Gta*igZߥ[ϾL[XUȨT3v?ec㢌GCZx^wKMp';33:KhzxG襫ZoK%I{Ӫjb2G[K tEB<9 9J\Ɇz`tzc!pGɑtаP=Rx*C`͵h#@58p (b0^Ev xI͖&!gvVd=סZ..KH"MIgG68^t>RqCnϋI/kABpJ`3yҸ~jZ<ݝc UR3uK[5-M݉]]tZ] ^ʩ[g/kVu˔]a%z#dG\UK=Pvzf,&'n((~ztieu3gbvaLN&yێy jLJFo90;:TKn7:+?Uk)FI|,gg@ir:ɥ-?l.?P]8tTΨ, a:@`Ј1$>.CJY)2 ImۆQqCh4Zd@QA3EGs6Iou)n"T Nq`hua8j0R ,jf٥d{wOeRV| -5a!B[GEa5kG(r)H8-bׯ(L߷ܪ7Ǟ N"jsm&[ޭȭm#kcYf<^q˱gNp;_Zyݹu۔SSSX]aO }lZe/O3|Y<ɜsehc3ܞRu==]G5dUЈ#G-:iQ HσdtMVt^ u{]$9^9r(VUҡU-[ـVw˽?L8'eM4}ɘ5ݱOͅqivfr,7_6X)p ưWs-kn`xzoe|Džj,:2_4MݏJR^HꮠȤpt;8SS]^5jT(LNMΌO^.ܚN{wqkDoHTK:V+sJnS1IAnrm|:MSJM?U[+O㓫 Wt$dJ2kG_5ӣ?'ĭu+)Ջ~!n1^skYϽF+zUzk^\hsߴ*'7s#GO} GSc9633ܜQ8Cko>{7gOLNO:& _ 3ɚђ')ѭKݝ>bOJ:ڰBLS@<N]>(suٙG8Ԍ4gz1Rg@)Յ?' ^q-R`c Bz5HBw4~,e%bU!dk0 ]YQqO6gpy;S L| \}^ʚ r?8D8[:Uź\@RVA̤n|@S$Ul\Jz vҧTKp0Ňnmf-M%XqSS |K/D~Z zEqfyNniҳmtl>]vahk| ijk`JZҿjMMh*U/*+Iꦣ00T^ackk6 =^1[$!_Ѵ \@<)%ߺز؛f= !-3)Jηr\i ^K~(;Ax4eٱDrl= BU|Dڦ>{0wbCKs1aW-Xf1c24`") aSY5T@m %NC CICI~ !!C : 3:ÇЗ-::&^]}Iegj:"dF#jjo3_em |ς>w7/?l*JF@ ?vI#@lpє5.3Ӓz v8 ZH-TUлiALj0]klF;$gA+- ^m|`*Tax)l-зvFo P.th*/vCKۡ{2sMO>{Vw""heM7@B ]8|)oBwr 'RNS[wK6X^W!q(19t{(ǂx)nt j ,~vZ91c[VQv'V_~,k gث~ ɶ".`{[jJy? 7oލ أv$T;<7/`7Fu~iFZ(TC#Џ8ϊ6tC}"=sV-7}Y ͺ,TIe;\'Ugca̬H)kH)yvl{ove:(vzc=w RQZk3R[b93xJſOLC(Nfε4p l< 3o2ɗUČk\Jl^ `f5PȜ77m ǠSI}qDSӝS2vR,7$$EC,:%죳*BdFvvgˠ ԃjyJ[ʋn[{ 1h$~zcuyn3X[pܒ]ck1`lZ|'v-VQ.Ljȇ:x^rۚ>kuʫ^4j@ReAش5Xd$<@jqR(6:O\t[(j}Phw Z\FWqx8-e%NWGV@<ݞΡ'We.`; 9vX;2PUdžĤI7OaJ|Qbqlh~tVz&fmXՒkf o%T!SXd?Ǧ&hǮ |eW 1Iv/B @ ;7 Դ } | ;~:]qT858 8@;/*khq .]#O4PCQ=A=35P *kL2IC⨑s<Pg EτkX,h }4?;!~ f@?OjiiNc,nZ%ى8y| 6G{miۉ P^(3G@@B}T[&'s¿lB+S1UNRIJt 8zJ[J)kP]K:"2 )j ~ F}6- ^!8xd-cB!*"kgXF=er@6aƢi:#N|tlئ 0utzľUjB3ESģj{ґ:!'T BuQX׊|hʺX&*2.YOٍ~Ѭ25eQY AH/.r k(ۯFwTx~0+5v\Z~}dόiI.@c2$*0dn 2sXr", lyym\dfxb+ s#V~ Zw\{C~0J;@!hsSDn"qe0=K@+4ѸU)[9怣yq~cɡc~D'밊eV,ڟph\MLi8E  Ơ]GFpncPɱ|SJ>hzN\+[6zLq-9X ۏc'Us]@zl\G"Ζ$n_(܍q5Rv6C f@gRU (a 7.Qq肶>c et`K:4|Zm/2uWLu,u~X8<ZiL7J29< todrxmd]{FZZ%V)0iM&ە˳j'ibᯗ?y(uR-78}:ӂ98bڠ&}P}oWGC '@;/l"A?ѰDD u.Ƕ6fpzݤ[t)C^攢Ot)&5 hiSL3g*-$aw\쩒MኆpRb΀ ;cM%2wiլ9cA%(_ݳbhU; Og(sJ X;Ӑ.ЧihGA[t=IMfpe'R %mޏmYt 9 Wbk۲5"<Zi<.#儲GEJA3H2xAZߦdoLl,C0g @'j}rz94{&yn_4Ztۻ$dgctkRX i}Rj^'a:xwbbn415m2SʿNUNщKsֳ9./U0Dx Y y)ʎ0岭EmdI&W|;t ]olZ^ͩwX߀mB@b_t.F..o;z Foe+K'NoVh:#6&=c!P瘞~?*|<^RPhw0=;޶f'0Gџ!_ cʱoz*G[]g0Ow#QKuw*::0q|o 0AGT~JKazt[tmkcpIVTS_{sC%W`0}+:" by=+dwlf=g ?֋;T G7@JLX ӛ `%=W17b M}fWln}쐮пD%{$Yߢp>}*{pzkB8.(+F#!F#Sm>coXx[e_44u'XftKɧ!`bq| ڳwכ -W0m ĵg-R/Iu[jj雺{u;bһ+3^QH@,ybҭUR왐#-tWJ}3 -5\8dpff29##}E*9vtfr0ɇqortq]Xh*g}ib2ckPv?S3£7@_jrw;׏j>ӇT0}/omii+K,QŃfl/enѩVÜ ߹>Wj翚yd|9Xo'&&gnO7W?׺M._hwAA#f5E% `w ;>i`Q-nN hgWӇix>K#Aa&~Q"A>~kUuj>)Ujý7*tpB, Gqe߇A#=3/yp7dhz3(V_PoA+eL0Ovb'@?J/SOXj = g^Knvlϑdwߡ6~:;IA0gA @GO*<h;H?+vUThh î@=s.;  GbO[iVWً1yaUSkuJP˂ͮwo?z.ogc\*ԿG/Qxԯ{T3h* wQ'_S`+_)Eڐ6y;:)蘌bZɷF{gLRmK?OJ[j :Q}mGRb]3wz@$gA+٥z '%}zSb < Z@hHh7=aý D@<)߫|=9_! WZ* <XBŏGeFa( F~w~M#1!ksw+fueohKF򂃦T#w=m\nXsabl>4IvK51j$s F摄ۚG?HQ[ |dg\l H6L^e -ZYo`y넳gٗnE*x؈4V {{MDx<5U XN6kqC,hv-Y͸}>#+Pē|}S7=;X7kS /ai}/_'9E#|Q nj'ދ" EQPv] e+6BL63iX<( . lsN"Kף"%XAD `e-+mm{FGA2k (jA]vhu;$`۹Iv2j)c;>2{8ё ,)sx hFXv+b +uč5*$*ڽj9ߑ=!N'AO/O<4}Vň"_]}F@_o9R`S<עeVyu{c֜,gDg<6)}H%Gb?P؉Ro/f2~e.`dwX q(4Idk$ X[ւ9f-̽ĕWY!u9ϵFٕ7Զ A+ C _{Wx8zNo.~+ۯ@)]yW|,T)~Vv u|3.ve^%`z',gralZl8yYᖹ*WvWj5q|SBׅuG'[kHj]]PQ}- 7ukCwbF!ݖ"6Lp{P[B昹9en?oVJ7ckҎ|cT>` SZnH\fwG@N}T`P1|2190:QEG:4Zɳ.#qj:,r@#'=/y<|@J NǼ[2#YXN,= D-=!j:˚^Y+`0&|1 q|~pſ>Fxte,ck@Ӳr,&DwɂT`cK=8Dcʍ:µݭ5T9B=.;4 |up0sȕ. 9ꝘJVЉ K2U  guьA)$fnEjٷZ>I.jh#;DNaBz!n@/ܬ*aIBIxtfwmw|B ~eVQsn:3mYSĵY-*ų,۲ Ljete(mղJtųkA+ Y_ rrEIkOI!oVr&I` h'Yгҗ?X@.ORW,5~f n:>(*]v&tmYGT_ "PDB45mÅ.[I0߻NE4thͱey}Ʀl 5]Vr|,"?gLvtr,c}Hyzyna5+Ζxc ^s+iHq)K><×Fv՜X"TJK̾PWNd#v~\k2ZgFݎ%o,ߘ^4dA#%0|#{sij5MKwԄ| U|S:P>,KIr v]?~wwW6u|C| l|ϲ+aj_65[cޚa ֵX+E]%NM"},µwF@kܣ N18z{Kp,Yǵ7l>M& ΪX& O#5ؖ:ji2boT&yVeRx{͋Y٦ U|R0Kf-(lun K}EmaZ(o1IuHPu8/ /ׄX SC܊J; Q(E޸BwDD?P >=8pB*"#j7ߋEtG#]TNJ)D0QE g3-b{" tTZtE{w:P3J?Z.9q hSyW18 ZelY̵b[_t T9 BaBqg_a:=>uJ.nv N/q7}#ŶH8YE@bR_@+ {,ߴqzEfW7Z;ibO@$`Hm.j4u߻;N%)M Va&xJS+ELp?E8SoFYn<7-VE!|DU$ {⚵M/Z⵹Vd*tWl=l>.>  R7!s셵~$<]ZyMܞ55SG~Cz+s%C $7IK㣳ň>wo'u"T?hŲEi\<]Xu:Z)RjFxݘPxݹؚMVs{i9m{RJγ^o2%>W8+%=?@jKX"ze='Qiư?Q} A$tvxH-t_MH#II$IA~[.J$Ax KZZeF=F #%Ӆ~&Ixyҗ};&[xMG- Q>(>Ʃg V^ 2atAmQ`#n;$4RcёK0? +ދ?.  Q6J[e9w+P'ē\ s{@s{"ZO '%̊ٗ;t6n= VŲ.[=0Z>k0)={4mZg.B<"<|@@-isAu7 BA[t)yV=?]L\c!Bu=  }{ʘGK&6?"_uM.xtH+v]WYbSO8=s#nGYѢ<Ju}Q.3 IDضQ$U&n}ʝf |oqWڡ}Mx uu\%K굚VI: Q=a󪲰^Fv(VwItGM'B R\{p0){DardO4@!< zJF@P[H}N6M~`3b`EJw#\G YTÌIr9vIٌgMLI6j! F3P#1-Pi4B_^5w9n430oY w*Wfg{cjsm{T z3΀og6 [sf[|w@مMvHCS_t;bO&n.xO0Y 7ͰF˅ўua*x݅1tgϻ0Aoԅ-]LCIi0GTh+K6X^W!q2D ̓z `4 ˠy5~@?‹J \i(ɖU.sW_(KBk gث~ ɶ".`{[jJ; L7L8z7FZ*?'`FZa2.RĮK؍v]`FZ*.0V&#m>NdÔgE9Y=iފ$ϊ9 dYוJ; l4,RM!dW-m:[Up)Bd~;H@Zj䇕#A$hl }ۮG^w#*u f~Oٚ*6k1`JgA׮*g۵./+Uʈ*Z~ݥ _>S/C V[/AU`",bMWd8ܬh&\P"N:e]|0K!ʹeu(LКNAH7@ybeN|L ۽2N֖ NL{ݛX>ol͂9fHw~pj-3]^6) U!@=d:JlRQqMO5HY(JH(=!&z xۃTx4ػ$=) +rwJ]cg43#tPqGAM ]=ʖe].H$xkW8Xe>ƽWrt :\CݢLd'@pQ` wY3baƇ7ǘˮlqͮo' ?؞ ?M>PC\VB\g9jlflt'{=* t{ .T4 .;/nxEѼktacSa%B@/t_Å{n)'V-*~Q@%n25:\Rd<$zduQ5 7YSj f)4{x 77H3r* 3Eq^P7Kn ԭ-VKÊefF{akNZ2]dA?}IG$T$)8Z CbMI'p&1G>eg#H͖jq/ҧOߓ{i Pex$LI0&ä2YzA6 F8*XᜊX0*R\ò-9a4Cqw ވ*P5EtqyN\bk/q3|Z*ܗܠ~;MSt/޴\뇺ZM Lo m-C*`: XQ*|8*0G oW{#YU!V/VS*$K2 ],}˓>I0$h2)|*ݒ P?nR&pZKߓ vπ>*~g5`twwuˌqxҩxs"cܜy" jʕN>jmacE8pI+1@+0s)XT`TL>E'j$.Pw~!=} pIǻ!&iKuilV yR(~.7>(.;%0, })؞#Ohנx #Gd%acf)s͒ۮT,pǁzN?SS~u)x8[駱$}-`Xs]1: tz!W eTL0s+0IVWrOW|$B }Laהmfٸ[":B͎|vq}cmE n5c;z!)lc^@9 {x624&/ B!ٝza!jy0 q b41h>э</~Q%jB8 ZˎEA܍ ȴe qy8 z65ZѕM~.H.ޅ:TC貑dt7BS1ǀrJA>-*$>c\.A V4 c^&/N^p׀P"S;Kܐ\+[x-HJo2k}. 9g u$R]3Kf-0BEv56*(ohWP8Gڃ1zڃ< P|cek>kM+oK&'@O&1#qt z7b>d6+ASϒ`J,|M.'caيeV P^}95Ez:Q,p˩NԖ@poӖWN\L>)4b 9L&i.1h3,YC~ jf9_5=Zhq+G:׷»khQ.+P&{)jS#~ +17 +#>Z)ZPq6x ^Yv/@_fqߊ ާI>}byn)5V˥?};Nٛ[.}G}fmʺX&h;3m짊mM\ipA^ VTa&]y|aqeB }[CŮ^~^eg3uߦ_LpG >}Nd#v8~xd(/E`K7Z$Êe3Kjvj5/uթ=/u諾U቟N<'0yʥ²$e:niG'l}wOJ}곥 з\[b4^yReEkmZz,ߴ˞!P'< 6+a['C џ6ሡc[(ի) &) 3IZ5*{܁N/dj雺k' : a%h$VjqGOA1C.wITWtaz*VKWt8q_*1Do7iXƞPvtEGSaGGV3$pYo Ȭ^gY_շhn1S6~βZER n.ʷ?τw@뛓wån }l.qVtԘ<&x6S_^Pvg\{ KsWGl˹ 9.өyN7e^_Ϻc+Z|z[Tmo eU(m~OJڸI;F1V0+~7z(] \ џ4kdz΃{DYG#@"`Ǡ8GX~'~B(Y!G+ >x?eG󝚽'Y.Mu:drЍ yg+* gP96eGNQFTfi9M|.bM6ctMwkTP.w*ʎ0FY]oƧw2_[ѐBѡQuNSGA:K*[O6㆕bv"710>ZwO^]a:*|Wf{6,c(fdJY6azF2V⦮&?6\1cgt3az$,T:&L4#oP8ah%RlWRJ.-:=w4Ƿѽa?:L [[{Dz/~TG4K[t`(̼w2gf?_KnOÎlD+4bdA)+5|Rԡb$n uXwp#[׏J᠑f8/mϷ*ٌ]-%+ctWKMs,~O1O?M )0 g~r>f?( M62[\ h~ X]̆$Yvz;1( XY ϐ)JV(T]S1%U_&װ8*:.7jNDS)ʛ$!ZjN,qtxWnX>)x4Of*ֶeU| Z_8AbI^j_UH(ou9~h,7ǣyVVisr{gWjM߯ys / _BwcϏNn;ND !r֞җ*s8 z2*Յ+ht~4{N*9R|,vҭT8/u5CKhv7mr-mZgv{>yvXc=//ALQDY%{ ޛYT7dc @62pzb V^^zB#3Ϥ$)؃P n(49 RgX\v8Z\g.-aFȫdLI:!^>Pq$Ge& h%o\'Zt3Fy|!¡42SC LjRR FȞ _5Rqqڂ:<;Z{,{B l($vIK{}XY0FK| }PHk 䟣9ve*ozsLπVYlGܿ4L3L}B[d}1ف8 <T = L|v*4MY7c*[pIPB% #y-d[]ȩo^WO*~#LGe^N(okq+rn㴙݀ܣ̄uQ_hi3?Ƕhy-7fWs\_aS߀g9s/j~!!/LwovαVb'^Jƿ ίnnn%ⲕךNׂ+,^}M+|9m_=8I8Ųm6519MM_^s܍fK/=8'~j3OY+^7aC`F 7tX+I}g@gp+T-JB$6?' ijfI~1t 0A$[[Nt=aý D@<)nX)\Ci$-C@T5@y2#m C8~˜~w~kGh4e\hj{ᗾ>͊تYAˑ}yo~rJkTKYۿlk polyCub/man/0000755000176200001440000000000015172466713012456 5ustar liggesuserspolyCub/man/sfg2gpc.Rd0000644000176200001440000000344515120305241014263 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/sfg2gpc.R \name{sfg2gpc} \alias{sfg2gpc} \title{Convert polygonal \code{"sfg"} to \code{"gpc.poly"}} \usage{ sfg2gpc(object) } \arguments{ \item{object}{a \code{"POLYGON"} or \code{"MULTIPOLYGON"} \code{"sfg"} object.} } \value{ The converted polygon of class \code{"gpc.poly"}. If package \pkg{gpclib} is not available, \code{sfg2gpc} will just return the \code{pts} slot of the \code{"gpc.poly"} (no formal class) with a warning. } \description{ Package \pkg{polyCub} implements a converter from class \code{"\link[sf:st_polygon]{(MULTI)POLYGON}"} of package \CRANpkg{sf} to \code{"gpc.poly"} of package \CRANpkg{gpclib} such that \code{\link{polyCub.exact.Gauss}} can be used with simple feature polygons. } \note{ Package \pkg{gpclib} is required for the formal class definition of a \code{"gpc.poly"}. } \examples{ \dontshow{if (requireNamespace("sf")) withAutoprint(\{ # examplesIf} ## use example polygons from example(plotpolyf, ask = FALSE) letterR # a simple "xylist" letterR.sfg <- sf::st_polygon(lapply(letterR, function(xy) rbind(cbind(xy$x, xy$y), c(xy$x[1], xy$y[1])))) letterR.sfg stopifnot(identical(letterR, xylist(letterR.sfg))) \dontshow{ stopifnot(identical(rep(letterR, 2), xylist(sf::st_multipolygon(list(letterR.sfg, letterR.sfg))))) } ## convert sf "POLYGON" to a "gpc.poly" letterR.gpc_from_sfg <- sfg2gpc(letterR.sfg) letterR.gpc_from_sfg \dontshow{ if (is(letterR.gpc_from_sfg, "gpc.poly") && requireNamespace("spatstat.geom")) { letterR.xylist_from_gpc <- xylist(letterR.gpc_from_sfg) # with hole info stopifnot(identical(letterR, lapply(letterR.xylist_from_gpc, `[`, 1:2))) }} \dontshow{\}) # examplesIf} } \seealso{ \code{\link{xylist}} } \author{ Sebastian Meyer } \keyword{methods} \keyword{spatial} polyCub/man/polyCub.midpoint.Rd0000644000176200001440000000606115172341742016201 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/polyCub.midpoint.R \name{polyCub.midpoint} \alias{polyCub.midpoint} \title{Two-Dimensional Midpoint Rule} \usage{ polyCub.midpoint(polyregion, f, ..., eps = NULL, dimyx = NULL, plot = FALSE) } \arguments{ \item{polyregion}{a polygonal integration domain. It can be any object coercible to the \pkg{spatstat.geom} class \code{"\link[spatstat.geom]{owin}"} via a corresponding \code{\link[spatstat.geom]{as.owin}}-method. Note that this includes polygons of the classes \code{"gpc.poly"} and \code{"\link[sp:SpatialPolygons-class]{SpatialPolygons}"}, because \pkg{polyCub} defines methods \code{\link{as.owin.gpc.poly}} and \code{\link{as.owin.SpatialPolygons}}, respectively. \pkg{sf} also registers suitable \code{as.owin} methods for its \code{"\link[sf:st_polygon]{(MULTI)POLYGON}"} classes.} \item{f}{a two-dimensional real-valued function. As its first argument it must take a coordinate matrix, i.e., a numeric matrix with two columns, and it must return a numeric vector of length the number of coordinates.} \item{...}{further arguments for \code{f}.} \item{eps}{width and height of the pixels (squares), see \code{\link[spatstat.geom]{as.mask}}.} \item{dimyx}{number of subdivisions in each dimension, see \code{\link[spatstat.geom]{as.mask}}.} \item{plot}{logical indicating if an illustrative plot of the numerical integration should be produced.} } \value{ The approximated value of the integral of \code{f} over \code{polyregion}. } \description{ The surface is converted to a binary pixel image using the \code{\link[spatstat.geom]{as.im.function}} method from package \CRANpkg{spatstat.geom}. The integral under the surface is then approximated as the sum over (pixel area * f(pixel midpoint)). } \examples{ ## a function to integrate (here: isotropic zero-mean Gaussian density) f <- function (s, sigma = 5) exp(-rowSums(s^2)/2/sigma^2) / (2*pi*sigma^2) ## a simple polygon as integration domain hexagon <- list( list(x = c(7.33, 7.33, 3, -1.33, -1.33, 3), y = c(-0.5, 4.5, 7, 4.5, -0.5, -3)) ) if (require("spatstat.geom")) { hexagon.owin <- owin(poly = hexagon) show_midpoint <- function (eps) { plotpolyf(hexagon.owin, f, xlim = c(-8,8), ylim = c(-8,8), use.lattice = FALSE) ## add evaluation points to plot with(as.mask(hexagon.owin, eps = eps), points(expand.grid(xcol, yrow), col = t(m), pch = 20)) title(main = paste("2D midpoint rule with eps =", eps)) } ## show nodes (eps = 0.5) show_midpoint(0.5) ## show pixel image (eps = 0.5) polyCub.midpoint(hexagon.owin, f, eps = 0.5, plot = TRUE) ## use a decreasing pixel size (increasing number of nodes) for (eps in c(5, 3, 1, 0.5, 0.3, 0.1)) cat(sprintf("eps = \%.1f: \%.7f\n", eps, polyCub.midpoint(hexagon.owin, f, eps = eps))) } } \seealso{ Other cubature methods: \code{\link{polyCub}()}, \code{\link{polyCub.SV}()}, \code{\link{polyCub.iso}()} } \concept{cubature methods} \keyword{math} \keyword{spatial} polyCub/man/polyCub.SV.Rd0000644000176200001440000001423315172341742014706 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/polyCub.SV.R \name{polyCub.SV} \alias{polyCub.SV} \title{Product Gauss Cubature over Polygonal Domains} \usage{ polyCub.SV(polyregion, f, ..., nGQ = 20, alpha = NULL, rotation = FALSE, engine = "C", plot = FALSE) } \arguments{ \item{polyregion}{a polygonal domain. The following classes are supported: \code{"\link[spatstat.geom]{owin}"} from package \pkg{spatstat.geom}, \code{"gpc.poly"} from \pkg{gpclib}, \code{"\link[sp:SpatialPolygons-class]{SpatialPolygons}"}, \code{"\link[sp:Polygons-class]{Polygons}"}, and \code{"\link[sp:Polygon-class]{Polygon}"} from package \pkg{sp}, as well as \code{"\link[sf:st_polygon]{(MULTI)POLYGON}"} from package \pkg{sf}. (For these classes, \pkg{polyCub} knows how to get an \code{\link{xylist}}.)} \item{f}{a two-dimensional real-valued function to be integrated over \code{polyregion} (or \code{NULL} to only compute nodes and weights). As its first argument it must take a coordinate matrix, i.e., a numeric matrix with two columns, and it must return a numeric vector of length the number of coordinates.} \item{...}{further arguments for \code{f}.} \item{nGQ}{degree of the one-dimensional Gauss-Legendre quadrature rule (default: 20) as implemented in function \code{\link[statmod]{gauss.quad}} of package \CRANpkg{statmod}. Nodes and weights up to \code{nGQ=60} are cached in \pkg{polyCub}, for larger degrees \pkg{statmod} is required.} \item{alpha}{base-line of the (rotated) polygon at \eqn{x = \alpha} \bibcitep{see|sommariva.vianello2007|for an explication}. If \code{NULL} (default), the midpoint of the x-range of each polygon is chosen if no \code{rotation} is performed, and otherwise the \eqn{x}-coordinate of the rotated point \code{"P"} (see \code{rotation}). If \code{f} has its maximum value at the origin \eqn{(0,0)}, e.g., the bivariate Gaussian density with zero mean, \code{alpha = 0} is a reasonable choice.} \item{rotation}{logical (default: \code{FALSE}) or a list of points \code{"P"} and \code{"Q"} describing the preferred direction. If \code{TRUE}, the polygon is rotated according to the vertices \code{"P"} and \code{"Q"}, which are farthest apart \bibcitep{see|sommariva.vianello2007|}. For convex polygons, this rotation guarantees that all nodes fall inside the polygon.} \item{engine}{character string specifying the implementation to use. Up to \pkg{polyCub} version 0.4-3, the two-dimensional nodes and weights were computed by \R functions and these are still available by setting \code{engine = "R"}. The new C-implementation is now the default (\code{engine = "C"}) and requires approximately 30\% less computation time.\cr The special setting \code{engine = "C+reduce"} will discard redundant nodes at (0,0) with zero weight resulting from edges on the base-line \eqn{x = \alpha} or orthogonal to it. This extra cleaning is only worth its cost for computationally intensive functions \code{f} over polygons which really have some edges on the baseline or parallel to the x-axis. Note that the old \R implementation does not have such unset zero nodes and weights.} \item{plot}{logical indicating if an illustrative plot of the numerical integration should be produced.} } \value{ The approximated value of the integral of \code{f} over \code{polyregion}.\cr In the case \code{f = NULL}, only the computed nodes and weights are returned in a list of length the number of polygons of \code{polyregion}, where each component is a list with \code{nodes} (a numeric matrix with two columns), \code{weights} (a numeric vector of length \code{nrow(nodes)}), the rotation \code{angle}, and \code{alpha}. } \description{ Product Gauss cubature over polygons as proposed by \bibcitet{sommariva.vianello2007}. } \examples{ ## a function to integrate (here: isotropic zero-mean Gaussian density) f <- function (s, sigma = 5) exp(-rowSums(s^2)/2/sigma^2) / (2*pi*sigma^2) ## a simple polygon as integration domain hexagon <- list( list(x = c(7.33, 7.33, 3, -1.33, -1.33, 3), y = c(-0.5, 4.5, 7, 4.5, -0.5, -3)) ) ## image of the function and integration domain plotpolyf(hexagon, f) ## use a degree of nGQ = 3 and show the corresponding nodes polyCub.SV(hexagon, f, nGQ = 3, plot = TRUE) ## extract nodes and weights nw <- polyCub.SV(hexagon, f = NULL, nGQ = 3)[[1]] nrow(nw$nodes) ## manually apply the cubature rule sum(nw$weights * f(nw$nodes)) ## use an increasing number of nodes for (nGQ in c(1:5, 10, 20, 60)) cat(sprintf("nGQ = \%2i: \%.16f\n", nGQ, polyCub.SV(hexagon, f, nGQ = nGQ))) ## polyCub.SV() is the default method used by the polyCub() wrapper polyCub(hexagon, f, nGQ = 3) # calls polyCub.SV() ### now using a simple *rectangular* integration domain rectangle <- list(list(x = c(-1, 7, 7, -1), y = c(-3, -3, 7, 7))) polyCub.SV(rectangle, f, plot = TRUE) ## effect of rotation given a very low nGQ opar <- par(mfrow = c(1,3)) polyCub.SV(rectangle, f, nGQ = 4, rotation = FALSE, plot = TRUE) title(main = "without rotation (default)") polyCub.SV(rectangle, f, nGQ = 4, rotation = TRUE, plot = TRUE) title(main = "standard rotation") polyCub.SV(rectangle, f, nGQ = 4, rotation = list(P = c(0,0), Q = c(2,-3)), plot = TRUE) title(main = "custom rotation") par(opar) ## comparison with the "cubature" package if (requireNamespace("cubature")) { fc <- function (s, sigma = 5) # non-vectorized version of f exp(-sum(s^2)/2/sigma^2) / (2*pi*sigma^2) cubature::hcubature(fc, lowerLimit = c(-1, -3), upperLimit = c(7, 7)) } } \references{ \bibinfo{sommariva.vianello2007}{footer}{ Their MATLAB implementation \samp{polygauss}, on which this R implementation was based, is available (in revised versions) at \url{https://sites.google.com/view/alvisesommarivaunipd/home-page/software/software_matlab} under the GNU GPL (>=2) license.} \bibshow{*} } \seealso{ Other cubature methods: \code{\link{polyCub}()}, \code{\link{polyCub.iso}()}, \code{\link{polyCub.midpoint}()} } \author{ Sebastian Meyer % NOTE: roxygen2 outputs author \emph{after} references in the Rd file, see % \code{roxygen2:::RoxyTopic$public_methods$format}, so do not \bibcite here } \concept{cubature methods} \keyword{math} \keyword{spatial} polyCub/man/coerce-sp-methods.Rd0000644000176200001440000000374715172123737016275 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/coerce-sp-methods.R \name{coerce-sp-methods} \alias{coerce-sp-methods} \alias{as.owin.SpatialPolygons} \alias{as.owin.Polygons} \alias{as.owin.Polygon} \alias{coerce,SpatialPolygons,owin-method} \alias{coerce,Polygons,owin-method} \alias{coerce,Polygon,owin-method} \alias{coerce,Polygon,Polygons-method} \title{Coerce \code{"SpatialPolygons"} to \code{"owin"}} \usage{ as.owin.SpatialPolygons(W, ...) as.owin.Polygons(W, ...) as.owin.Polygon(W, ...) } \arguments{ \item{W}{an object of class \code{"SpatialPolygons"}, \code{"Polygons"}, or \code{"Polygon"}.} \item{...}{further arguments passed to \code{\link[spatstat.geom]{owin}}.} } \value{ The polygon(s) as an \code{"\link[spatstat.geom:owin.object]{owin}"} object. } \description{ Package \pkg{polyCub} implements \code{coerce}-methods (\code{as(object, Class)}) to convert \code{"\link[sp:SpatialPolygons-class]{SpatialPolygons}"} (or \code{"\link[sp:Polygons-class]{Polygons}"} or \code{"\link[sp:Polygon-class]{Polygon}"}) of package \CRANpkg{sp} to \code{"\link[spatstat.geom:owin.object]{owin}"} of package \CRANpkg{spatstat.geom}. They are also available as \code{as.owin.*} functions to support \code{\link{polyCub.midpoint}}. } \examples{ diamond <- list(x = c(1,2,1,0), y = c(1,2,3,2)) # anti-clockwise diamond.sp <- sp::Polygon(lapply(diamond, rev)) # clockwise diamond.Ps <- sp::Polygons(list(diamond.sp), ID = "my diamond") diamond.SpPs <- sp::SpatialPolygons(list(diamond.Ps)) if (require("spatstat.geom")) { diamond.owin <- owin(poly = diamond) diamond.owin_from_Polygon <- as.owin(diamond.sp) stopifnot(all.equal(diamond.owin, diamond.owin_from_Polygon)) ## also for "Polygons" and "SpatialPolygons", using S3 or S4 methods: stopifnot(identical(diamond.owin, as.owin(diamond.Ps))) stopifnot(identical(diamond.owin, as(diamond.SpPs, "owin"))) } } \seealso{ \code{\link{xylist}} } \author{ Sebastian Meyer } \keyword{methods} \keyword{spatial} polyCub/man/coerce-gpc-methods.Rd0000644000176200001440000000407615120305241016401 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/coerce-gpc-methods.R \name{coerce-gpc-methods} \alias{coerce-gpc-methods} \alias{owin2gpc} \alias{gpc2owin} \alias{as.owin.gpc.poly} \title{Conversion between polygonal \code{"owin"} and \code{"gpc.poly"}} \usage{ owin2gpc(object) gpc2owin(object, ...) as.owin.gpc.poly(W, ...) } \arguments{ \item{object}{an object of class \code{"gpc.poly"} or \code{"owin"}, respectively.} \item{...}{further arguments passed to \code{\link[spatstat.geom]{owin}}.} \item{W}{an object of class \code{"gpc.poly"}.} } \value{ The converted polygon of class \code{"gpc.poly"} or \code{"owin"}, respectively. If package \pkg{gpclib} is not available, \code{owin2gpc} will just return the \code{pts} slot of the \code{"gpc.poly"} (no formal class) with a warning. } \description{ Package \pkg{polyCub} implements converters between the classes \code{"\link[spatstat.geom:owin.object]{owin}"} of package \CRANpkg{spatstat.geom} and \code{"gpc.poly"} of package \CRANpkg{gpclib}. } \note{ The converter \code{owin2gpc} requires the package \pkg{gpclib} for the formal class definition of a \code{"gpc.poly"}. It will produce vertices ordered according to the \pkg{sp} convention, i.e. clockwise for normal boundaries and anticlockwise for holes, where, however, the first vertex is \emph{not} repeated! } \examples{ \dontshow{if (requireNamespace("spatstat.geom")) withAutoprint(\{ # examplesIf} ## use example polygons from example(plotpolyf, ask = FALSE) letterR # a simple "xylist" letterR.owin <- spatstat.geom::owin(poly = letterR) letterR.gpc_from_owin <- owin2gpc(letterR.owin) ## warns if "gpclib" is unavailable if (is(letterR.gpc_from_owin, "gpc.poly")) { letterR.xylist_from_gpc <- xylist(letterR.gpc_from_owin) stopifnot(all.equal(letterR, lapply(letterR.xylist_from_gpc, `[`, 1:2))) letterR.owin_from_gpc <- gpc2owin(letterR.gpc_from_owin) stopifnot(all.equal(letterR.owin, letterR.owin_from_gpc)) } \dontshow{\}) # examplesIf} } \seealso{ \code{\link{xylist}} } \author{ Sebastian Meyer } \keyword{methods} \keyword{spatial} polyCub/man/polyCub.Rd0000644000176200001440000000434415172341742014361 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/polyCub.R \name{polyCub} \alias{polyCub} \title{Wrapper Function for the Various Cubature Methods} \usage{ polyCub(polyregion, f, method = c("SV", "midpoint", "iso", "exact.Gauss"), ..., plot = FALSE) } \arguments{ \item{polyregion}{a polygonal domain. The following classes are supported: \code{"\link[spatstat.geom]{owin}"} from package \pkg{spatstat.geom}, \code{"gpc.poly"} from \pkg{gpclib}, \code{"\link[sp:SpatialPolygons-class]{SpatialPolygons}"}, \code{"\link[sp:Polygons-class]{Polygons}"}, and \code{"\link[sp:Polygon-class]{Polygon}"} from package \pkg{sp}, as well as \code{"\link[sf:st_polygon]{(MULTI)POLYGON}"} from package \pkg{sf}. (For these classes, \pkg{polyCub} knows how to get an \code{\link{xylist}}.)} \item{f}{a two-dimensional real-valued function to be integrated over \code{polyregion}. As its first argument it must take a coordinate matrix, i.e., a numeric matrix with two columns, and it must return a numeric vector of length the number of coordinates.\cr For the \code{"exact.Gauss"} \code{method}, \code{f} is ignored since it is specific to the bivariate normal density.} \item{method}{choose one of the implemented cubature methods (partial argument matching is applied), see \code{help("\link{polyCub-package}")} for an overview. Defaults to using product Gauss cubature implemented in \code{\link{polyCub.SV}}.} \item{...}{arguments of \code{f} or of the specific \code{method}.} \item{plot}{logical indicating if an illustrative plot of the numerical integration should be produced.} } \value{ The approximated integral of \code{f} over \code{polyregion}. } \description{ The wrapper function \code{polyCub} can be used to call specific cubature methods via its \code{method} argument. It calls the \code{\link{polyCub.SV}} function by default, which implements general-purpose product Gauss cubature. The desired cubature function should usually be called directly. } \seealso{ Details and examples in the \code{vignette("polyCub")} and on the method-specific help pages. Other cubature methods: \code{\link{polyCub.SV}()}, \code{\link{polyCub.iso}()}, \code{\link{polyCub.midpoint}()} } \concept{cubature methods} \keyword{math} \keyword{spatial} polyCub/man/polyCub.iso.Rd0000644000176200001440000001420415172341742015146 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/polyCub.iso.R \name{polyCub.iso} \alias{polyCub.iso} \alias{.polyCub.iso} \title{Cubature of Isotropic Functions over Polygonal Domains} \usage{ polyCub.iso(polyregion, f, intrfr, ..., center, control = list(), check.intrfr = FALSE, plot = FALSE) .polyCub.iso(polys, intrfr, ..., center, control = list(), .witherror = FALSE) } \arguments{ \item{polyregion}{a polygonal domain. The following classes are supported: \code{"\link[spatstat.geom]{owin}"} from package \pkg{spatstat.geom}, \code{"gpc.poly"} from \pkg{gpclib}, \code{"\link[sp:SpatialPolygons-class]{SpatialPolygons}"}, \code{"\link[sp:Polygons-class]{Polygons}"}, and \code{"\link[sp:Polygon-class]{Polygon}"} from package \pkg{sp}, as well as \code{"\link[sf:st_polygon]{(MULTI)POLYGON}"} from package \pkg{sf}. (For these classes, \pkg{polyCub} knows how to get an \code{\link{xylist}}.)} \item{f}{a two-dimensional real-valued function. As its first argument it must take a coordinate matrix, i.e., a numeric matrix with two columns, and it must return a numeric vector of length the number of coordinates.} \item{intrfr}{a \code{function(R, ...)}, which implements the (analytical) antiderivative of \eqn{r f_r(r)} from 0 to \code{R}. The first argument must be vectorized but not necessarily named \code{R}.\cr If \code{intrfr} is missing, it will be approximated numerically via \preformatted{ integrate(function(r, ...) r * f(cbind(x0 + r, y0), ...), 0, R, ..., control = control) } where \code{c(x0, y0)} is the \code{center} of isotropy. Note that \code{f} will \emph{not} be checked for isotropy.} \item{...}{further arguments for \code{f} or \code{intrfr}.} \item{center}{numeric vector of length 2, the center of isotropy.} \item{control}{list of arguments passed to \code{\link{integrate}}, the quadrature rule used for the line integral along the polygon boundary.} \item{check.intrfr}{logical (or numeric vector) indicating if (for which \code{r}'s) the supplied \code{intrfr} function should be checked against a numerical approximation. This check requires \code{f} to be specified. If \code{TRUE}, the set of test \code{r}'s defaults to a \code{\link{seq}} of length 20 from 1 to the maximum absolute x or y coordinate of any edge of the \code{polyregion}.} \item{plot}{logical indicating if an image of the function should be plotted together with the polygonal domain, i.e., \code{\link{plotpolyf}(polyregion, f, \dots)}.} \item{polys}{something like \code{owin$bdry}, but see \code{\link{xylist}}.} \item{.witherror}{logical indicating if an upper bound for the absolute integration error should be attached as an attribute to the result?} } \value{ The approximate integral of the isotropic function \code{f} over \code{polyregion}.\cr If the \code{intrfr} function is provided (which is assumed to be exact), an upper bound for the absolute integration error is appended to the result as attribute \code{"abs.error"}. It equals the sum of the absolute errors reported by all \code{\link{integrate}} calls (there is one for each edge of \code{polyregion}). } \description{ \code{polyCub.iso} numerically integrates a radially symmetric function \eqn{f(x,y) = f_r(||(x,y)-\boldsymbol{\mu}||)}{f(x,y) = f_r(||(x,y)-\mu||)}, with \eqn{\mu} being the center of isotropy, over a polygonal domain. It internally approximates a line integral along the polygon boundary using \code{\link{integrate}}. The integrand requires the antiderivative of \eqn{r f_r(r)}), which should be supplied as argument \code{intrfr} (\code{f} itself is only required if \code{check.intrfr=TRUE}). The two-dimensional integration problem thereby reduces to an efficient adaptive quadrature in one dimension. If \code{intrfr} is not available analytically, \code{polyCub.iso} can use a numerical approximation (meaning \code{integrate} within \code{integrate}), but the general-purpose cubature method \code{\link{polyCub.SV}} might be more efficient in this case. See \bibcitet{|meyer.held2014|Supplement B, Section 2.4} for mathematical details. \code{.polyCub.iso} is a \dQuote{bare-bone} version of \code{polyCub.iso}. } \examples{ ## we use the example polygon and f (exponential decay) from example(plotpolyf) ## numerical approximation of 'intrfr' (not recommended) (intISOnum <- polyCub.iso(letterR, f, center = fcenter)) ## analytical 'intrfr' ## intrfr(R) = int_0^R r*f(r) dr, for f(r) = dexp(r), gives intrfr <- function (R, rate = 1) pgamma(R, 2, rate) / rate (intISOana <- polyCub.iso(letterR, f, intrfr = intrfr, center = fcenter, check.intrfr = TRUE)) ## f is only used to check 'intrfr' against a numerical approximation stopifnot(all.equal(intISOana, intISOnum, check.attributes = FALSE)) ### polygon area: f(r) = 1, f(x,y) = 1, center does not really matter ## intrfr(R) = int_0^R r*f(r) dr = int_0^R r dr = R^2/2 intrfr.const <- function (R) R^2/2 (area.ISO <- polyCub.iso(letterR, intrfr = intrfr.const, center = c(0,0))) if (require("spatstat.geom")) { # check against area.owin() stopifnot(all.equal(area.owin(owin(poly = letterR)), area.ISO, check.attributes = FALSE)) } } \references{ \bibshow{*} } \seealso{ \code{system.file("include", "polyCubAPI.h", package = "polyCub")} for a full C-implementation of this cubature method (for a \emph{single} polygon). The corresponding C-routine \code{polyCub_iso} can be used by other \R packages, notably \CRANpkg{surveillance}, via \samp{LinkingTo: polyCub} (in the \file{DESCRIPTION}) and \samp{#include } (in suitable \file{/src} files). Note that the \code{intrfr} function must then also be supplied as a C-routine. An example can be found in the package tests. Other cubature methods: \code{\link{polyCub}()}, \code{\link{polyCub.SV}()}, \code{\link{polyCub.midpoint}()} } \author{ Sebastian Meyer The basic mathematical formulation of this efficient integration for radially symmetric functions was ascertained with great support by Emil Hedevang (Dept. of Mathematics, Aarhus University, Denmark) during the Summer School on Topics in Space-Time Modeling and Inference (May 2013, Aalborg, Denmark). } \concept{cubature methods} \keyword{math} \keyword{spatial} polyCub/man/figures/0000755000176200001440000000000013422360357014113 5ustar liggesuserspolyCub/man/figures/logo.png0000644000176200001440000002467713422360357015601 0ustar liggesusersPNG  IHDRX? pHYsod IDATxyTոـauXeQPY\h!@$;FDH".\јnAd,*#,#0[:v߭oy֩iNSUTUOsx, pp)kA7WhF'BTz S؞=;zMִAӁ 4 ڼy@AՁ^ ̜ySuJ\Z;4vAH[h2;;3pͧ~@ 𷐟 {@z\ sw (z^ܖKϞyqo|yևWmL`1éȐS0rπA,Xظ@>1 :ixU[({իA>:uj7iѢ1+W~ͱcN(%8 XX` \ L 32k;3mڹxb))Ss E-z .C؝E.)ےѿ+ ĺuߑ:˖m \Zб='~6;g:a'6]a1=>p'ͪQv ;I@`annwٝIzѸq*-=3s9r$d\ Ah " رX5mHd Z/-Zd?K-uoߐoNZj7Z=p#GlX# l9y;(4 ''ooʻfРdfdq'sŪU23[Q!ؒB 2}zswboP'~[oB͏߲|i(tA14KO=՜C ĈBZhW:_|#rpB[C0׵0/ɓO`֬tjbرc!ի.ͧsC?r?$lQO0XiGfQuѨsL 3wtKEE5?_áC!U?lǐE,dNv,!#Fsᗿl=!`(u᳥  7\,jXeB,1 )pVvRxI˷W} \nYChZFy۵_UV^oѻw .9snSZhcK5ąO.p7ͅ9sZng gўoӴi.V}Cyyi ,!&:6QrGma0ct3loAQĉQw( `.=,X ݦޠC=6O{-'Q燥龈5x[v1d w= OPS'brew+{A!P WICՅ>up6|8؄0N; sƇG!U0]5. }0Z|B3plX"BUYY+,'S Zg`\GЙuK33ˡp\l;ةR̠wo74 ֮- n;ePOj:\9  5ʥR0q,y ziWc^{íDn"ZlŠ!-:-m;Q2Qٜ\[_O&!},"~ dZ?K܅:e<2?  eBI@ftvmbEm?`Psv4Zm^#|I+$c̙s'8LAHxvhȡ9aS*M3mLee!UnL"pTU@m㰁pP1D}ZU^NN~W;† VMnbЧ:Rma׎xgX`Mx&Ǝ}뿏7~ch ~wT)(o,\]WW0~~1Pj5Gg:n {,7N \k3j#2228̓3F)5o[SZ*qrC2L.:3 Zl͸qo2o^u6I ܦ#C #7dN81aـmj_>3i'>qE^`#cǾΗ_B͏Lb`1>\O8^z%x}9>S*XNZ1f Zhʕ!aPnuK]e:mMCc23hnVXhqd#L2[VI R ~ r(pL7QVnu1v,]9sTX$0Nv@DZE+5}),Y2s1$m,1ą!nvZ$4_¤՜7eR[e=]7Q$cKK˙1c AڷWI^.w*%WʅnJ_4Ve3tKJ*No =1vޫ oA"l:5'' 'nNA6QZb6nfՄev[!''ի? <ub=U#f*pJh s@T&(0^U 窫k׏lX{y6Q{Ȧd;a O?vi O] Cόv:N%Z\:G,Zz 6W} L*8h* 4ʛ >"<|̙֭OҪUsmEUY3" ت /tegˡUDBVYgYe 2&b5..>ԩ/>yy(.>8Wns-t3;+nϭ8 sZSdy{^$7C\ȨQog"ʎJ| lh.܅@60vX8zKAHotļyᇯҭ[Hr{`zdB7ƣn=Ca0h+ArVƕ7A5J~6<4D_Vj˅@]z] C{Ȁ.q0:rVƕK YY6c\IY1֮"xb*g *x-Q2}Q'D}ߧ|Gu ,Eh'2`@*횟i]P ёB07c{m[-+1H֝66…ydvWv,esQqs>(on=ۡo'QޤH,r u2ҥ7|M6fժumӁ[& ԉ{iF#+!:!a'~dkl?ʜ9z[3L>_ aOcRZ5.)u2|& ŸD[3Vjldݺb.b k$ €}Xv.-iP (F',vq'ccLf\I(Ҽ%1DYRj%6Nff&͚UNǴzA u?"x@w]Nne!8(zVV{`k0un>%q%:3Zwgb{}JǑ#.tQU ]F"`~"5>hc ?`ߡTǍ>vc`]A9p2sv2 Sb<rOD{GV׼{}b!8 dvxmC_Or29c\ͫvRHv<:V/ICŮIԝvteڟDέL0ffۓ4y5{#ә'B%6b]ŭC\3;=BEff•%8GW}-ּ'ڹ6Gy{y]:u3 F> _N5p֍SH {KKB=zq81MwB= ?iWq< hF [o{ A|KhY(V4'7^ /̃7\?mx áвzv2L1 v 6GU#yT{H@mthcHvox?SA>+,+1te*{M"?zs\vJθ Gf4.>jLF$2mqQͫ`Ś~ڂX`'8XY~hd{}舺R.t*y$:V;ϸJQ= w?<4}.ylgmX`P1ʅFB)>Ӥd=;W9'iVfX`7bՏb=(8Ƀ%P^iXPJ=VĮthxk 5R#'ᔞCc[+ᔞ#qKcUVRe\ Lrp"p"ѕi!cě =D=F< ,.B;[Gpg -b98aԕvx,yl||X`o@D!lX}d22kdT"AKcjdїJ#Cs*n)D=DY@<+,V . j1 =S  !Ju(p,dy Q`$s`Oa G:I<=s΁\+0E>B>(S{S-$B[xʊbBF<񢰂tz>ѕin~JW[ !Xrͨofeͤ mćc^ E5>Gb=XCC"4.Qf&߉"htqv [Wvr{=j!uzDSH6^M/pM/.qhI,%wmŤjX`gZ,z**`X{:v Ǫ=W^f}Vޞ[3& !uZrkvfܧ)6ւY="{#B"Ct# !ZJQ``܅vgF2.FCk+[yd)n΄2Bm$ !2ʹBJ߅N%w(unf]fqZ`IװL,y'-I,ҩz܏(Ы9{^4Vu|DYe֩9RRŵ:ҵJ%]!uZz{(=^ , $.JTz +]!tY֎C`Ţ ^뱬9bYȴ \yOHX`Dz֗OS!X>{ g\h3%T3f}emo \ !BuֹVeo{gKp=H1jX2,A,h 8:(H܅N% i+ lq)W?δiO]Vف=bS\hܲ8q/yj%C !"VڑRjqh4t,Q6LQͫ^{FYu-+[{ q˒2?tqñz؆&Yp2v-phZI].(c:\fuY`I@"yu)|BN ,Err׻Fbi-`u)l#y 8=酸zq$FpTqScKeS{V׋B{V(Vj2qYb|{XOҿ:{ȉSXS' ;5SV p,k j)Ew&(i zyNA>NҾ~C؃RຶC؃B׵B-Tyb _K ,p,ZH]D=H ܱG &e<1)ז6" AfGy, 9D=JxZaL83cC8ڰfa ܣqiGq0(.M`-)RN  pcK(8(yq?>?VByÌ}}3,qPinXv1ˏm;* . -|whO" b&:)˶S%l8 Wn}旭,0 RT]'׵3o\ R+z5dڳr`BGsDإ6arӥ\[$v)s],#x;d5J0QdhgX,¿v1[Aq <~܇(i 8p<%s r.n K:Cl9 7L Yir}†`a(*jh =@fNRpQ!+5U?- |w+> 1ۏr8p~`ݺڪYd0cx@S(T_̙SZ)AYY@ z–B;GfLfmUr<1`,0{S>0 x}yu+ff2`cT|5!}VN~//Lmy pp= 7JٷCG)n_15 S`BA"y'3fx0r~;=x- )ЫXd9}ިL\hß/f͂y" 6%]o(b`7 {=ʻp :^-niVx6j~נ@AH?@;L ͞L ۔j \P$)ζnxު1> GGeT?+x,p bsLs1O&U"dѢ2z-gW3r6CiqmaЙʄN+acdF/͆ !lGmƄ#3 n=C(S}= 'CϞ[U-.-ZS0{Z FM2/QQ])hEؤr-/7̫M0b̛o Qaq46/ /,XyRX96hߩ!k@~>\Yr>#kLjCJOGi , XΝ0z4?Py>OZ }BAp90u*tdR`**w};j+QԵiY m1'yo2224/߆KG9oZkI;P{_ֶ؉ )f eIDAT9 c0"նmU nJ\ ^ C~>x6C$s, ,4>#-l4AM ާ-4 ;Ri9vVe8TQx  ܏ Bܲ{b| ,X g] c PᏮKrbVq: bwȞVW[gz^,-`ނ*nBpg!`_BAH„?ByBMzBwgUE-#ͪ!+sBF<a[0zb KC %gnuxB'3\csm 뿌B.7&BGcsԷõw?EPQ[" A-_SByעF A~ V0 |uDl~ <V ?q6R"l:?5oBE@Y3N4ANݰ xM8X>$ͯx k *Vu1a Y-3W f-;oB4B0xcRd  QIMl 쨂EŰӉ'j;\q'|# T_K&p-8Z[xMx ̪'mϽAp<#‹.t4(+2K6T˥59+MNpïGkC湕WC=3ύGXpND͍fM`6ح=Dۙup ߢ18[PsKڀ-U0'kغF=LPޭ!Bбu~] Ja_k `w3B)G߄k MA]M}5i~mh:&whؚgm_dd|u^]V#Qh:c[}x\$ ɢu>d}>&ը\5iL΁<&tcB:mEͶSӇ`4ʻr  \N@mM|ZmEl[Rô44Nxx#&龈U^@FfC,8;oB$io"Y o)VAeh"buy! 0F+!|Zc_[">Cs'{Z! l rT I!vprPddX~ˋJ u0_IG3:1ihK<[ ԋG,+7!1x4.'I#u! Sat$z^o~za$F<.B )l]c(]05' 7:4!Q`s ->Yf5mӡu=RRX߁F,N|/(5w*S^JLۚvUR6=D% 0 ؛([K)`hHa#x m)La^ƾ_|Q5" q!!-`zޘTďO"ȭ# l9my`Ltr4IP]kB8:=?%8*lը`\X७P? P^i7ٟ!gQP Gm"MvsPNB CA:z`?߃UETA?LpB;p`_,+i|wAo>Yr;QHc <[PaQalпUm'J+੥0UX\ZYvQg=]Kgsd.n05(JpɈm!-aпmu(g;a{l[D:~z,Dؽd$IN HK`ʇ܊[&"2v7PiwQa/ʫvX Qg?_̈́߆,R~,A\XTQ`dH %FwV-1pm VQbipP0z {:L7qsMr9XZDSlFԉiٙpcxBh1Aq)L^ i~SQ_ r Hsjujy  P1@43$к*%FbABg[^^lApThJ uT5e  hY~A?:X8?tIENDB`polyCub/man/polyCub-package.Rd0000644000176200001440000000354615167151503015753 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/zzz.R \docType{package} \name{polyCub-package} \alias{polyCub-package} \title{Cubature over Polygonal Domains} \description{ The \R package \pkg{polyCub} implements \emph{cubature} (numerical integration) over \emph{polygonal} domains. It solves the problem of integrating a continuously differentiable function \eqn{f(x,y)} over simple closed polygons. } \details{ \pkg{polyCub} provides the following cubature methods: \describe{ \item{\code{\link{polyCub.SV}}:}{ General-purpose \emph{product Gauss cubature} \bibcitep{sommariva.vianello2007} } \item{\code{\link{polyCub.midpoint}}:}{ Simple \emph{two-dimensional midpoint rule} based on \code{\link[spatstat.geom]{as.im.function}} from \CRANpkg{spatstat.geom} \bibcitep{R:spatstat.geom} } \item{\code{\link{polyCub.iso}}:}{ Adaptive cubature for \emph{radially symmetric functions} via line \code{\link{integrate}()} along the polygon boundary \bibcitep{|meyer.held2014|Supplement B, Section 2.4} } } A brief description and benchmark experiment of the above cubature methods can be found in the \code{vignette("polyCub")}. There is also \code{\link{polyCub.exact.Gauss}}, intended to accurately (but slowly) integrate the \emph{bivariate Gaussian density}; however, this implementation is disabled as of \pkg{polyCub} 0.9.0: it needs a reliable implementation of polygon triangulation. \bibcitet{|meyer2010|Section 3.2} discusses and compares some of these methods. } \note{ To cite package \pkg{polyCub} in publications, please use \code{citation("polyCub")}: \Sexpr[results=rd,stage=build]{tools::toRd(citation("polyCub"))} } \references{ \bibshow{*} } \seealso{ \code{vignette("polyCub")} For the special case of a rectangular domain along the axes (e.g., a bounding box), the \CRANpkg{cubature} package is more appropriate. } \author{ Sebastian Meyer } polyCub/man/checkintrfr.Rd0000644000176200001440000000502515171755501015244 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/polyCub.iso.R \name{checkintrfr} \alias{checkintrfr} \title{Check the Integral of \eqn{r f_r(r)}} \usage{ checkintrfr(intrfr, f, ..., center, control = list(), rs = numeric(0L), tolerance = control$rel.tol) } \arguments{ \item{intrfr}{a \code{function(R, ...)}, which implements the (analytical) antiderivative of \eqn{r f_r(r)} from 0 to \code{R}. The first argument must be vectorized but not necessarily named \code{R}.\cr If \code{intrfr} is missing, it will be approximated numerically via \preformatted{ integrate(function(r, ...) r * f(cbind(x0 + r, y0), ...), 0, R, ..., control = control) } where \code{c(x0, y0)} is the \code{center} of isotropy. Note that \code{f} will \emph{not} be checked for isotropy.} \item{f}{a two-dimensional real-valued function. As its first argument it must take a coordinate matrix, i.e., a numeric matrix with two columns, and it must return a numeric vector of length the number of coordinates.} \item{...}{further arguments for \code{f} or \code{intrfr}.} \item{center}{numeric vector of length 2, the center of isotropy.} \item{control}{list of arguments passed to \code{\link{integrate}}, the quadrature rule used for the line integral along the polygon boundary.} \item{rs}{numeric vector of upper bounds for which to check the validity of \code{intrfr}. If it has length 0 (default), no checks are performed.} \item{tolerance}{of \code{\link{all.equal.numeric}} when comparing \code{intrfr} results with numerical integration. Defaults to the relative tolerance used for \code{integrate}.} } \value{ The \code{intrfr} function, invisibly. If only \code{f} was given, an \code{integrate}-based approximation of \code{intrfr} is returned. } \description{ This function is auxiliary to \code{\link{polyCub.iso}} for the cubature of a radially symmetric function \eqn{f(x,y) = f_r(||(x,y)-\boldsymbol{\mu}||)}{f(x,y) = f_r(||(x,y)-\mu||)}, with \eqn{\mu} being the center of isotropy, over a polygonal domain. The (analytical) integral of \eqn{r f_r(r)} from 0 to \eqn{R}, \code{intrfr}, is checked against an \code{\link{integrate}}-based approximation for various values (\code{rs}) of the upper bound \eqn{R}. A warning is issued if inconsistencies are found. } \examples{ f_const <- function (coords) rep(1, nrow(coords)) intrfr_const <- function (R) R^2/2 # = \int_0^R r f_r(r) dr checkintrfr(intrfr_const, f = f_const, center = c(0,0), rs = 1:10) # OK checkintrfr(function(R) R, f = f_const, center = c(0,0), rs = 1:10) # warns } polyCub/man/xylist.Rd0000644000176200001440000000752415172123737014305 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/xylist.R \name{xylist} \alias{xylist} \alias{xylist.owin} \alias{xylist.sfg} \alias{xylist.gpc.poly} \alias{xylist.SpatialPolygons} \alias{xylist.Polygons} \alias{xylist.Polygon} \alias{xylist.default} \title{Convert Various Polygon Classes to a Simple List of Vertices} \usage{ xylist(object, ...) \method{xylist}{owin}(object, ...) \method{xylist}{sfg}(object, ...) \method{xylist}{gpc.poly}(object, ...) \method{xylist}{SpatialPolygons}(object, reverse = TRUE, ...) \method{xylist}{Polygons}(object, reverse = TRUE, ...) \method{xylist}{Polygon}(object, reverse = TRUE, ...) \method{xylist}{default}(object, ...) } \arguments{ \item{object}{an object of one of the supported spatial classes.} \item{...}{(unused) argument of the generic.} \item{reverse}{logical (\code{TRUE}) indicating if the vertex order of the \pkg{sp} classes should be reversed to get the \code{xylist}/\code{owin} convention.} } \value{ Applying \code{xylist} to a polygon object, one gets a simple list, where each component (polygon) is a list of \code{"x"} and \code{"y"} coordinates. These represent vertex coordinates following \pkg{spatstat.geom}'s \code{"owin"} convention (anticlockwise order for exterior boundaries, without repeating any vertex). } \description{ Different packages concerned with spatial data use different polygon specifications, which sometimes becomes very confusing (see Details below). To be compatible with the various polygon classes, package \pkg{polyCub} uses an S3 class \code{"xylist"}, which represents a polygonal domain (of potentially multiple polygons) by its core feature only: a list of lists of vertex coordinates (see the "Value" section below). The generic function \code{xylist} can deal with the following polygon classes: \itemize{ \item \code{"\link[spatstat.geom:owin.object]{owin}"} from package \pkg{spatstat.geom} \item \code{"gpc.poly"} from package \pkg{gpclib} \item \code{"\link[sp:Polygons-class]{Polygons}"} from package \pkg{sp} (as well as \code{"\link[sp:Polygon-class]{Polygon}"} and \code{"\link[sp:SpatialPolygons-class]{SpatialPolygons}"}) \item \code{"\link[sf:st_polygon]{(MULTI)POLYGON}"} from package \pkg{sf} } The (somehow useless) default \code{xylist}-method does not perform any transformation but only ensures that the polygons are not closed (first vertex not repeated). } \details{ Polygon specifications differ with respect to: \itemize{ \item is the first vertex repeated? \item which ring direction represents holes? } Package overview: \describe{ \item{\pkg{spatstat.geom}:}{\code{"owin"} does \emph{not repeat} the first vertex, and anticlockwise = normal boundary, clockwise = hole. This convention is also used for the return value of \code{xylist}.} \item{\pkg{sp}:}{\emph{Repeat} first vertex at the end (closed), anticlockwise = hole, clockwise = normal boundary} \item{\pkg{sf}:}{\emph{Repeat} first vertex at the end (closed), clockwise = hole, anticlockwise = normal boundary; \emph{however}, \pkg{sf} does not check the ring direction by default, so it cannot be relied upon.} \item{\pkg{gpclib}:}{There seem to be no such conventions for polygons of class \code{"gpc.poly"}.} } Thus, for polygons from \pkg{sf} and \pkg{gpclib}, \code{xylist} needs to check the ring direction, which makes these two formats the least efficient for integration domains in \pkg{polyCub}. } \examples{ diamond <- list(x = c(1,2,1,0), y = c(1,2,3,2)) # anti-clockwise diamond.sp <- sp::Polygon(lapply(diamond, rev)) # clockwise diamond.Ps <- sp::Polygons(list(diamond.sp), ID = "my diamond") diamond.SpPs <- sp::SpatialPolygons(list(diamond.Ps)) stopifnot(identical(xylist(diamond.sp), list(diamond))) stopifnot(identical(xylist(diamond.Ps), list(diamond))) stopifnot(identical(xylist(diamond.SpPs), list(diamond))) } \author{ Sebastian Meyer } \keyword{methods} \keyword{spatial} polyCub/man/plotpolyf.Rd0000644000176200001440000000544615172466713015006 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/plotpolyf.R \name{plotpolyf} \alias{plotpolyf} \title{Plot Polygonal Domain on Image of Bivariate Function} \usage{ plotpolyf(polyregion, f, ..., npixel = 100, cuts = 15, col = rev(heat.colors(cuts + 1)), lwd = 3, xlim = NULL, ylim = NULL, use.lattice = TRUE, print.args = list()) } \arguments{ \item{polyregion}{a polygonal domain. The following classes are supported: \code{"\link[spatstat.geom]{owin}"} from package \pkg{spatstat.geom}, \code{"gpc.poly"} from \pkg{gpclib}, \code{"\link[sp:SpatialPolygons-class]{SpatialPolygons}"}, \code{"\link[sp:Polygons-class]{Polygons}"}, and \code{"\link[sp:Polygon-class]{Polygon}"} from package \pkg{sp}, as well as \code{"\link[sf:st_polygon]{(MULTI)POLYGON}"} from package \pkg{sf}. (For these classes, \pkg{polyCub} knows how to get an \code{\link{xylist}}.)} \item{f}{a two-dimensional real-valued function. As its first argument it must take a coordinate matrix, i.e., a numeric matrix with two columns, and it must return a numeric vector of length the number of coordinates.} \item{...}{further arguments for \code{f}.} \item{npixel}{numeric vector of length 1 or 2 setting the number of pixels in each dimension.} \item{cuts}{number of cut points in the \eqn{z} dimension. The range of function values will be divided into \code{cuts+1} levels.} \item{col}{color vector used for the function levels.} \item{lwd}{line width of the polygon edges.} \item{xlim, ylim}{numeric vectors of length 2 setting the axis limits. \code{NULL} means using the bounding box of \code{polyregion}.} \item{use.lattice}{logical indicating if \pkg{lattice} graphics (\code{\link[lattice]{levelplot}}) should be used.} \item{print.args}{a list of arguments passed to \code{\link[lattice]{print.trellis}} for plotting the produced \code{\link[lattice:trellis.object]{"trellis"}} object (if \code{use.lattice = TRUE}). The \code{print} step is omitted if \code{print.args} is not a list.} } \description{ Produces a combined plot of a polygonal domain and an image of a bivariate function, using either \code{\link[lattice:levelplot]{lattice::levelplot}} or \code{\link{image}}. } \examples{ ### a polygonal domain (a simplified version of spatstat.data::letterR$bdry) letterR <- list( list(x = c(2.7, 3, 3.3, 3.9, 3.7, 3.4, 3.8, 3.7, 3.4, 2, 2, 2.7), y = c(1.7, 1.6, 0.7, 0.7, 1.3, 1.8, 2.2, 2.9, 3.3, 3.3, 0.7, 0.7)), list(x = c(2.6, 2.6, 3, 3.2, 3), y = c(2.2, 2.7, 2.7, 2.5, 2.2)) ) ### f: isotropic exponential decay fr <- function(r, rate = 1) dexp(r, rate = rate) fcenter <- c(2,3) f <- function (s, rate = 1) fr(sqrt(rowSums(t(t(s)-fcenter)^2)), rate = rate) ### plot plotpolyf(letterR, f, use.lattice = FALSE) plotpolyf(letterR, f, use.lattice = TRUE) } \author{ Sebastian Meyer } \keyword{hplot} polyCub/man/polyCub.exact.Gauss.Rd0000644000176200001440000000542415167155715016554 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/polyCub.exact.Gauss.R \name{polyCub.exact.Gauss} \alias{polyCub.exact.Gauss} \title{Quasi-Exact Cubature of the Bivariate Normal Density (DEFUNCT)} \usage{ polyCub.exact.Gauss(polyregion, mean = c(0, 0), Sigma = diag(2), plot = FALSE) } \arguments{ \item{polyregion}{a \code{"gpc.poly"} polygon or something that can be coerced to this class, e.g., an \code{"owin"} polygon (via \code{\link{owin2gpc}}), or an \code{"sfg"} polygon (via \code{\link{sfg2gpc}}).} \item{mean, Sigma}{mean and covariance matrix of the bivariate normal density to be integrated.} \item{plot}{logical indicating if an illustrative plot of the numerical integration should be produced. Note that the \code{polyregion} will be transformed (shifted and scaled).} } \value{ The integral of the bivariate normal density over \code{polyregion}. Two attributes are appended to the integral value: \item{nEval}{ number of triangles over which the standard bivariate normal density had to be integrated, i.e. number of calls to \code{\link[mvtnorm]{pmvnorm}} and \code{\link[stats]{pnorm}}, the former of which being the most time-consuming operation. } \item{error}{ Approximate absolute integration error stemming from the error introduced by the \code{nEval} \code{\link[mvtnorm]{pmvnorm}} evaluations. For this reason, the cubature method is in fact only quasi-exact (as is the \code{pmvnorm} function). } } \description{ This cubature method is \strong{defunct} as of \pkg{polyCub} version 0.9.0. It relied on \code{tristrip()} from package \CRANpkg{gpclib} for polygon triangulation, but that package did not have a \acronym{FOSS} license and was no longer maintained on a mainstream repository.\cr Contributions to resurrect this cubature method are welcome: an alternative implementation for constrained polygon triangulation is needed, see \url{https://github.com/bastistician/polyCub/issues/2}. } \details{ The bivariate Gaussian density can be integrated based on a triangulation of the (transformed) polygonal domain, using formulae from the \bibcitet{R:Abramowitz+Stegun:1972} handbook (Section 26.9, Example 9, pp. 956f.). This method is quite cumbersome because the A&S formula is only for triangles where one vertex is the origin (0,0). For each triangle we have to check in which of the 6 outer regions of the triangle the origin (0,0) lies and adapt the signs in the formula appropriately: \eqn{(AOB+BOC-AOC)} or \eqn{(AOB-AOC-BOC)} or \eqn{(AOB+AOC-BOC)} or \eqn{(AOC+BOC-AOB)} or \ldots. However, the most time consuming step is the evaluation of \code{\link[mvtnorm]{pmvnorm}}. } \references{ \bibshow{*} } \seealso{ \code{\link{circleCub.Gauss}} for quasi-exact cubature of the isotropic Gaussian density over a circular domain. } \keyword{math} \keyword{spatial} polyCub/man/circleCub.Gauss.Rd0000644000176200001440000000335315167766605015734 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/circleCub.R \name{circleCub.Gauss} \alias{circleCub.Gauss} \title{Integration of the Isotropic Gaussian Density over Circular Domains} \usage{ circleCub.Gauss(center, r, mean, sd) } \arguments{ \item{center}{numeric vector of length 2 (center of the circle).} \item{r}{numeric (radius of the circle). Several radii may be supplied.} \item{mean}{numeric vector of length 2 (mean of the bivariate Gaussian density).} \item{sd}{numeric (common standard deviation of the isotropic Gaussian density in both dimensions).} } \value{ The integral value (one for each supplied radius). } \description{ This function calculates the integral of the bivariate, isotropic Gaussian density (i.e., \eqn{\Sigma} = \code{sd^2*diag(2)}) over a circular domain via the cumulative distribution function \code{pchisq} of the (non-central) Chi-Squared distribution \bibcitep{|R:Abramowitz+Stegun:1972|Formula 26.3.24}. } \note{ The non-centrality parameter of the evaluated chi-squared distribution equals the squared distance between the \code{mean} and the \code{center}. If this becomes too large, the result becomes inaccurate, see \code{\link{pchisq}}. } \examples{ circleCub.Gauss(center=c(1,2), r=3, mean=c(4,5), sd=6) ## compare with cubature over a polygonal approximation of a circle d2norm <- function (s, mean, sd) dnorm(s[,1], mean=mean[1], sd=sd) * dnorm(s[,2], mean=mean[2], sd=sd) if (requireNamespace("spatstat.geom")) { # for the disc() npoly <- 32 # increase this for a closer match disc.poly <- spatstat.geom::disc(radius=3, centre=c(1,2), npoly=npoly) polyCub.iso(disc.poly, d2norm, mean=c(4,5), sd=6, center=c(4,5)) } } \references{ \bibshow{*} } \keyword{math} \keyword{spatial} polyCub/DESCRIPTION0000644000176200001440000000330415172637442013410 0ustar liggesusersPackage: polyCub Title: Cubature over Polygonal Domains Version: 0.9.4 Date: 2026-04-24 Authors@R: c( person("Sebastian", "Meyer", email = "seb.meyer@fau.de", role = c("aut","cre","trl"), comment = c(ORCID = "0000-0002-1791-9449")), person("Leonhard", "Held", role = "ths"), person("Michael", "Hoehle", role = "ths") ) Description: Numerical integration of continuously differentiable functions f(x,y) over simple closed polygonal domains. The following cubature methods are implemented: product Gauss cubature (Sommariva and Vianello, 2007, ), the simple two-dimensional midpoint rule (wrapping 'spatstat.geom' functions), and adaptive cubature for radially symmetric functions via line integrate() along the polygon boundary (Meyer and Held, 2014, , Supplement B). For simple integration along the axes, the 'cubature' package is more appropriate. License: GPL-2 URL: https://github.com/bastistician/polyCub BugReports: https://github.com/bastistician/polyCub/issues Note: Building the package requires R >= 4.6.0 for \bibshow{} et al. Depends: R (>= 3.4.0), methods Imports: grDevices, graphics, stats, sp (>= 1.0-11) Suggests: spatstat.geom, lattice, mvtnorm, statmod, sf, cubature, litedown (>= 0.9), microbenchmark VignetteBuilder: litedown RoxygenNote: 7.3.3 NeedsCompilation: yes Packaged: 2026-04-24 09:20:44 UTC; smeyer Author: Sebastian Meyer [aut, cre, trl] (ORCID: ), Leonhard Held [ths], Michael Hoehle [ths] Maintainer: Sebastian Meyer Repository: CRAN Date/Publication: 2026-04-24 10:00:02 UTC